jpred/lib/IO/String.pm

   1 package IO::String;
   2
   3 # Copyright 1998-2005 Gisle Aas.
   4 #
   5 # This library is free software; you can redistribute it and/or
   6 # modify it under the same terms as Perl itself.
   7
   8 require 5.005_03;
   9 use strict;
  10 use vars qw($VERSION $DEBUG $IO_CONSTANTS);
  11 $VERSION = "1.08";    # $Date: 2007/02/05 17:08:37 $
  12
  13 use Symbol ();
  14
  15 sub new {
  16   my $class = shift;
  17   my $self = bless Symbol::gensym(), ref($class) || $class;
  18   tie *$self, $self;
  19   $self->open(@_);
  20   return $self;
  21 }
  22
  23 sub open {
  24   my $self = shift;
  25   return $self->new(@_) unless ref($self);
  26
  27   if (@_) {
  28     my $bufref = ref( $_[0] ) ? $_[0] : \$_[0];
  29     $$bufref = "" unless defined $$bufref;
  30     *$self->{buf} = $bufref;
  31   } else {
  32     my $buf = "";
  33     *$self->{buf} = \$buf;
  34   }
  35   *$self->{pos} = 0;
  36   *$self->{lno} = 0;
  37   return $self;
  38 }
  39
  40 sub pad {
  41   my $self = shift;
  42   my $old  = *$self->{pad};
  43   *$self->{pad} = substr( $_[0], 0, 1 ) if @_;
  44   return "\0" unless defined($old) && length($old);
  45   return $old;
  46 }
  47
  48 sub dump {
  49   require Data::Dumper;
  50   my $self = shift;
  51   print Data::Dumper->Dump( [$self], ['*self'] );
  52   print Data::Dumper->Dump( [ *$self{HASH} ], ['$self{HASH}'] );
  53   return;
  54 }
  55
  56 sub TIEHANDLE {
  57   print "TIEHANDLE @_\n" if $DEBUG;
  58   return $_[0] if ref( $_[0] );
  59   my $class = shift;
  60   my $self = bless Symbol::gensym(), $class;
  61   $self->open(@_);
  62   return $self;
  63 }
  64
  65 sub DESTROY {
  66   print "DESTROY @_\n" if $DEBUG;
  67 }
  68
  69 sub close {
  70   my $self = shift;
  71   delete *$self->{buf};
  72   delete *$self->{pos};
  73   delete *$self->{lno};
  74   undef *$self if $] eq "5.008";    # workaround for some bug
  75   return 1;
  76 }
  77
  78 sub opened {
  79   my $self = shift;
  80   return defined *$self->{buf};
  81 }
  82
  83 sub binmode {
  84   my $self = shift;
  85   return 1 unless @_;
  86
  87   # XXX don't know much about layers yet :-(
  88   return 0;
  89 }
  90
  91 sub getc {
  92   my $self = shift;
  93   my $buf;
  94   return $buf if $self->read( $buf, 1 );
  95   return undef;
  96 }
  97
  98 sub ungetc {
  99   my $self = shift;
 100   $self->setpos( $self->getpos() - 1 );
 101   return 1;
 102 }
 103
 104 sub eof {
 105   my $self = shift;
 106   return length( ${ *$self->{buf} } ) <= *$self->{pos};
 107 }
 108
 109 sub print {
 110   my $self = shift;
 111   if ( defined $\ ) {
 112     if ( defined $, ) {
 113       $self->write( join( $,, @_ ) . $\ );
 114     } else {
 115       $self->write( join( "", @_ ) . $\ );
 116     }
 117   } else {
 118     if ( defined $, ) {
 119       $self->write( join( $,, @_ ) );
 120     } else {
 121       $self->write( join( "", @_ ) );
 122     }
 123   }
 124   return 1;
 125 }
 126 *printflush = \*print;
 127
 128 sub printf {
 129   my $self = shift;
 130   print "PRINTF(@_)\n" if $DEBUG;
 131   my $fmt = shift;
 132   $self->write( sprintf( $fmt, @_ ) );
 133   return 1;
 134 }
 135
 136 my ( $SEEK_SET, $SEEK_CUR, $SEEK_END );
 137
 138 sub _init_seek_constants {
 139   if ($IO_CONSTANTS) {
 140     require IO::Handle;
 141     $SEEK_SET = &IO::Handle::SEEK_SET;
 142     $SEEK_CUR = &IO::Handle::SEEK_CUR;
 143     $SEEK_END = &IO::Handle::SEEK_END;
 144   } else {
 145     $SEEK_SET = 0;
 146     $SEEK_CUR = 1;
 147     $SEEK_END = 2;
 148   }
 149 }
 150
 151 sub seek {
 152   my ( $self, $off, $whence ) = @_;
 153   my $buf = *$self->{buf} || return 0;
 154   my $len = length($$buf);
 155   my $pos = *$self->{pos};
 156
 157   _init_seek_constants() unless defined $SEEK_SET;
 158
 159   if ( $whence == $SEEK_SET ) { $pos = $off }
 160   elsif ( $whence == $SEEK_CUR ) { $pos += $off }
 161   elsif ( $whence == $SEEK_END ) { $pos = $len + $off }
 162   else                           { die "Bad whence ($whence)" }
 163   print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG;
 164
 165   $pos = 0 if $pos < 0;
 166   $self->truncate($pos) if $pos > $len;    # extend file
 167   *$self->{pos} = $pos;
 168   return 1;
 169 }
 170
 171 sub pos {
 172   my $self = shift;
 173   my $old  = *$self->{pos};
 174   if (@_) {
 175     my $pos = shift || 0;
 176     my $buf = *$self->{buf};
 177     my $len = $buf ? length($$buf) : 0;
 178     $pos = $len if $pos > $len;
 179     *$self->{pos} = $pos;
 180   }
 181   return $old;
 182 }
 183
 184 sub getpos { shift->pos; }
 185
 186 *sysseek = \&seek;
 187 *setpos  = \&pos;
 188 *tell    = \&getpos;
 189
 190 sub getline {
 191   my $self = shift;
 192   my $buf  = *$self->{buf} || return;
 193   my $len  = length($$buf);
 194   my $pos  = *$self->{pos};
 195   return if $pos >= $len;
 196
 197   unless ( defined $/ ) {    # slurp
 198     *$self->{pos} = $len;
 199     return substr( $$buf, $pos );
 200   }
 201
 202   unless ( length $/ ) {     # paragraph mode
 203                              # XXX slow&lazy implementation using getc()
 204     my $para = "";
 205     my $eol  = 0;
 206     my $c;
 207     while ( defined( $c = $self->getc ) ) {
 208       if ( $c eq "\n" ) {
 209         $eol++;
 210         next if $eol > 2;
 211       } elsif ( $eol > 1 ) {
 212         $self->ungetc($c);
 213         last;
 214       } else {
 215         $eol = 0;
 216       }
 217       $para .= $c;
 218     }
 219     return $para;    # XXX wantarray
 220   }
 221
 222   my $idx = index( $$buf, $/, $pos );
 223   if ( $idx < 0 ) {
 224
 225     # return rest of it
 226     *$self->{pos} = $len;
 227     $. = ++*$self->{lno};
 228     return substr( $$buf, $pos );
 229   }
 230   $len = $idx - $pos + length($/);
 231   *$self->{pos} += $len;
 232   $. = ++*$self->{lno};
 233   return substr( $$buf, $pos, $len );
 234 }
 235
 236 sub getlines {
 237   die "getlines() called in scalar context\n" unless wantarray;
 238   my $self = shift;
 239   my ( $line, @lines );
 240   push( @lines, $line ) while defined( $line = $self->getline );
 241   return @lines;
 242 }
 243
 244 sub READLINE {
 245   goto &getlines if wantarray;
 246   goto &getline;
 247 }
 248
 249 sub input_line_number {
 250   my $self = shift;
 251   my $old  = *$self->{lno};
 252   *$self->{lno} = shift if @_;
 253   return $old;
 254 }
 255
 256 sub truncate {
 257   my $self = shift;
 258   my $len  = shift || 0;
 259   my $buf  = *$self->{buf};
 260   if ( length($$buf) >= $len ) {
 261     substr( $$buf, $len ) = '';
 262     *$self->{pos} = $len if $len < *$self->{pos};
 263   } else {
 264     $$buf .= ( $self->pad x ( $len - length($$buf) ) );
 265   }
 266   return 1;
 267 }
 268
 269 sub read {
 270   my $self = shift;
 271   my $buf  = *$self->{buf};
 272   return undef unless $buf;
 273
 274   my $pos = *$self->{pos};
 275   my $rem = length($$buf) - $pos;
 276   my $len = $_[1];
 277   $len = $rem if $len > $rem;
 278   return undef if $len < 0;
 279   if ( @_ > 2 ) {    # read offset
 280     substr( $_[0], $_[2] ) = substr( $$buf, $pos, $len );
 281   } else {
 282     $_[0] = substr( $$buf, $pos, $len );
 283   }
 284   *$self->{pos} += $len;
 285   return $len;
 286 }
 287
 288 sub write {
 289   my $self = shift;
 290   my $buf  = *$self->{buf};
 291   return unless $buf;
 292
 293   my $pos  = *$self->{pos};
 294   my $slen = length( $_[0] );
 295   my $len  = $slen;
 296   my $off  = 0;
 297   if ( @_ > 1 ) {
 298     $len = $_[1] if $_[1] < $len;
 299     if ( @_ > 2 ) {
 300       $off = $_[2] || 0;
 301       die "Offset outside string" if $off > $slen;
 302       if ( $off < 0 ) {
 303         $off += $slen;
 304         die "Offset outside string" if $off < 0;
 305       }
 306       my $rem = $slen - $off;
 307       $len = $rem if $rem < $len;
 308     }
 309   }
 310   substr( $$buf, $pos, $len ) = substr( $_[0], $off, $len );
 311   *$self->{pos} += $len;
 312   return $len;
 313 }
 314
 315 *sysread  = \&read;
 316 *syswrite = \&write;
 317
 318 sub stat {
 319   my $self = shift;
 320   return   unless $self->opened;
 321   return 1 unless wantarray;
 322   my $len = length ${ *$self->{buf} };
 323
 324   return (
 325     undef, undef,    # dev, ino
 326     0666,            # filemode
 327     1,               # links
 328     $>,              # user id
 329     $),              # group id
 330     undef,           # device id
 331     $len,            # size
 332     undef,           # atime
 333     undef,           # mtime
 334     undef,           # ctime
 335     512,             # blksize
 336     int( ( $len + 511 ) / 512 )    # blocks
 337   );
 338 }
 339
 340 sub FILENO {
 341   return undef;                    # XXX perlfunc says this means the file is closed
 342 }
 343
 344 sub blocking {
 345   my $self = shift;
 346   my $old = *$self->{blocking} || 0;
 347   *$self->{blocking} = shift if @_;
 348   return $old;
 349 }
 350
 351 my $notmuch = sub { return };
 352
 353 *fileno   = $notmuch;
 354 *error    = $notmuch;
 355 *clearerr = $notmuch;
 356 *sync     = $notmuch;
 357 *flush    = $notmuch;
 358 *setbuf   = $notmuch;
 359 *setvbuf  = $notmuch;
 360
 361 *untaint   = $notmuch;
 362 *autoflush = $notmuch;
 363 *fcntl     = $notmuch;
 364 *ioctl     = $notmuch;
 365
 366 *GETC    = \&getc;
 367 *PRINT   = \&print;
 368 *PRINTF  = \&printf;
 369 *READ    = \&read;
 370 *WRITE   = \&write;
 371 *SEEK    = \&seek;
 372 *TELL    = \&getpos;
 373 *EOF     = \&eof;
 374 *CLOSE   = \&close;
 375 *BINMODE = \&binmode;
 376
 377 sub string_ref {
 378   my $self = shift;
 379   return *$self->{buf};
 380 }
 381 *sref = \&string_ref;
 382
 383 1;
 384
 385 __END__
 386
 387 =head1 NAME
 388
 389 IO::String - Emulate file interface for in-core strings
 390
 391 =head1 SYNOPSIS
 392
 393  use IO::String;
 394  $io = IO::String->new;
 395  $io = IO::String->new($var);
 396  tie *IO, 'IO::String';
 397
 398  # read data
 399  <$io>;
 400  $io->getline;
 401  read($io, $buf, 100);
 402
 403  # write data
 404  print $io "string\n";
 405  $io->print(@data);
 406  syswrite($io, $buf, 100);
 407
 408  select $io;
 409  printf "Some text %s\n", $str;
 410
 411  # seek
 412  $pos = $io->getpos;
 413  $io->setpos(0);        # rewind
 414  $io->seek(-30, -1);
 415  seek($io, 0, 0);
 416
 417 =head1 DESCRIPTION
 418
 419 The C<IO::String> module provides the C<IO::File> interface for in-core
 420 strings.  An C<IO::String> object can be attached to a string, and
 421 makes it possible to use the normal file operations for reading or
 422 writing data, as well as for seeking to various locations of the string.
 423 This is useful when you want to use a library module that only
 424 provides an interface to file handles on data that you have in a string
 425 variable.
 426
 427 Note that perl-5.8 and better has built-in support for "in memory"
 428 files, which are set up by passing a reference instead of a filename
 429 to the open() call. The reason for using this module is that it
 430 makes the code backwards compatible with older versions of Perl.
 431
 432 The C<IO::String> module provides an interface compatible with
 433 C<IO::File> as distributed with F<IO-1.20>, but the following methods
 434 are not available: new_from_fd, fdopen, format_write,
 435 format_page_number, format_lines_per_page, format_lines_left,
 436 format_name, format_top_name.
 437
 438 The following methods are specific to the C<IO::String> class:
 439
 440 =over 4
 441
 442 =item $io = IO::String->new
 443
 444 =item $io = IO::String->new( $string )
 445
 446 The constructor returns a newly-created C<IO::String> object.  It
 447 takes an optional argument, which is the string to read from or write
 448 into.  If no $string argument is given, then an internal buffer
 449 (initially empty) is allocated.
 450
 451 The C<IO::String> object returned is tied to itself.  This means
 452 that you can use most Perl I/O built-ins on it too: readline, <>, getc,
 453 print, printf, syswrite, sysread, close.
 454
 455 =item $io->open
 456
 457 =item $io->open( $string )
 458
 459 Attaches an existing IO::String object to some other $string, or
 460 allocates a new internal buffer (if no argument is given).  The
 461 position is reset to 0.
 462
 463 =item $io->string_ref
 464
 465 Returns a reference to the string that is attached to
 466 the C<IO::String> object.  Most useful when you let the C<IO::String>
 467 create an internal buffer to write into.
 468
 469 =item $io->pad
 470
 471 =item $io->pad( $char )
 472
 473 Specifies the padding to use if
 474 the string is extended by either the seek() or truncate() methods.  It
 475 is a single character and defaults to "\0".
 476
 477 =item $io->pos
 478
 479 =item $io->pos( $newpos )
 480
 481 Yet another interface for reading and setting the current read/write
 482 position within the string (the normal getpos/setpos/tell/seek
 483 methods are also available).  The pos() method always returns the
 484 old position, and if you pass it an argument it sets the new
 485 position.
 486
 487 There is (deliberately) a difference between the setpos() and seek()
 488 methods in that seek() extends the string (with the specified
 489 padding) if you go to a location past the end, whereas setpos()
 490 just snaps back to the end.  If truncate() is used to extend the string,
 491 then it works as seek().
 492
 493 =back
 494
 495 =head1 BUGS
 496
 497 In Perl versions < 5.6, the TIEHANDLE interface was incomplete.
 498 If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will
 499 not do anything on an C<IO::String> handle.  See L<perltie> for
 500 details.
 501
 502 =head1 SEE ALSO
 503
 504 L<IO::File>, L<IO::Stringy>, L<perlfunc/open>
 505
 506 =head1 COPYRIGHT
 507
 508 Copyright 1998-2005 Gisle Aas.
 509
 510 This library is free software; you can redistribute it and/or
 511 modify it under the same terms as Perl itself.
 512
 513 =cut