"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/IO/String.pm" (5 Apr 2016, 11461 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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: 2005/12/05 12:00:47 $
   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