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