1: #!/usr/bin/perl -wT
   2: 
   3: # This is designed to show a homegrown getline routine.
   4: # It is intended to be a drop in for modules such as
   5: # IO::Socket::SSL which currently (v0.78) does not have a
   6: # getline method.
   7: # 
   8: # To try this out, save the entire chunk to a file and run it.
   9: # It will show some tests, and then a benchmark between it,
  10: # a straight call to the parent class, and a placebo class which
  11: # has the same number of method lookups.  It actually fairs 
  12: # pretty well against all the things that perl and the kernel
  13: # are doing for you.
  14: #
  15: # For early adopters, you can actually put this in place in a 
  16: # sub class of IO::Socket::SSL and get getline support now. (I've
  17: # submitted the code to the author and am waiting to see if it
  18: # meets his approval.  I know the code looks simple, but it makes
  19: # a lot of things possible.
  20: #
  21: # TODO: See if I can use Tie::Handle and get <$fh> to work.
  22: 
  23: ### sample package containing the getline methods
  24: package MYO::File;
  25: 
  26: ### ISA can be any IO::Handle object (including IO::Socket::SSL)
  27: use strict;
  28: use vars qw(@ISA);
  29: use IO::File ();
  30: @ISA = qw(IO::File);
  31: 
  32: ### declare some package globals (to create aliases later
  33: use vars qw( $buffer $b_read );
  34: 
  35: sub new {
  36:   my $type  = shift;
  37:   my $class = ref($type) || $type || __PACKAGE__;
  38:   my $fh    = __PACKAGE__->SUPER::new( @_ );
  39: 
  40:   return undef unless defined $fh;
  41:   
  42:   $ { *$fh }{read_length} = 2 ** 11; # (2k)
  43:   $ { *$fh }{buffer}      = '';
  44:   $ { *$fh }{bytes_read}  = 0;
  45:   $ { *$fh }{eol}         = "\012";
  46: 
  47:   bless $fh, $class;
  48: }
  49: 
  50: sub getline {
  51:   @_ == 1 or die 'usage: $io->getline()';
  52:   my $fh = shift;
  53:   local *buffer = \${ *$fh }{buffer};
  54:   local *b_read = \${ *$fh }{bytes_read};
  55:   my $read_len  = $ { *$fh }{read_length};
  56:   my $eol       = $ { *$fh }{eol};
  57: 
  58:   my $index = index($buffer, $eol);
  59:   
  60:   while( $index == -1 ){
  61:     $fh->sysread( $buffer, $read_len, length($buffer) )
  62:       or return undef;
  63:     
  64:     $index = index($buffer, $eol);
  65:   }
  66: 
  67:   $index  += length($eol);
  68:   $b_read += $index;
  69: 
  70:   return substr($buffer, 0, $index, '');
  71: } 
  72: 
  73: sub seek {
  74:   my $fh = shift;
  75:   $fh->SUPER::seek( @_ );
  76:   $ { *$fh }{buffer} = '';
  77:   $ { *$fh }{bytes_read} = 0;
  78: }
  79: 
  80: sub tell {
  81:   my $fh = shift;
  82:   $ { *$fh }{bytes_read};
  83: }
  84: 
  85: ### allow for modification of eol
  86: sub end_of_line {
  87:   my $fh = shift;
  88:   return $ { *$fh }{eol} unless @_;
  89:   $ { *$fh }{eol} = shift;
  90: }
  91: 
  92: ### allow for modification of read_length
  93: sub getline_read_length {
  94:   my $fh = shift;
  95:   return $ { *$fh }{read_length} unless @_;
  96:   $ { *$fh }{read_length} = shift;
  97: }
  98: 
  99: ###------------------------------------------------###
 100: 
 101: ### control group (check the effect of method lookups
 102: package Placebo;
 103: use vars qw(@ISA);
 104: use IO::File ();
 105: @ISA = qw(IO::File);
 106: sub getline{ shift()->SUPER::getline() }
 107: sub seek{    shift()->SUPER::seek( @_ ) }
 108: sub tell{    shift()->SUPER::tell( @_ ) }
 109: 
 110: ###------------------------------------------------###
 111: 
 112: ### back to package main to do some tests
 113: package main;
 114: 
 115: use IO::File ();
 116: 
 117: ### set up three file handles
 118: my $fh1 =  IO::File->new($0,'r');
 119: my $fh2 = MYO::File->new($0,'r');
 120: my $fh3 =   Placebo->new($0,'r');
 121: 
 122: ### read line test
 123: for( 1..3 ){
 124:   print "$_ fh1: ".$fh1->getline();
 125:   print "$_ fh2: ".$fh2->getline();
 126:   print "$_ fh3: ".$fh3->getline();
 127: }
 128: 
 129: ### seek and tell test
 130: print "tell fh1: ", $fh1->tell(), "\n";
 131: print "tell fh2: ", $fh2->tell(), "\n";
 132: print "tell fh3: ", $fh3->tell(), "\n";
 133: $fh1->seek(0,0);
 134: $fh2->seek(0,0);
 135: $fh3->seek(0,0);
 136: print "tell fh1: ", $fh1->tell(), "\n";
 137: print "tell fh2: ", $fh2->tell(), "\n";
 138: print "tell fh3: ", $fh3->tell(), "\n";
 139: 
 140: ###------------------------------------------------###
 141: 
 142: ### do a benchmark
 143: use Benchmark qw(cmpthese);
 144: cmpthese(1000,{
 145:   IO_File  => sub { $fh1->seek(0,0);
 146:                     for(1..70){ my $line = $fh1->getline(); } },
 147:   MYO_File => sub { $fh2->seek(0,0);
 148:                     for(1..70){ my $line = $fh2->getline(); } },
 149:   Placebo  => sub { $fh3->seek(0,0);
 150:                     for(1..70){ my $line = $fh3->getline(); } },
 151: });
 152: exit;