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