tlperl: added IO::String

git-svn-id: svn://tug.org/texlive/trunk@22978 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 551 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/IO/String.pm b/Master/tlpkg/tlperl/lib/IO/String.pm
new file mode 100644
index 00000000000..4bc8e719601
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/String.pm
@@ -0,0 +1,551 @@
+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: 2005/12/05 12:00:47 $
+
+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