--- /dev/null
+package IO::String;
+
+# Copyright 1998-2005 Gisle Aas.
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+require 5.005_03;
+use strict;
+use vars qw($VERSION $DEBUG $IO_CONSTANTS);
+$VERSION = "1.08"; # $Date: 2007/02/05 17:08:37 $
+
+use Symbol ();
+
+sub new {
+ my $class = shift;
+ my $self = bless Symbol::gensym(), ref($class) || $class;
+ tie *$self, $self;
+ $self->open(@_);
+ return $self;
+}
+
+sub open {
+ my $self = shift;
+ return $self->new(@_) unless ref($self);
+
+ if (@_) {
+ my $bufref = ref( $_[0] ) ? $_[0] : \$_[0];
+ $$bufref = "" unless defined $$bufref;
+ *$self->{buf} = $bufref;
+ } else {
+ my $buf = "";
+ *$self->{buf} = \$buf;
+ }
+ *$self->{pos} = 0;
+ *$self->{lno} = 0;
+ return $self;
+}
+
+sub pad {
+ my $self = shift;
+ my $old = *$self->{pad};
+ *$self->{pad} = substr( $_[0], 0, 1 ) if @_;
+ return "\0" unless defined($old) && length($old);
+ return $old;
+}
+
+sub dump {
+ require Data::Dumper;
+ my $self = shift;
+ print Data::Dumper->Dump( [$self], ['*self'] );
+ print Data::Dumper->Dump( [ *$self{HASH} ], ['$self{HASH}'] );
+ return;
+}
+
+sub TIEHANDLE {
+ print "TIEHANDLE @_\n" if $DEBUG;
+ return $_[0] if ref( $_[0] );
+ my $class = shift;
+ my $self = bless Symbol::gensym(), $class;
+ $self->open(@_);
+ return $self;
+}
+
+sub DESTROY {
+ print "DESTROY @_\n" if $DEBUG;
+}
+
+sub close {
+ my $self = shift;
+ delete *$self->{buf};
+ delete *$self->{pos};
+ delete *$self->{lno};
+ undef *$self if $] eq "5.008"; # workaround for some bug
+ return 1;
+}
+
+sub opened {
+ my $self = shift;
+ return defined *$self->{buf};
+}
+
+sub binmode {
+ my $self = shift;
+ return 1 unless @_;
+
+ # XXX don't know much about layers yet :-(
+ return 0;
+}
+
+sub getc {
+ my $self = shift;
+ my $buf;
+ return $buf if $self->read( $buf, 1 );
+ return undef;
+}
+
+sub ungetc {
+ my $self = shift;
+ $self->setpos( $self->getpos() - 1 );
+ return 1;
+}
+
+sub eof {
+ my $self = shift;
+ return length( ${ *$self->{buf} } ) <= *$self->{pos};
+}
+
+sub print {
+ my $self = shift;
+ if ( defined $\ ) {
+ if ( defined $, ) {
+ $self->write( join( $,, @_ ) . $\ );
+ } else {
+ $self->write( join( "", @_ ) . $\ );
+ }
+ } else {
+ if ( defined $, ) {
+ $self->write( join( $,, @_ ) );
+ } else {
+ $self->write( join( "", @_ ) );
+ }
+ }
+ return 1;
+}
+*printflush = \*print;
+
+sub printf {
+ my $self = shift;
+ print "PRINTF(@_)\n" if $DEBUG;
+ my $fmt = shift;
+ $self->write( sprintf( $fmt, @_ ) );
+ return 1;
+}
+
+my ( $SEEK_SET, $SEEK_CUR, $SEEK_END );
+
+sub _init_seek_constants {
+ if ($IO_CONSTANTS) {
+ require IO::Handle;
+ $SEEK_SET = &IO::Handle::SEEK_SET;
+ $SEEK_CUR = &IO::Handle::SEEK_CUR;
+ $SEEK_END = &IO::Handle::SEEK_END;
+ } else {
+ $SEEK_SET = 0;
+ $SEEK_CUR = 1;
+ $SEEK_END = 2;
+ }
+}
+
+sub seek {
+ my ( $self, $off, $whence ) = @_;
+ my $buf = *$self->{buf} || return 0;
+ my $len = length($$buf);
+ my $pos = *$self->{pos};
+
+ _init_seek_constants() unless defined $SEEK_SET;
+
+ if ( $whence == $SEEK_SET ) { $pos = $off }
+ elsif ( $whence == $SEEK_CUR ) { $pos += $off }
+ elsif ( $whence == $SEEK_END ) { $pos = $len + $off }
+ else { die "Bad whence ($whence)" }
+ print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG;
+
+ $pos = 0 if $pos < 0;
+ $self->truncate($pos) if $pos > $len; # extend file
+ *$self->{pos} = $pos;
+ return 1;
+}
+
+sub pos {
+ my $self = shift;
+ my $old = *$self->{pos};
+ if (@_) {
+ my $pos = shift || 0;
+ my $buf = *$self->{buf};
+ my $len = $buf ? length($$buf) : 0;
+ $pos = $len if $pos > $len;
+ *$self->{pos} = $pos;
+ }
+ return $old;
+}
+
+sub getpos { shift->pos; }
+
+*sysseek = \&seek;
+*setpos = \&pos;
+*tell = \&getpos;
+
+sub getline {
+ my $self = shift;
+ my $buf = *$self->{buf} || return;
+ my $len = length($$buf);
+ my $pos = *$self->{pos};
+ return if $pos >= $len;
+
+ unless ( defined $/ ) { # slurp
+ *$self->{pos} = $len;
+ return substr( $$buf, $pos );
+ }
+
+ unless ( length $/ ) { # paragraph mode
+ # XXX slow&lazy implementation using getc()
+ my $para = "";
+ my $eol = 0;
+ my $c;
+ while ( defined( $c = $self->getc ) ) {
+ if ( $c eq "\n" ) {
+ $eol++;
+ next if $eol > 2;
+ } elsif ( $eol > 1 ) {
+ $self->ungetc($c);
+ last;
+ } else {
+ $eol = 0;
+ }
+ $para .= $c;
+ }
+ return $para; # XXX wantarray
+ }
+
+ my $idx = index( $$buf, $/, $pos );
+ if ( $idx < 0 ) {
+
+ # return rest of it
+ *$self->{pos} = $len;
+ $. = ++*$self->{lno};
+ return substr( $$buf, $pos );
+ }
+ $len = $idx - $pos + length($/);
+ *$self->{pos} += $len;
+ $. = ++*$self->{lno};
+ return substr( $$buf, $pos, $len );
+}
+
+sub getlines {
+ die "getlines() called in scalar context\n" unless wantarray;
+ my $self = shift;
+ my ( $line, @lines );
+ push( @lines, $line ) while defined( $line = $self->getline );
+ return @lines;
+}
+
+sub READLINE {
+ goto &getlines if wantarray;
+ goto &getline;
+}
+
+sub input_line_number {
+ my $self = shift;
+ my $old = *$self->{lno};
+ *$self->{lno} = shift if @_;
+ return $old;
+}
+
+sub truncate {
+ my $self = shift;
+ my $len = shift || 0;
+ my $buf = *$self->{buf};
+ if ( length($$buf) >= $len ) {
+ substr( $$buf, $len ) = '';
+ *$self->{pos} = $len if $len < *$self->{pos};
+ } else {
+ $$buf .= ( $self->pad x ( $len - length($$buf) ) );
+ }
+ return 1;
+}
+
+sub read {
+ my $self = shift;
+ my $buf = *$self->{buf};
+ return undef unless $buf;
+
+ my $pos = *$self->{pos};
+ my $rem = length($$buf) - $pos;
+ my $len = $_[1];
+ $len = $rem if $len > $rem;
+ return undef if $len < 0;
+ if ( @_ > 2 ) { # read offset
+ substr( $_[0], $_[2] ) = substr( $$buf, $pos, $len );
+ } else {
+ $_[0] = substr( $$buf, $pos, $len );
+ }
+ *$self->{pos} += $len;
+ return $len;
+}
+
+sub write {
+ my $self = shift;
+ my $buf = *$self->{buf};
+ return unless $buf;
+
+ my $pos = *$self->{pos};
+ my $slen = length( $_[0] );
+ my $len = $slen;
+ my $off = 0;
+ if ( @_ > 1 ) {
+ $len = $_[1] if $_[1] < $len;
+ if ( @_ > 2 ) {
+ $off = $_[2] || 0;
+ die "Offset outside string" if $off > $slen;
+ if ( $off < 0 ) {
+ $off += $slen;
+ die "Offset outside string" if $off < 0;
+ }
+ my $rem = $slen - $off;
+ $len = $rem if $rem < $len;
+ }
+ }
+ substr( $$buf, $pos, $len ) = substr( $_[0], $off, $len );
+ *$self->{pos} += $len;
+ return $len;
+}
+
+*sysread = \&read;
+*syswrite = \&write;
+
+sub stat {
+ my $self = shift;
+ return unless $self->opened;
+ return 1 unless wantarray;
+ my $len = length ${ *$self->{buf} };
+
+ return (
+ undef, undef, # dev, ino
+ 0666, # filemode
+ 1, # links
+ $>, # user id
+ $), # group id
+ undef, # device id
+ $len, # size
+ undef, # atime
+ undef, # mtime
+ undef, # ctime
+ 512, # blksize
+ int( ( $len + 511 ) / 512 ) # blocks
+ );
+}
+
+sub FILENO {
+ return undef; # XXX perlfunc says this means the file is closed
+}
+
+sub blocking {
+ my $self = shift;
+ my $old = *$self->{blocking} || 0;
+ *$self->{blocking} = shift if @_;
+ return $old;
+}
+
+my $notmuch = sub { return };
+
+*fileno = $notmuch;
+*error = $notmuch;
+*clearerr = $notmuch;
+*sync = $notmuch;
+*flush = $notmuch;
+*setbuf = $notmuch;
+*setvbuf = $notmuch;
+
+*untaint = $notmuch;
+*autoflush = $notmuch;
+*fcntl = $notmuch;
+*ioctl = $notmuch;
+
+*GETC = \&getc;
+*PRINT = \&print;
+*PRINTF = \&printf;
+*READ = \&read;
+*WRITE = \&write;
+*SEEK = \&seek;
+*TELL = \&getpos;
+*EOF = \&eof;
+*CLOSE = \&close;
+*BINMODE = \&binmode;
+
+sub string_ref {
+ my $self = shift;
+ return *$self->{buf};
+}
+*sref = \&string_ref;
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::String - Emulate file interface for in-core strings
+
+=head1 SYNOPSIS
+
+ use IO::String;
+ $io = IO::String->new;
+ $io = IO::String->new($var);
+ tie *IO, 'IO::String';
+
+ # read data
+ <$io>;
+ $io->getline;
+ read($io, $buf, 100);
+
+ # write data
+ print $io "string\n";
+ $io->print(@data);
+ syswrite($io, $buf, 100);
+
+ select $io;
+ printf "Some text %s\n", $str;
+
+ # seek
+ $pos = $io->getpos;
+ $io->setpos(0); # rewind
+ $io->seek(-30, -1);
+ seek($io, 0, 0);
+
+=head1 DESCRIPTION
+
+The C<IO::String> module provides the C<IO::File> interface for in-core
+strings. An C<IO::String> object can be attached to a string, and
+makes it possible to use the normal file operations for reading or
+writing data, as well as for seeking to various locations of the string.
+This is useful when you want to use a library module that only
+provides an interface to file handles on data that you have in a string
+variable.
+
+Note that perl-5.8 and better has built-in support for "in memory"
+files, which are set up by passing a reference instead of a filename
+to the open() call. The reason for using this module is that it
+makes the code backwards compatible with older versions of Perl.
+
+The C<IO::String> module provides an interface compatible with
+C<IO::File> as distributed with F<IO-1.20>, but the following methods
+are not available: new_from_fd, fdopen, format_write,
+format_page_number, format_lines_per_page, format_lines_left,
+format_name, format_top_name.
+
+The following methods are specific to the C<IO::String> class:
+
+=over 4
+
+=item $io = IO::String->new
+
+=item $io = IO::String->new( $string )
+
+The constructor returns a newly-created C<IO::String> object. It
+takes an optional argument, which is the string to read from or write
+into. If no $string argument is given, then an internal buffer
+(initially empty) is allocated.
+
+The C<IO::String> object returned is tied to itself. This means
+that you can use most Perl I/O built-ins on it too: readline, <>, getc,
+print, printf, syswrite, sysread, close.
+
+=item $io->open
+
+=item $io->open( $string )
+
+Attaches an existing IO::String object to some other $string, or
+allocates a new internal buffer (if no argument is given). The
+position is reset to 0.
+
+=item $io->string_ref
+
+Returns a reference to the string that is attached to
+the C<IO::String> object. Most useful when you let the C<IO::String>
+create an internal buffer to write into.
+
+=item $io->pad
+
+=item $io->pad( $char )
+
+Specifies the padding to use if
+the string is extended by either the seek() or truncate() methods. It
+is a single character and defaults to "\0".
+
+=item $io->pos
+
+=item $io->pos( $newpos )
+
+Yet another interface for reading and setting the current read/write
+position within the string (the normal getpos/setpos/tell/seek
+methods are also available). The pos() method always returns the
+old position, and if you pass it an argument it sets the new
+position.
+
+There is (deliberately) a difference between the setpos() and seek()
+methods in that seek() extends the string (with the specified
+padding) if you go to a location past the end, whereas setpos()
+just snaps back to the end. If truncate() is used to extend the string,
+then it works as seek().
+
+=back
+
+=head1 BUGS
+
+In Perl versions < 5.6, the TIEHANDLE interface was incomplete.
+If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will
+not do anything on an C<IO::String> handle. See L<perltie> for
+details.
+
+=head1 SEE ALSO
+
+L<IO::File>, L<IO::Stringy>, L<perlfunc/open>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2005 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
git://source.jalview.org / jabaws.git / blobdiff