IO-String-1.08/0000755000175000001440000000000010345241321012232 5ustar gisleusersIO-String-1.08/META.yml0000644000175000001440000000044710345241321013510 0ustar gisleusers# 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 IO-String-1.08/t/0000755000175000001440000000000010345241321012475 5ustar gisleusersIO-String-1.08/t/truncate.t0000644000175000001440000000116706606654527014541 0ustar gisleusersprint "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"; IO-String-1.08/t/read.t0000644000175000001440000000436410327230052013603 0ustar gisleusersprint "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"; IO-String-1.08/t/close.t0000644000175000001440000000071110345020147013767 0ustar gisleusers#!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"; IO-String-1.08/t/write.t0000644000175000001440000000143006606662102014023 0ustar gisleusersprint "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"; IO-String-1.08/t/para.t0000644000175000001440000000056510032776264013627 0ustar gisleusers#!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); IO-String-1.08/t/seek.t0000644000175000001440000000236410142710760013621 0ustar gisleusersprint "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"; IO-String-1.08/String.pm0000644000175000001440000002630510345025757014061 0ustar gisleuserspackage 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 IO-String-1.08/Changes0000644000175000001440000000472410345026645013546 0ustar gisleusers2005-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 IO-String-1.08/MANIFEST0000644000175000001440000000027110345241321013363 0ustar gisleusersChanges 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) IO-String-1.08/Makefile.PL0000644000175000001440000000032306704220346014212 0ustar gisleusersrequire 5.005_03; # need self-tie patch use ExtUtils::MakeMaker; WriteMakefile( NAME => 'IO::String', VERSION_FROM => 'String.pm', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, ); IO-String-1.08/README0000644000175000001440000000101710345025722013116 0ustar gisleusersIO::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.