Peek.pm

[japhy]

Description:

Inspired by How to 'peek' at next line while parsing with <>. Update: subclassed Tie::StdHandle, shortened the code considerably.

package Peek;

use Carp;
use Tie::Handle;
use strict;
our @ISA = 'Tie::StdHandle';
our $SILENT = 0;

my %buffer;

=head1 NAME

Peek - interface to allow "peeking" at filehandles

=head1 SYNOPSIS

  use Peek;
  use strict;
  use warnings;

  open FOO, "< somefile" or die "can't open somefile: $!";

  while (<FOO>) {
    chomp;
    print "Current line '$_'\n";
    chomp(my $next = peek FOO);
    print "Next line will be '$next'\n";
  }

  close FOO;

=head1 DESCRIPTION

This installs a method into the C<IO::Handle> class named C<peek()>.  
+If you
call C<peek()> on a filehandle, the filehandle becomes a C<Peek> objec
+t, and
then you can peek at the next lines in the filehandle.

You will be warned about the installation of the filehandle as a C<Pee
+k>
object the first time you call C<peek()> on it.  To silence this, set 
+the
C<$Peek::SILENT> variable to a true value.

=head1 BUGS

I have to call C<tell()> on the filehandle before I turn it into a C<P
+eek>
object, or else the code breaks (in certain conditions).

=head1 AUTHOR

Jeff C<japhy> Pinyan, F<[e-mail]>

Inspired by F<http://www.perlmonks.org/index.pl?node_id=181068>.

=cut


sub TIEHANDLE {
  my ($class, $io) = @_;
  bless $io, $class;
}


sub READLINE {
  my ($io) = @_;
  my $buf = $buffer{$io};

  if (@$buf) {
    if (wantarray) { return splice(@$buf, 0), <$io> }
    else { return shift @$buf }
  }
  else { return <$io> }
}


sub IO::Handle::peek {
  my ($fh) = @_;
  my $name = *$fh{NAME};
  my $obj = tied *$fh;

  unless ($obj and UNIVERSAL::isa($obj, __PACKAGE__)) {
    carp "implementing peek() for $name" unless $Peek::SILENT;

    my $fd = fileno($fh);
    tell $fh;  # XXX - this is needed to workaround a bug (!)

    open my($new_io), "<&$fd" or croak "can't dup $name: $!";
    tie *$fh, __PACKAGE__, $new_io;
    $obj = tied *$fh;
  }

  push @{ $buffer{$obj} }, scalar <$obj>;
  return $buffer{$obj}[-1];
}


1;