Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Peek.pm

by japhy (Canon)
on Jul 11, 2002 at 20:05 UTC ( #181129=snippet: print w/replies, xml ) Need Help??
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<japhy@pobox.com>

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;
Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://181129]
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (6)
As of 2017-05-26 02:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?