From be0f65a017ba3f1cd7b8c130c2dcd73b9fba85ef Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 14:04:57 +0000 Subject: perl-IO-String-1.08 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..38b5474 --- /dev/null +++ b/Changes @@ -0,0 +1,121 @@ +2005-12-05 Gisle Aas + + Release 1.08 + + The untie code in close() just seemed wrong, so just + remove it. The object still seems to get cleaned up + on various versions perl. + + + +2005-10-24 Gisle Aas + + Release 1.07 + + Make sure read() will not return negative values. + + + + +2004-11-05 Gisle Aas + + Release 1.06 + + Make seek() return TRUE when it succeed. It used to + return the new position, but we want to be compatible with + the builtin seek(). + Patch contributed by Kurt M. Brown + + Make print() and printf() return TRUE even when printing + the empty string. The used to return the lenght of the string + printed, but now they always return 1 to be compatible with + the builtins. + + Make binmode() return TRUE unless layers are provided. + + + +2004-04-01 Gisle Aas + + Release 1.05 + + Fix handling of paragraph mode. + + + + +2004-01-08 Gisle Aas + + Release 1.04 + + Documentation fixes by Paul Croome . + + + +2003-10-06 Gisle Aas + + Release 1.03 + + Seek will not reset the input_line_number (aka $.) for the IO::String + object any more. + + Workaround for core dump in close() in perl-5.6.x. + + + +2002-12-27 Gisle Aas + + Release 1.02 + + Complemented the tiehandle interface with SEEK/TELL/EOF/BINMODE. + + Make close($io) untie the object. This make it possible + to avoid memory leaks in perl-5.8 which seems to have problems + with self-ties. Based on patch by Eric Kolve . + + + +2000-01-28 Gisle Aas + + Release 1.01 + + The eof() method had opposite logic. Bug spotted by + Daniel Gruhl + + + +1999-04-12 Gisle Aas + + Release 1.00 + + Perl version 5.005_03 or better is now needed, because that + perl has Chip's no-memory-leak-on-self-tie-patch. + + Documentation update + + + +1998-10-14 Gisle Aas + + Release 0.03 + + Loading of the SEEK_xxx constants from the IO::Handle module + is now optional. The previous way did not work with IO-1.20. + + + +1998-10-12 Gisle Aas + + Release 0.02 + + Added some documentation. + + Fixed $io->stat + + Fixed $io->pad to return the default if it is set to "" + + + +1998-10-07 Gisle Aas + + Release 0.01 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..b7d1d27 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,12 @@ +Changes +MANIFEST +Makefile.PL +README +String.pm +t/close.t +t/para.t +t/read.t +t/seek.t +t/truncate.t +t/write.t +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..bad4378 --- /dev/null +++ b/META.yml @@ -0,0 +1,10 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: IO-String +version: 1.08 +version_from: String.pm +installdirs: site +requires: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..11fac07 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,9 @@ +require 5.005_03; # need self-tie patch + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'IO::String', + VERSION_FROM => 'String.pm', + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, +); diff --git a/README b/README new file mode 100644 index 0000000..56256e8 --- /dev/null +++ b/README @@ -0,0 +1,19 @@ +IO::String is an IO::File (and IO::Handle) compatible class that read +or write data from in-core strings. It is really just a +simplification of what I needed from Eryq's IO-stringy modules. As +such IO::String is a replacement for IO::Scalar. + +Installation as usual: + + perl Makefile.PL + make + make test + make install + +Documentation is embedded in the module. + + +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. diff --git a/String.pm b/String.pm new file mode 100644 index 0000000..4bc8e71 --- /dev/null +++ b/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 module provides the C interface for in-core +strings. An C 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 module provides an interface compatible with +C as distributed with F, 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 class: + +=over 4 + +=item $io = IO::String->new + +=item $io = IO::String->new( $string ) + +The constructor returns a newly-created C 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 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 object. Most useful when you let the C +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 handle. See L for +details. + +=head1 SEE ALSO + +L, L, L + +=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 diff --git a/t/close.t b/t/close.t new file mode 100644 index 0000000..e6b2e5b --- /dev/null +++ b/t/close.t @@ -0,0 +1,36 @@ +#!perl -w + +print "1..1\n"; + +use strict; +use IO::String; + +my $str = "abcd"; + +my $destroyed = 0; + +{ + package MyStr; + @MyStr::ISA = qw(IO::String); + + sub DESTROY { + $destroyed++; + print "DESTROY @_\n"; + } +} + + +my $rounds = 5; + +for (1..$rounds) { + my $io = MyStr->new($str); + die unless $io->getline eq "abcd"; + $io->close; + undef($io); + print "-\n"; +} + +print "XXX $destroyed\n"; + +print "not " unless $destroyed == $rounds; +print "ok 1\n"; diff --git a/t/para.t b/t/para.t new file mode 100644 index 0000000..d613d01 --- /dev/null +++ b/t/para.t @@ -0,0 +1,49 @@ +#!perl -w + +use strict; +use Test qw(plan ok); + +plan tests => 8; + +use IO::String; + +my $fh = IO::String->new(<, "a\n\n"); +ok(<$fh>, "a\nb\n\n"); +ok(<$fh>, "a\nb\nc\n\n"); +ok(<$fh>, "a\nb\nc\nd\n"); +ok(<$fh>, undef); + +$fh = IO::String->new(<, "a\nb\n\n"); +ok(<$fh>, undef); +ok(<$fh>, undef); diff --git a/t/read.t b/t/read.t new file mode 100644 index 0000000..3c87668 --- /dev/null +++ b/t/read.t @@ -0,0 +1,109 @@ +print "1..17\n"; + +$str = <new($str); + +@lines = <$io>; +print "not " unless @lines == 5 && $lines[1] eq "of a paragraph\n" && $. == 5; +print "ok 1\n"; + +use vars qw(@tmp); + +print "not " if defined($io->getline) || + (@tmp = $io->getlines) || + defined(<$io>) || + defined($io->getc) || + read($io, $buf, 100) != 0 || + $io->getpos != length($str); +print "ok 2\n"; + + +{ + local $/; # slurp mode + $io->setpos(0); + @lines = $io->getlines; + print "not " unless @lines == 1 && $lines[0] eq $str; + print "ok 3\n"; + + $io->setpos(index($str, "and")); + $line = <$io>; + print "not " unless $line eq "and a single line.\n\n"; + print "ok 4\n"; +} + +{ + local $/ = ""; # paragraph mode + $io->setpos(0); + @lines = <$io>; + print "not " unless @lines == 2 && $lines[1] eq "and a single line.\n\n"; + print "ok 5\n"; +} + +{ + local $/ = "is"; + $io->setpos(0); + @lines = (); + my $no = $io->input_line_number; + my $err; + while (<$io>) { + push(@lines, $_); + $err++ if $. != ++$no; + } + + print "not " if $err; + print "ok 6\n"; + + print "not " unless @lines == 3 && join("-", @lines) eq + "This- is- an example\n" . + "of a paragraph\n\n" . + "and a single line.\n\n"; + print "ok 7\n"; +} + + +# Test read + +$io->setpos(0); + +print "not " unless read($io, $buf, 3) == 3 && $buf eq "Thi"; +print "ok 8\n"; + +print "not " unless sysread($io, $buf, 3, 2) == 3 && $buf eq "Ths i"; +print "ok 9\n"; + +$io->seek(-4, 2); + +print "not " if $io->eof; +print "ok 10\n"; + +print "not " unless read($io, $buf, 20) == 4 && $buf eq "e.\n\n"; +print "ok 11\n"; + +print "not " unless read($io, $buf, 20) == 0 && $buf eq ""; +print "ok 12\n"; + +print "not " unless $io->eof; +print "ok 13\n"; + + +$io->setpos(0); +print "not " if defined(read($io, $buf, -1)); +print "ok 14\n"; + +print "not " unless read($io, $buf, 0) == 0; +print "ok 15\n"; + +print "not " unless read($io, $buf, 4) == 4 && $buf eq "This"; +print "ok 16\n"; + +$str = ""; +print "not " if defined(read($io, $buf, 4)); +print "ok 17\n"; diff --git a/t/seek.t b/t/seek.t new file mode 100644 index 0000000..42c6cc0 --- /dev/null +++ b/t/seek.t @@ -0,0 +1,63 @@ +print "1..10\n"; + +$str = "abcd"; + +#$IO::String::DEBUG++; + +use IO::String; +$io = IO::String->new($str); + +sub all_pos +{ + my($io, $expect) = @_; + $io->getpos == $expect && + $io->pos == $expect && + $io->tell == $expect && + $io->seek(0, 1) == $expect && + $io->sysseek(0, 1) == $expect && + $] >= 5.006 ? ( tell($io) == $expect && + seek($io, 0, 1) == $expect && + sysseek($io, 0, 1) == $expect + ) + : 1; +} + +print "not " unless all_pos($io, 0); +print "ok 1\n"; + +$io->setpos(2); +print "not " unless all_pos($io, 2); +print "ok 2\n"; + +$io->setpos(10); # XXX should it be defined in terms of seek?? +print "not " unless all_pos($io, 4); +print "ok 3\n"; + +$io->seek(10, 0); +print "not " unless all_pos($io, 10); +print "ok 4\n"; + +$io->print("���"); +print "not " unless all_pos($io, 13); +print "ok 5\n"; + +$io->seek(-4, 2); +print "not " unless all_pos($io, 9); +print "ok 6\n"; + +print "not " unless $io->read($buf, 20) == 4 && $buf eq "\0���"; +print "ok 7\n"; + +print "not " unless $io->seek(-10,1) && all_pos($io, 3); +print "ok 8\n"; + +$io->seek(0,0); +print "not " unless all_pos($io, 0); +print "ok 9\n"; + +if ($] >= 5.006) { + seek($io, 1, 0); + print "not " unless all_pos($io, 1); +} +print "ok 10\n"; + diff --git a/t/truncate.t b/t/truncate.t new file mode 100644 index 0000000..50a3397 --- /dev/null +++ b/t/truncate.t @@ -0,0 +1,38 @@ +print "1..6\n"; + +use IO::String; + +$io = IO::String->new($str); + +$io->truncate(10); +print "not " unless length($str) == 10; +print "ok 1\n"; + +print "not " unless $io->getpos == 0; +print "ok 2\n"; + +$io->setpos(8); +$io->truncate(2); +print "not " unless length($str) == 2 && $io->getpos == 2; +print "ok 3\n"; + +undef($io); +$str = ""; + +$io = IO::String->new($str); +$io->pad("+"); + +$io->truncate(5); + +$n = read($io, $buf, 20); +print "not " unless $n == 5 && $buf eq "+++++" && $buf eq $str; +print "ok 4\n"; + +print "not " unless read($io, $buf, 20) == 0; +print "ok 5\n"; + +$io->truncate(0); +print "not " unless $str eq ""; +print "ok 6\n"; + + diff --git a/t/write.t b/t/write.t new file mode 100644 index 0000000..c813e8e --- /dev/null +++ b/t/write.t @@ -0,0 +1,46 @@ +print "1..1\n"; + +#$IO::String::DEBUG++; + +use IO::String; +$io = IO::String->new; + +print $io "Heisan\n"; +$io->print("a", "b", "c"); + +{ + local($\) = "\n"; + print $io "d", "e"; + local($,) = ","; + print $io "f", "g", "h"; +} + +$foo = "1234567890"; + +syswrite($io, $foo, length($foo)); +$io->syswrite($foo); +$io->syswrite($foo, length($foo)); +$io->write($foo, length($foo), 5); +$io->write("xxx\n", 100, -1); + +for (1..3) { + printf $io "i(%d)", $_; + $io->printf("[%d]\n", $_); +} +select $io; +print "\n"; + +$io->setpos(0); +print "h"; + + +local *str = $io->string_ref; + +select STDOUT; +print $str; + +print "not " unless $str eq "heisan\nabcde\nf,g,h\n" . + ("1234567890" x 3) . "67890\n" . + "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n"; +print "ok 1\n"; +