diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/IO/String.pm')
-rwxr-xr-x | Master/tlpkg/tlperl.old/lib/IO/String.pm | 551 |
1 files changed, 0 insertions, 551 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/IO/String.pm b/Master/tlpkg/tlperl.old/lib/IO/String.pm deleted file mode 100755 index 4bc8e719601..00000000000 --- a/Master/tlpkg/tlperl.old/lib/IO/String.pm +++ /dev/null @@ -1,551 +0,0 @@ -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 |