IO-stringy-2.111/0000755000076400007640000000000012515754733011660 5ustar dfsdfsIO-stringy-2.111/COPYING0000644000076400007640000000361310677325622012714 0ustar dfsdfsThe "IO-stringy" Perl5 toolkit. Copyright (c) 1996 by Eryq. All rights reserved. Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. You should have received a copy of the Perl license along with Perl; see the file README in Perl distribution. You should have received a copy of the GNU General Public License along with Perl; see the file Copying. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. You should have received a copy of the Artistic License along with Perl; see the file Artistic. NO WARRANTY BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS IO-stringy-2.111/README0000644000076400007640000003117512515754625012547 0ustar dfsdfsNAME IO-stringy - I/O on in-core objects like strings and arrays SYNOPSIS IO:: ::AtomicFile adpO Write a file which is updated atomically ERYQ ::Lines bdpO I/O handle to read/write to array of lines ERYQ ::Scalar RdpO I/O handle to read/write to a string ERYQ ::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ ::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ ::WrapTie adpO Tie your handles & retain full OO interface ERYQ DESCRIPTION This toolkit primarily provides modules for performing both traditional and object-oriented i/o) on things *other* than normal filehandles; in particular, IO::Scalar, IO::ScalarArray, and IO::Lines. In the more-traditional IO::Handle front, we have IO::AtomicFile which may be used to painlessly create files which are updated atomically. And in the "this-may-prove-useful" corner, we have IO::Wrap, whose exported wraphandle() function will clothe anything that's not a blessed object in an IO::Handle-like wrapper... so you can just use OO syntax and stop worrying about whether your function's caller handed you a string, a globref, or a FileHandle. WARNINGS Perl's TIEHANDLE spec was incomplete prior to 5.005_57; it was missing support for "seek()", "tell()", and "eof()". Attempting to use these functions with an IO::Scalar, IO::ScalarArray, IO::Lines, etc. will not work prior to 5.005_57. None of the relevant methods will be invoked by Perl; and even worse, this kind of bug can lie dormant for a while. If you turn warnings on (via $^W or "perl -w"), and you see something like this... seek() on unopened file ...then you are probably trying to use one of these functions on one of our IO:: classes with an old Perl. The remedy is to simply use the OO version; e.g.: $SH->seek(0,0); ### GOOD: will work on any 5.005 seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond INSTALLATION Requirements As of version 2.x, this toolkit requires Perl 5.005 for the IO::Handle subclasses, and 5.005_57 or better is strongly recommended. See "WARNINGS" for details. Directions Most of you already know the drill... perl Makefile.PL make make test make install For everyone else out there... if you've never installed Perl code before, or you're trying to use this in an environment where your sysadmin or ISP won't let you do interesting things, relax: since this module contains no binary extensions, you can cheat. That means copying the directory tree under my "./lib" directory into someplace where your script can "see" it. For example, under Linux: cp -r IO-stringy-1.234/lib/* /path/to/my/perl/ Now, in your Perl code, do this: use lib "/path/to/my/perl"; use IO::Scalar; ### or whatever Ok, now you've been told. At this point, anyone who whines about not being given enough information gets an unflattering haiku written about them in the next change log. I'll do it. Don't think I won't. VERSION $Id: README,v 1.2 2005/02/10 21:24:05 dfs Exp $ TO DO (2000/08/02) Finalize $/ support Graham Barr submitted this patch half a *year* ago; Like a moron, I lost his message under a ton of others, and only now have the experimental implementation done. Will the sudden sensitivity to $/ hose anyone out there? I'm worried, so you have to enable it explicitly in 1.x. It will be on by default in 2.x, though only IO::Scalar has been implemented. (2001/08/08) Remove IO::WrapTie from new IO:: classes It's not needed. Backwards compatibility could be maintained by having new_tie() be identical to new(). Heck, I'll bet that IO::WrapTie should be reimplemented so the returned object is just like an IO::Scalar in its use of globrefs. CHANGE LOG Version 2.111 (2015/04/22) Update maintainer's name, which is now Dianne Skoll. Version 2.110 (2005/02/10) Maintainership taken over by DSKOLL Closed the following bugs at https://rt.cpan.org/NoAuth/Bugs.html?Dist=IO-stringy: * 2208 IO::ScalarArray->getline does not return undef for EOF if undef($/) * 7132 IO-stringy/Makefile.PL bug - name should be module name * 11249 IO::Scalar flush shouldn't return undef * 2172 $\ (output record separator) not respected * 8605 IO::InnerFile::seek() should return 1 on success * 4798 *.html in lib/ * 4369 Improvement: handling of fixed-size reads in IO::Scalar (Actually, bug 4369 was closed in Version 2.109) Version 2.109 (2003/12/21) IO::Scalar::getline now works with ref to int. *Thanks to Dominique Quatravaux for this patch.* Version 2.108 (2001/08/20) The terms-of-use have been placed in the distribution file "COPYING". Also, small documentation tweaks were made. Version 2.105 (2001/08/09) Added support for various seek() whences to IO::ScalarArray. Added support for consulting $/ in IO::Scalar and IO::ScalarArray. The old "use_RS()" is not even an option. Unsupported record separators will cause a croak(). Added a lot of regression tests to supoprt the above. Better on-line docs (hyperlinks to individual functions). Version 2.103 (2001/08/08) After sober consideration I have reimplemented IO::Scalar::print() so that it once again always seeks to the end of the string. Benchmarks show the new implementation to be just as fast as Juergen's contributed patch; until someone can convince me otherwise, the current, safer implementation stays. I thought more about giving IO::Scalar two separate handles, one for reading and one for writing, as suggested by Binkley. His points about what tell() and eof() return are, I think, show-stoppers for this feature. Even the manpages for stdio's fseek() seem to imply a *single* file position indicator, not two. So I think I will take this off the TO DO list. Remedy: you can always have two handles open on the same scalar, one which you only write to, and one which you only read from. That should give the same effect. Version 2.101 (2001/08/07) Alpha release. This is the initial release of the "IO::Scalar and friends are now subclasses of IO::Handle". I'm flinging it against the wall. Please tell me if the banana sticks. When it does, the banana will be called 2.2x. First off, *many many thanks to Doug Wilson*, who has provided an *invaluable* service by patching IO::Scalar and friends so that they (1) inherit from IO::Handle, (2) automatically tie themselves so that the "new()" objects can be used in native i/o constructs, and (3) doing it so that the whole damn thing passes its regression tests. As Doug knows, my globref Kung-Fu was not up to the task; he graciously provided the patches. This has earned him a seat at the Co-Authors table, and the right to have me address him as *sensei*. Performance of IO::Scalar::print() has been improved by as much as 2x for lots of little prints, with the cost of forcing those who print-then-seek-then-print to explicitly seek to end-of-string before printing again. *Thanks to Juergen Zeller for this patch.* Added the COPYING file, which had been missing from prior versions. *Thanks to Albert Chin-A-Young for pointing this out.* IO::Scalar consults $/ by default (1.x ignored it by default). Yes, I still need to support IO::ScalarArray. Version 1.221 (2001/08/07) I threatened in "INSTALLATION" to write an unflattering haiku about anyone who whined that I gave them insufficient information... but it turns out that I left out a crucial direction. D'OH! *Thanks to David Beroff for the "patch" and the haiku...* Enough info there? Here's unflattering haiku: Forgot the line, "make"! ;-) Version 1.220 (2001/04/03) Added untested SEEK, TELL, and EOF methods to IO::Scalar and IO::ScalarArray to support corresponding functions for tied filehandles: untested, because I'm still running 5.00556 and Perl is complaining about "tell() on unopened file". *Thanks to Graham Barr for the suggestion.* Removed not-fully-blank lines from modules; these were causing lots of POD-related warnings. *Thanks to Nicolas Joly for the suggestion.* Version 1.219 (2001/02/23) IO::Scalar objects can now be made sensitive to $/ . Pains were taken to keep the fast code fast while adding this feature. *Cheers to Graham Barr for submitting his patch; jeers to me for losing his email for 6 months.* Version 1.218 (2001/02/23) IO::Scalar has a new sysseek() method. *Thanks again to Richard Jones.* New "TO DO" section, because people who submit patches/ideas should at least know that they're in the system... and that I won't lose their stuff. Please read it. New entries in "AUTHOR". Please read those too. Version 1.216 (2000/09/28) IO::Scalar and IO::ScalarArray now inherit from IO::Handle. I thought I'd remembered a problem with this ages ago, related to the fact that these IO:: modules don't have "real" filehandles, but the problem apparently isn't surfacing now. If you suddenly encounter Perl warnings during global destruction (especially if you're using tied filehandles), then please let me know! *Thanks to B. K. Oxley (binkley) for this.* Nasty bug fixed in IO::Scalar::write(). Apparently, the offset and the number-of-bytes arguments were, for all practical purposes, *reversed.* You were okay if you did all your writing with print(), but boy was *this* a stupid bug! *Thanks to Richard Jones for finding this one. For you, Rich, a double-length haiku:* Newspaper headline typeset by dyslexic man loses urgency BABY EATS FISH is simply not equivalent to FISH EATS BABY New sysread and syswrite methods for IO::Scalar. *Thanks again to Richard Jones for this.* Version 1.215 (2000/09/05) Added 'bool' overload to '""' overload, so object always evaluates to true. (Whew. Glad I caught this before it went to CPAN.) Version 1.214 (2000/09/03) Evaluating an IO::Scalar in a string context now yields the underlying string. *Thanks to B. K. Oxley (binkley) for this.* Version 1.213 (2000/08/16) Minor documentation fixes. Version 1.212 (2000/06/02) Fixed IO::InnerFile incompatibility with Perl5.004. *Thanks to many folks for reporting this.* Version 1.210 (2000/04/17) Added flush() and other no-op methods. *Thanks to Doru Petrescu for suggesting this.* Version 1.209 (2000/03/17) Small bug fixes. Version 1.208 (2000/03/14) Incorporated a number of contributed patches and extensions, mostly related to speed hacks, support for "offset", and WRITE/CLOSE methods. *Thanks to Richard Jones, Doru Petrescu, and many others.* Version 1.206 (1999/04/18) Added creation of ./testout when Makefile.PL is run. Version 1.205 (1999/01/15) Verified for Perl5.005. Version 1.202 (1998/04/18) New IO::WrapTie and IO::AtomicFile added. Version 1.110 Added IO::WrapTie. Version 1.107 Added IO::Lines, and made some bug fixes to IO::ScalarArray. Also, added getc(). Version 1.105 No real changes; just upgraded IO::Wrap to have a $VERSION string. AUTHOR Primary Maintainer Dianne Skoll (dfs@roaringpenguin.com). Original Author Eryq (eryq@zeegee.com). President, ZeeGee Software Inc (http://www.zeegee.com). Co-Authors For all their bug reports and patch submissions, the following are officially recognized: Richard Jones B. K. Oxley (binkley) Doru Petrescu Doug Wilson (for picking up the ball I dropped, and doing tie() right) Go to http://www.zeegee.com for the latest downloads and on-line documentation for this module. Enjoy. Yell if it breaks. IO-stringy-2.111/contrib/0000755000076400007640000000000012515754727013323 5ustar dfsdfsIO-stringy-2.111/contrib/Clever.pm0000644000076400007640000000144210677325622015075 0ustar dfsdfspackage IO::Clever; require 5.005_03; use strict; use vars qw($VERSION @ISA); @ISA = qw(IO::String); $VERSION = "1.01"; # ChangeLog: # 1999-07-21-02:06:47 Uri Guttman told me a critical fix: # $fp->input_record_separator is _Global_; local($/) is safer my(%params); sub new { my $class = shift; return IO::File->new(@_) unless $_[0] =~ /^>/; my $self = bless IO::String->new(), ref($class) || $class; $params{$self} = [ @_ ]; $self; } sub DESTROY { my($self) = @_; my $filename = $params{$self}->[0]; return unless $filename =~ s/^>//; my($new) = ${$self->string_ref}; if (-f $filename) { my $fp = IO::File->new("<$filename") || die "$0: $filename: $!\n"; local ($/); return if $new eq $fp->getline; } IO::File->new(@{$params{$self}})->print($new); delete $params{$self}; } 1; IO-stringy-2.111/META.yml0000644000076400007640000000073012515754733013131 0ustar dfsdfs--- #YAML:1.0 name: IO-stringy version: 2.111 abstract: ~ author: [] license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 IO-stringy-2.111/t/0000755000076400007640000000000012515754731012121 5ustar dfsdfsIO-stringy-2.111/t/IO_Scalar.t0000644000076400007640000000230411564514627014102 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t", "./lib"; use IO::Scalar; use ExtUtils::TBone; use Common; #-------------------- # # TEST... # #-------------------- my $RECORDSEP_TESTS = 'undef empty custom newline'; sub opener { my $s = join('', @{$_[0]}); IO::Scalar->new(\$s); } ### Make a tester: my $T = typical ExtUtils::TBone; Common->test_init(TBone=>$T); $T->log_warnings; ### Set the counter: my $main_tests = 1 + 1 + 1; my $common_tests = (1 + 1 + 4 + 4 + 3 + 4 + Common->test_recordsep_count($RECORDSEP_TESTS)); $T->begin($main_tests + $common_tests); ### Open a scalar on a string, containing initial data: my $s = $Common::DATA_S; my $SH = IO::Scalar->new(\$s); $T->ok($SH, "OPEN: open a scalar on a ref to a string"); ### Make sure fileno does not die $T->ok(!defined($SH->fileno()), "fileno() returns undef"); ### Run standard tests: Common->test_print($SH); $T->ok(($s eq $Common::FDATA_S), "FULL", S=>$s, F=>$Common::FDATA_S); Common->test_getc($SH); Common->test_getline($SH); Common->test_read($SH); Common->test_seek($SH); Common->test_tie(TieArgs => ['IO::Scalar']); Common->test_recordsep($RECORDSEP_TESTS, \&opener); ### So we know everything went well... $T->end; IO-stringy-2.111/t/IO_InnerFile.t0000644000076400007640000000267511663740613014557 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t", "./lib"; use IO::InnerFile; use IO::File; use ExtUtils::TBone; use Common; #-------------------- # # TEST... # #-------------------- # Make a tester: my $T = typical ExtUtils::TBone; Common->test_init(TBone=>$T); $T->begin(7); # Create a test file open(OUT, '>t/dummy-test-file') || die("Cannot write t/dummy-test-file: $!"); print OUT <<'EOF'; Here is some dummy content. Here is some more dummy content Here is yet more dummy content. And finally another line. EOF close(OUT); # Open it as a regular file handle my $fh = IO::File->new('new($fh, 28, 64); # Second and third lines my $line; $line = <$inner>; $T->ok_eq($line, "Here is some more dummy content\n"); $line = <$inner>; $T->ok_eq($line, "Here is yet more dummy content.\n"); $line = <$inner>; $T->ok(!defined($line)); $inner->close(); $inner = IO::InnerFile->new($fh, 28, 64); # Second and third lines # Test list context (CPAN ticket #66186) my @arr; @arr = <$inner>; $T->ok(scalar(@arr) == 2); $T->ok_eq($arr[0], "Here is some more dummy content\n"); $T->ok_eq($arr[1], "Here is yet more dummy content.\n"); # Make sure slurp mode works as expected $inner->seek(0, 0); { local $/; my $contents = <$inner>; $T->ok_eq($contents, "Here is some more dummy content\nHere is yet more dummy content.\n"); } # So we know everything went well... $T->end; unlink('t/dummy-test-file'); IO-stringy-2.111/t/IO_WrapTie.t0000644000076400007640000000200210677325622014242 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t"; use IO::Handle; use IO::Scalar; use ExtUtils::TBone; use IO::WrapTie; #-------------------- # # TEST... # #-------------------- # Make a tester: my $T = typical ExtUtils::TBone; # Set the counter: unless ($] >= 5.004) { $T->begin(1); $T->ok(1); $T->end; exit 0; } $T->begin(6); my $hello = 'Hello, '; my $world = "world!\n"; #### test my $s = ''; my $SH = new IO::WrapTie 'IO::Scalar', \$s; $T->ok(1, "Construction"); #### test print $SH $hello, $world; $T->ok($s eq "$hello$world", "print FH ARGS", S => $s); #### test $SH->print($hello, $world); $T->ok($s eq "$hello$world$hello$world", "FH->print(ARGS)", S => $s); #### test $SH->seek(0,0); $T->ok(1, "FH->seek(0,0)"); #### test @x = <$SH>; $T->ok((($x[0] eq "$hello$world") && ($x[1] eq "$hello$world") && !$x[2]), "array = "); #### test my $sref = $SH->sref; $T->ok($sref eq \$s, "FH->sref"); # So we know everything went well... $T->end; IO-stringy-2.111/t/IO_Lines.t0000644000076400007640000000175110677325622013753 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t", "./lib"; use IO::Lines; use ExtUtils::TBone; use Common; #-------------------- # # TEST... # #-------------------- my $RECORDSEP_TESTS = 'undef newline'; sub opener { my $a = [@{$_[0]}]; IO::Lines->new($a); } # Make a tester: my $T = typical ExtUtils::TBone; Common->test_init(TBone=>$T); # Set the counter: my $main_tests = 1; my $common_tests = (1 + 1 + 4 + 4 + 3 + 4 + Common->test_recordsep_count($RECORDSEP_TESTS)); $T->begin($main_tests + $common_tests); # Open a scalar on a string, containing initial data: my @la = @Common::DATA_LA; my $LAH = IO::Lines->new(\@la); $T->ok($LAH, "OPEN: open a scalar on a ref to an array"); # Run standard tests: Common->test_print($LAH); Common->test_getc($LAH); Common->test_getline($LAH); Common->test_read($LAH); Common->test_seek($LAH); Common->test_tie(TieArgs => ['IO::Lines', []]); Common->test_recordsep($RECORDSEP_TESTS, \&opener); # So we know everything went well... $T->end; IO-stringy-2.111/t/two.t0000644000076400007640000000165610677325622013127 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t", "./lib"; use IO::Scalar; use ExtUtils::TBone; use Common; #-------------------- # # TEST... # #-------------------- ### Make a tester: my $T = typical ExtUtils::TBone; Common->test_init(TBone=>$T); $T->log_warnings; ### Set the counter: my $ntests = (($] >= 5.004) ? 2 : 0); $T->begin($ntests); if ($ntests == 0) { $T->end; exit 0; } ### Open handles on strings: my $str1 = "Tea for two"; my $str2 = "Me 4 U"; my $str3 = "hello"; my $S1 = IO::Scalar->new(\$str1); my $S2 = IO::Scalar->new(\$str2); ### Interleave output: print $S1 ", and two "; print $S2 ", and U "; my $S3 = IO::Scalar->new(\$str3); $S3->print(", world"); print $S1 "for tea"; print $S2 "4 me"; ### Verify: $T->ok_eq($str1, "Tea for two, and two for tea", "COHERENT STRING 1"); $T->ok_eq($str2, "Me 4 U, and U 4 me", "COHERENT STRING 2"); ### So we know everything went well... $T->end; IO-stringy-2.111/t/simple.t0000644000076400007640000000222010677325622013573 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t", "./lib"; use IO::Scalar; use IO::ScalarArray; use IO::Lines; use ExtUtils::TBone; use Common; #-------------------- # # TEST... # #-------------------- ### Make a tester: my $T = typical ExtUtils::TBone; Common->test_init(TBone=>$T); $T->log_warnings; ### Set the counter: my $ntests = 6; $T->begin($ntests); #------------------------------ my $SH = new IO::Scalar; print $SH "Hi there!\n"; print $SH "Tres cool, no?\n"; $T->ok_eq(${$SH->sref}, "Hi there!\nTres cool, no?\n"); $SH->seek(0, 0); my $line = <$SH>; $T->ok_eq($line, "Hi there!\n"); #------------------------------ my $AH = new IO::ScalarArray; print $AH "Hi there!\n"; print $AH "Tres cool, no?\n"; $T->ok_eq(join('', @{$AH->aref}), "Hi there!\nTres cool, no?\n"); $AH->seek(0, 0); $line = <$AH>; $T->ok_eq($line, "Hi there!\n"); #------------------------------ my $LH = new IO::Lines; print $LH "Hi there!\n"; print $LH "Tres cool, no?\n"; $T->ok_eq(join('', @{$LH->aref}), "Hi there!\nTres cool, no?\n"); $LH->seek(0, 0); $line = <$LH>; $T->ok_eq($line, "Hi there!\n"); ### So we know everything went well... $T->end; IO-stringy-2.111/t/IO_ScalarArray.t0000644000076400007640000000210511564514627015100 0ustar dfsdfs#!/usr/bin/perl -w #-*-Perl-*- use lib "./t", "./lib"; use IO::ScalarArray; use ExtUtils::TBone; use Common; #-------------------- # # TEST... # #-------------------- my $RECORDSEP_TESTS = 'undef newline'; sub opener { my $a = [@{$_[0]}]; IO::ScalarArray->new($a); } # Make a tester: my $T = typical ExtUtils::TBone; Common->test_init(TBone=>$T); # Set the counter: my $main_tests = 1+1; my $common_tests = (1 + 1 + 4 + 4 + 3 + 4 + Common->test_recordsep_count($RECORDSEP_TESTS)); $T->begin($main_tests + $common_tests); # Open a scalar on a string, containing initial data: my @sa = @Common::DATA_SA; my $SAH = IO::ScalarArray->new(\@sa); $T->ok($SAH, "OPEN: open a scalar on a ref to an array"); $T->ok(!defined($SAH->fileno()), 'fileno() returns undef'); # Run standard tests: Common->test_print($SAH); Common->test_getc($SAH); Common->test_getline($SAH); Common->test_read($SAH); Common->test_seek($SAH); Common->test_tie(TieArgs => ['IO::ScalarArray', []]); Common->test_recordsep($RECORDSEP_TESTS, \&opener); # So we know everything went well... $T->end; IO-stringy-2.111/t/Common.pm0000644000076400007640000002024310677325622013710 0ustar dfsdfspackage Common; #-------------------- # # GLOBALS... # #-------------------- use vars qw(@DATA_SA @DATA_LA $DATA_S @ADATA_SA $ADATA_S $FDATA_S @FDATA_LA ); #------------------------------ # Data... # ...as a scalar-array: @DATA_SA = ( "A diner while ", "dining at Crewe\n", "Found a rather large ", "mouse in his stew\n Said the waiter, \"Don't shout,\n", " And ", "wave it about..." ); # ...as a string: $DATA_S = join '', @DATA_SA; # ...as a line-array: @DATA_LA = lines($DATA_S); # Additional data... # ...as a scalar-array: @ADATA_SA = ( "\nor the rest", " will be wanting one ", "too.\"\n", ); # ...as a string: $ADATA_S = join '', @ADATA_SA; # Full data... # ...as a string: $FDATA_S = $DATA_S . $ADATA_S; # ...as a line-array: @FDATA_LA = lines($FDATA_S); # Tester: my $T; # Scratch... my $BUF = ''; # buffer my $M; # message #------------------------------ # lines STR #------------------------------ sub lines { my $s = shift; split /^/, $s; } #------------------------------ # test_init PARAMHASH #------------------------------ # Init common tests. # sub test_init { my ($self, %p) = @_; $T = $p{TBone}; } #------------------------------ # test_print HANDLE, TEST #------------------------------ # Test printing to handle. # 1 # sub test_print { my ($self, $GH, $all) = @_; local($_); # Append with print: $M = "PRINT: able to print to $GH"; $GH->print($ADATA_SA[0]); $GH->print(@ADATA_SA[1..2]); $T->ok(1, $M); } #------------------------------ # test_getc HANDLE #------------------------------ # Test getc(). # 1 # sub test_getc { my ($self, $GH) = @_; local($_); my @c; $M = "GETC: seek(0,0) and getc()"; $GH->seek(0,0); for (0..2) { $c[$_] = $GH->getc }; $T->ok((($c[0] eq 'A') && ($c[1] eq ' ') && ($c[2] eq 'd')), $M); } #------------------------------ # test_getline HANDLE #------------------------------ # Test getline() and getlines(). # 4 # sub test_getline { my ($self, $GH) = @_; local($_); $M = "GETLINE/SEEK3: seek(3,START) and getline() gets part of 1st line"; $GH->seek(3,0); my $got = $GH->getline; my $want = "iner while dining at Crewe\n"; $T->ok(($got eq $want), $M, GH => $GH, Got => $got, Want => $want); $M = "GETLINE/NEXT: next getline() gets subsequent line"; $_ = $GH->getline; $T->ok(($_ eq "Found a rather large mouse in his stew\n"), $M, Got => $_); $M = "GETLINE/EOF: repeated getline() finds end of stream"; my $last; for (1..6) { $last = $GH->getline } $T->ok(!$last, $M, Last => (defined($last) ? $last : 'undef')); $M = "GETLINE/GETLINES: seek(0,0) and getlines() slurps in string"; $GH->seek(0,0); my @got = $GH->getlines; my $gots = join '', @got; $T->ok(($gots eq $FDATA_S), $M, GotAll => $gots, WantAll => $FDATA_S, Got => \@got); } #------------------------------ # test_read HANDLE #------------------------------ # Test read(). # 4 # sub test_read { my ($self, $GH) = @_; local($_); $M = "READ/FIRST10: reading first 10 bytes with seek(0,START) + read(10)"; $GH->seek(0,0); $GH->read($BUF,10); $T->ok(($BUF eq "A diner wh"), $M); $M = "READ/NEXT10: reading next 10 bytes with read(10)"; $GH->read($BUF,10); $T->ok(($BUF eq "ile dining"), $M); $M = "READ/TELL20: tell() the current location as 20"; $T->ok(($GH->tell == 20), $M); $M = "READ/SLURP: seek(0,START) + read(1000) reads in whole handle"; $GH->seek(0,0); $GH->read($BUF,1000); $T->ok(($BUF eq $FDATA_S), $M); } #------------------------------ # test_seek HANDLE #------------------------------ # Test seeks other than (0,0). # 2 # sub test_seek { my ($self, $GH) = @_; local($_); $M = "SEEK/SET: seek(2,SET) + read(5) returns 'diner'"; $GH->seek(2,0); $GH->read($BUF,5); $T->ok_eq($BUF, 'diner', $M); $M = "SEEK/END: seek(-6,END) + read(3) returns 'too'"; $GH->seek(-6,2); $GH->read($BUF,3); $T->ok_eq($BUF, 'too', $M); $M = "SEEK/CUR: seek(-7,CUR) + read(7) returns 'one too'"; $GH->seek(-7,1); $GH->read($BUF,7); $T->ok_eq($BUF, 'one too', $M); } #------------------------------ # test_tie PARAMHASH #------------------------------ # Test tiehandle getline() interface. # 4 # sub test_tie { my ($self, %p) = @_; my ($tieclass, @tieargs) = @{$p{TieArgs}}; local($_); my @lines; my $i; my $nmatched; $M = "TIE/TIE: able to tie"; tie(*OUT, $tieclass, @tieargs); $T->ok(1, $M, TieClass => $tieclass, TieArgs => \@tieargs); $M = "TIE/PRINT: printing data"; print OUT @DATA_SA; print OUT $ADATA_SA[0]; print OUT @ADATA_SA[1..2]; $T->ok(1, $M); $M = "TIE/GETLINE: seek(0,0) and scalar <> get expected lines"; tied(*OUT)->seek(0,0); # rewind @lines = (); push @lines, $_ while ; # get lines one at a time $nmatched = 0; # total up matches... for (0..$#lines) { ++$nmatched if ($lines[$_] eq $FDATA_LA[$_]) }; $T->ok(($nmatched == int(@FDATA_LA)), $M, Want => \@FDATA_LA, Gotl => \@lines, Lines=> "0..$#lines", Match=> $nmatched, FDatl=> int(@FDATA_LA), FData=> \@FDATA_LA); $M = "TIE/GETLINES: seek(0,0) and array <> slurps in lines"; tied(*OUT)->seek(0,0); # rewind @lines = ; # get lines all at once $nmatched = 0; # total up matches... for (0..$#lines) { ++$nmatched if ($lines[$_] eq $FDATA_LA[$_]) }; $T->ok(($nmatched == int(@FDATA_LA)), $M, Want => \@FDATA_LA, Gotl => \@lines, Lines=> "0..$#lines", Match=> $nmatched); # $M = "TIE/TELL: telling data"; # my $tell_oo = tied(*OUT)->tell; # my $tell_tie = tell OUT; # $T->ok(($tell_oo == $tell_tie), $M, # Want => $tell_oo, # Gotl => $tell_tie); } #------------------------------ # test_recordsep #------------------------------ # Try $/ tests. # # 3 x undef # 3 x empty # 2 x custom # 11 x newline # sub test_recordsep_count { my ($self, $seps) = @_; my $count = 0; $count += 3 if ($seps =~ /undef/) ; $count += 3 if ($seps =~ /empty/) ; $count += 2 if ($seps =~ /custom/) ; $count += 11 if ($seps =~ /newline/); $count; } sub test_recordsep { my ($self, $seps, $opener) = @_; my $GH; my @lines = ("par 1, line 1\n", "par 1, line 2\n", "\n", "\n", "\n", "\n", "par 2, line 1\n", "\n", "par 3, line 1\n", "par 3, line 2\n", "par 3, line 3"); my $all = join('', @lines); ### Slurp everything: if ($seps =~ /undef/) { $GH = &$opener(\@lines); local $/ = undef; $T->ok_eq($GH->getline, $all, "RECORDSEP undef: getline slurps everything"); } ### Read a little, slurp the rest: if ($seps =~ /undef/) { $GH = &$opener(\@lines); $T->ok_eq($GH->getline, $lines[0], "RECORDSEP undef: get first line"); local $/ = undef; $T->ok_eq($GH->getline, join('', @lines[1..$#lines]), "RECORDSEP undef: slurp the rest"); } ### Read paragraph by paragraph: if ($seps =~ /empty/) { $GH = &$opener(\@lines); local $/ = ""; $T->ok_eq($GH->getline, join('', @lines[0..2]), "RECORDSEP empty: first par"); $T->ok_eq($GH->getline, join('', @lines[6..7]), "RECORDSEP empty: second par"); $T->ok_eq($GH->getline, join('', @lines[8..10]), "RECORDSEP empty: third par"); } ### Read record by record: if ($seps =~ /custom/) { $GH = &$opener(\@lines); local $/ = "1,"; $T->ok_eq($GH->getline, "par 1,", "RECORDSEP custom: first rec"); $T->ok_eq($GH->getline, " line 1\npar 1,", "RECORDSEP custom: second rec"); } ### Read line by line: if ($seps =~ /newline/) { $GH = &$opener(\@lines); local $/ = "\n"; for my $i (0..10) { $T->ok_eq($GH->getline, $lines[$i], "RECORDSEP newline: rec $i"); } } } #------------------------------ 1; IO-stringy-2.111/t/ExtUtils/0000755000076400007640000000000012515754730013701 5ustar dfsdfsIO-stringy-2.111/t/ExtUtils/TBone.pm0000644000076400007640000003043710677325622015256 0ustar dfsdfspackage ExtUtils::TBone; =head1 NAME ExtUtils::TBone - a "skeleton" for writing "t/*.t" test files. =head1 SYNOPSIS Include a copy of this module in your t directory (as t/ExtUtils/TBone.pm), and then write your t/*.t files like this: use lib "./t"; # to pick up a ExtUtils::TBone use ExtUtils::TBone; # Make a tester... here are 3 different alternatives: my $T = typical ExtUtils::TBone; # standard log my $T = new ExtUtils::TBone; # no log my $T = new ExtUtils::TBone "testout/Foo.tlog"; # explicit log # Begin testing, and expect 3 tests in all: $T->begin(3); # expect 3 tests $T->msg("Something for the log file"); # message for the log # Run some tests: $T->ok($this); # test 1: no real info logged $T->ok($that, # test 2: logs a comment "Is that ok, or isn't it?"); $T->ok(($this eq $that), # test 3: logs comment + vars "Do they match?", This => $this, That => $that); # That last one could have also been written... $T->ok_eq($this, $that); # does 'eq' and logs operands $T->ok_eqnum($this, $that); # does '==' and logs operands # End testing: $T->end; =head1 DESCRIPTION This module is intended for folks who release CPAN modules with "t/*.t" tests. It makes it easy for you to output syntactically correct test-output while at the same time logging all test activity to a log file. Hopefully, bug reports which include the contents of this file will be easier for you to investigate. =head1 OUTPUT =head2 Standard output Pretty much as described by C, with a special "# END" comment placed at the very end: 1..3 ok 1 not ok 2 ok 3 # END =head1 Log file A typical log file output by this module looks like this: 1..3 ** A message logged with msg(). ** Another one. 1: My first test, using test(): how'd I do? 1: ok 1 ** Yet another message. 2: My second test, using test_eq()... 2: A: The first string 2: B: The second string 2: not ok 2 3: My third test. 3: ok 3 # END Each test() is logged with the test name and results, and the test-number prefixes each line. This allows you to scan a large file easily with "grep" (or, ahem, "perl"). A blank line follows each test's record, for clarity. =head1 PUBLIC INTERFACE =cut # Globals: use strict; use vars qw($VERSION); use FileHandle; use File::Basename; # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = substr q$Revision: 1.1 $, 10; #------------------------------ =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I Create a new tester. Any arguments are sent to log_open(). =cut sub new { my $self = bless { OUT =>\*STDOUT, Begin=>0, End =>0, Count=>0, }, shift; $self->log_open(@_) if @_; $self; } #------------------------------ =item typical I Create a typical tester. Use this instead of new() for most applicaitons. The directory "testout" is created for you automatically, to hold the output log file, and log_warnings() is invoked. =cut sub typical { my $class = shift; my ($tfile) = basename $0; unless (-d "testout") { mkdir "testout", 0755 or die "Couldn't create a 'testout' subdirectory: $!\n"; ### warn "$class: created 'testout' directory\n"; } my $self = $class->new($class->catfile('.', 'testout', "${tfile}log")); $self->log_warnings; $self; } #------------------------------ # DESTROY #------------------------------ # Class method, destructor. # Automatically closes the log. # sub DESTROY { $_[0]->log_close; } #------------------------------ =back =head2 Doing tests =over 4 =cut #------------------------------ =item begin NUMTESTS I Start testing. This outputs the 1..NUMTESTS line to the standard output. =cut sub begin { my ($self, $n) = @_; return if $self->{Begin}++; $self->l_print("1..$n\n\n"); print {$self->{OUT}} "1..$n\n"; } #------------------------------ =item end I Indicate the end of testing. This outputs a "# END" line to the standard output. =cut sub end { my ($self) = @_; return if $self->{End}++; $self->l_print("# END\n"); print {$self->{OUT}} "# END\n"; } #------------------------------ =item ok BOOL, [TESTNAME], [PARAMHASH...] I Do a test, and log some information connected with it. This outputs the test result lines to the standard output: ok 12 not ok 13 Use it like this: $T->ok(-e $dotforward); Or better yet, like this: $T->ok((-e $dotforward), "Does the user have a .forward file?"); Or even better, like this: $T->ok((-e $dotforward), "Does the user have a .forward file?", User => $ENV{USER}, Path => $dotforward, Fwd => $ENV{FWD}); That last one, if it were test #3, would be logged as: 3: Does the user have a .forward file? 3: User: "alice" 3: Path: "/home/alice/.forward" 3: Fwd: undef 3: ok You get the idea. Note that defined quantities are logged with delimiters and with all nongraphical characters suitably escaped, so you can see evidence of unexpected whitespace and other badnasties. Had "Fwd" been the string "this\nand\nthat", you'd have seen: 3: Fwd: "this\nand\nthat" And unblessed array refs like ["this", "and", "that"] are treated as multiple values: 3: Fwd: "this" 3: Fwd: "and" 3: Fwd: "that" =cut sub ok { my ($self, $ok, $test, @ps) = @_; ++($self->{Count}); # next test # Report to harness: my $status = ($ok ? "ok " : "not ok ") . $self->{Count}; print {$self->{OUT}} $status, "\n"; # Log: $self->ln_print($test, "\n") if $test; while (@ps) { my ($k, $v) = (shift @ps, shift @ps); my @vs = ((ref($v) and (ref($v) eq 'ARRAY'))? @$v : ($v)); foreach (@vs) { if (!defined($_)) { # value not defined: output keyword $self->ln_print(qq{ $k: undef\n}); } else { # value defined: output quoted, encoded form s{([\n\t\x00-\x1F\x7F-\xFF\\\"])} {'\\'.sprintf("%02X",ord($1)) }exg; s{\\0A}{\\n}g; $self->ln_print(qq{ $k: "$_"\n}); } } } $self->ln_print($status, "\n"); $self->l_print("\n"); 1; } #------------------------------ =item ok_eq ASTRING, BSTRING, [TESTNAME], [PARAMHASH...] I Convenience front end to ok(): test whether C, and logs the operands as 'A' and 'B'. =cut sub ok_eq { my ($self, $this, $that, $test, @ps) = @_; $self->ok(($this eq $that), ($test || "(Is 'A' string-equal to 'B'?)"), A => $this, B => $that, @ps); } #------------------------------ =item ok_eqnum ANUM, BNUM, [TESTNAME], [PARAMHASH...] I Convenience front end to ok(): test whether C, and logs the operands as 'A' and 'B'. =cut sub ok_eqnum { my ($self, $this, $that, $test, @ps) = @_; $self->ok(($this == $that), ($test || "(Is 'A' numerically-equal to 'B'?)"), A => $this, B => $that, @ps); } #------------------------------ =back =head2 Logging messages =over 4 =cut #------------------------------ =item log_open PATH I Open a log file for messages to be output to. This is invoked for you automatically by C and C. =cut sub log_open { my ($self, $path) = @_; $self->{LogPath} = $path; $self->{LOG} = FileHandle->new(">$path") || die "open $path: $!"; $self; } #------------------------------ =item log_close I Close the log file and stop logging. You shouldn't need to invoke this directly; the destructor does it. =cut sub log_close { my $self = shift; close(delete $self->{LOG}) if $self->{LOG}; } #------------------------------ =item log_warnings I Invoking this redefines $SIG{__WARN__} to log to STDERR and to the tester's log. This is automatically invoked when using the C constructor. =cut sub log_warnings { my ($self) = @_; $SIG{__WARN__} = sub { print STDERR $_[0]; $self->log("warning: ", $_[0]); }; } #------------------------------ =item log MESSAGE... I Log a message to the log file. No alterations are made on the text of the message. See msg() for an alternative. =cut sub log { my $self = shift; print {$self->{LOG}} @_ if $self->{LOG}; } #------------------------------ =item msg MESSAGE... I Log a message to the log file. Lines are prefixed with "** " for clarity, and a terminating newline is forced. =cut sub msg { my $self = shift; my $text = join '', @_; chomp $text; $text =~ s{^}{** }gm; $self->l_print($text, "\n"); } #------------------------------ # # l_print MESSAGE... # # Instance method, private. # Print to the log file if there is one. # sub l_print { my $self = shift; print { $self->{LOG} } @_ if $self->{LOG}; } #------------------------------ # # ln_print MESSAGE... # # Instance method, private. # Print to the log file, prefixed by message number. # sub ln_print { my $self = shift; foreach (split /\n/, join('', @_)) { $self->l_print("$self->{Count}: $_\n"); } } #------------------------------ =back =head2 Utilities =over 4 =cut #------------------------------ =item catdir DIR, ..., DIR I Concatenate several directories into a path ending in a directory. Lightweight version of the one in C; this method dates back to a more-innocent time when File::Spec was younger and less ubiquitous. Paths are assumed to be absolute. To signify a relative path, the first DIR must be ".", which is processed specially. On Mac, the path I end in a ':'. On Unix, the path I end in a '/'. =cut sub catdir { my $self = shift; my $relative = shift @_ if ($_[0] eq '.'); if ($^O eq 'Mac') { return ($relative ? ':' : '') . (join ':', @_) . ':'; } else { return ($relative ? './' : '/') . join '/', @_; } } #------------------------------ =item catfile DIR, ..., DIR, FILE I Like catdir(), but last element is assumed to be a file. Note that, at a minimum, you must supply at least a single DIR. =cut sub catfile { my $self = shift; my $file = pop; if ($^O eq 'Mac') { return $self->catdir(@_) . $file; } else { return $self->catdir(@_) . "/$file"; } } #------------------------------ =back =head1 VERSION $Id: TBone.pm,v 1.1 2005/02/10 19:38:36 dfs Exp $ =head1 CHANGE LOG =over 4 =item Version 1.124 (2001/08/20) The terms-of-use have been placed in the distribution file "COPYING". Also, small documentation tweaks were made. =item Version 1.122 (2001/08/20) Changed output of C<"END"> to C<"# END">; apparently, "END" is not a directive. Maybe it never was. I The storyteller need not say "the end" aloud; Silence is enough. Automatically invoke C when constructing via C. =item Version 1.120 (2001/08/17) Added log_warnings() to support the logging of SIG{__WARN__} messages to the log file (if any). =item Version 1.116 (2000/03/23) Cosmetic improvements only. =item Version 1.112 (1999/05/12) Added lightweight catdir() and catfile() (a la File::Spec) to enhance portability to Mac environment. =item Version 1.111 (1999/04/18) Now uses File::Basename to create "typical" logfile name, for portability. =item Version 1.110 (1999/04/17) Fixed bug in constructor that surfaced if no log was being used. =back Created: Friday-the-13th of February, 1998. =head1 AUTHOR Eryq (F). President, ZeeGee Software Inc. (F). Go to F for the latest downloads and on-line documentation for this module. Enjoy. Yell if it breaks. =cut #------------------------------ 1; __END__ my $T = new ExtUtils::TBone "testout/foo.tlog"; $T->begin(3); $T->msg("before 1\nor 2"); $T->ok(1, "one"); $T->ok(2, "Two"); $T->ok(3, "Three", Roman=>'III', Arabic=>[3, '03'], Misc=>"3\nor 3"); $T->end; 1; IO-stringy-2.111/examples/0000755000076400007640000000000012515754727013501 5ustar dfsdfsIO-stringy-2.111/examples/IO_Scalar_synopsis0000755000076400007640000000463510677325622017175 0ustar dfsdfs#!/usr/bin/perl =head1 NAME IO_Scalar_synopsis - test out IO::Scalar =head1 SYNOPSIS ### From our distribution's top level directory: perl -I./lib examples/IO_Scalar_synopsis =cut use 5.005; use IO::Scalar; use strict; my $line = ('-' x 60)."\n"; my $somestring = "My message:\n"; ### ### Perform I/O on strings, using the basic OO interface... ### ### Open a handle on a string, and append to it: print $line; my $SH = new IO::Scalar \$somestring; $SH->print("Hello"); $SH->print(", world!\nBye now!\n"); print "The string is now: ", $somestring, "\n"; ### Open a handle on a string, read it line-by-line, then close it: print $line; $SH = new IO::Scalar \$somestring; while (defined($_ = $SH->getline)) { print "Got line: $_"; } $SH->close; ### Open a handle on a string, and slurp in all the lines: print $line; $SH = new IO::Scalar \$somestring; print "All lines:\n", $SH->getlines; ### Get the current position (either of two ways): my $pos = $SH->getpos; my $offset = $SH->tell; ### Set the current position (either of two ways): $SH->setpos($pos); $SH->seek($offset, 0); ### Open an anonymous temporary scalar: print $line; $SH = new IO::Scalar; $SH->print("Hi there!"); print "I printed: ", ${$SH->sref}, "\n"; ### get at value ### Don't like OO for your I/O? No problem. ### Thanks to the magic of an invisible tie(), the following now ### works out of the box, just as it does with IO::Handle: ### Open a handle on a string, and append to it: print $line; $SH = new IO::Scalar \$somestring; print $SH "Hello"; print $SH ", world!\nBye now!\n"; print "The string is now: ", $somestring, "\n"; ### Open a handle on a string, read it line-by-line, then close it: print $line; $SH = new IO::Scalar \$somestring; while (<$SH>) { print "Got line: $_"; } close $SH; ### Open a handle on a string, and slurp in all the lines: print $line; $SH = new IO::Scalar \$somestring; print "All lines:\n", <$SH>; ### Get the current position (WARNING: requires 5.6): $offset = tell $SH; ### Set the current position (WARNING: requires 5.6): seek $SH, $offset, 0; ### Open an anonymous temporary scalar: print $line; $SH = new IO::Scalar; print $SH "Hi there!"; print "I printed: ", ${$SH->sref}, "\n"; ### get at value ### Stringification: print $line; my $str = ""; $SH = new IO::Scalar \$str; print $SH "Hello, "; print $SH "world!"; print "I printed: $SH\n"; ### Done! 1; IO-stringy-2.111/MANIFEST0000644000076400007640000000066511533467440013013 0ustar dfsdfsCOPYING MANIFEST Makefile.PL README contrib/Clever.pm examples/IO_Scalar_synopsis lib/IO/AtomicFile.pm lib/IO/InnerFile.pm lib/IO/Lines.pm lib/IO/Scalar.pm lib/IO/ScalarArray.pm lib/IO/Stringy.pm lib/IO/Wrap.pm lib/IO/WrapTie.pm t/Common.pm t/ExtUtils/TBone.pm t/IO_InnerFile.t t/IO_Lines.t t/IO_Scalar.t t/IO_ScalarArray.t t/IO_WrapTie.t t/simple.t t/two.t META.yml Module meta-data (added by MakeMaker) IO-stringy-2.111/Makefile.PL0000755000076400007640000000104010677325622013626 0ustar dfsdfs#!/usr/bin/perl use ExtUtils::MakeMaker; #------------------------------------------------------------ # Makefile: #------------------------------------------------------------ # Ensure the test output directory: (-d "testout") or mkdir "testout", 0755 or die "please make dir ./testout\n"; # Write the Makefile: WriteMakefile( NAME => "IO::Stringy", VERSION_FROM => "lib/IO/Stringy.pm", DISTNAME => "IO-stringy", 'dist' => { COMPRESS => 'gzip -f', SUFFIX => 'gz', } ); IO-stringy-2.111/lib/0000755000076400007640000000000012515754727012431 5ustar dfsdfsIO-stringy-2.111/lib/IO/0000755000076400007640000000000012515754731012733 5ustar dfsdfsIO-stringy-2.111/lib/IO/WrapTie.pm0000644000076400007640000003464312515754666014665 0ustar dfsdfs# SEE DOCUMENTATION AT BOTTOM OF FILE #------------------------------------------------------------ package IO::WrapTie; #------------------------------------------------------------ require 5.004; ### for tie use strict; use vars qw(@ISA @EXPORT $VERSION); use Exporter; # Inheritance, exporting, and package version: @ISA = qw(Exporter); @EXPORT = qw(wraptie); $VERSION = "2.111"; # Function, exported. sub wraptie { IO::WrapTie::Master->new(@_); } # Class method; BACKWARDS-COMPATIBILITY ONLY! sub new { shift; IO::WrapTie::Master->new(@_); } #------------------------------------------------------------ package IO::WrapTie::Master; #------------------------------------------------------------ use strict; use vars qw(@ISA $AUTOLOAD); use IO::Handle; # We inherit from IO::Handle to get methods which invoke i/o operators, # like print(), on our tied handle: @ISA = qw(IO::Handle); #------------------------------ # new SLAVE, TIEARGS... #------------------------------ # Create a new subclass of IO::Handle which... # # (1) Handles i/o OPERATORS because it is tied to an instance of # an i/o-like class, like IO::Scalar. # # (2) Handles i/o METHODS by delegating them to that same tied object!. # # Arguments are the slave class (e.g., IO::Scalar), followed by all # the arguments normally sent into that class's TIEHANDLE method. # In other words, much like the arguments to tie(). :-) # # NOTE: # The thing $x we return must be a BLESSED REF, for ($x->print()). # The underlying symbol must be a FILEHANDLE, for (print $x "foo"). # It has to have a way of getting to the "real" back-end object... # sub new { my $master = shift; my $io = IO::Handle->new; ### create a new handle my $slave = shift; tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE bless $io, $master; ### return a master } #------------------------------ # AUTOLOAD #------------------------------ # Delegate method invocations on the master to the underlying slave. # sub AUTOLOAD { my $method = $AUTOLOAD; $method =~ s/.*:://; my $self = shift; tied(*$self)->$method(\@_); } #------------------------------ # PRELOAD #------------------------------ # Utility. # # Most methods like print(), getline(), etc. which work on the tied object # via Perl's i/o operators (like 'print') are inherited from IO::Handle. # # Other methods, like seek() and sref(), we must delegate ourselves. # AUTOLOAD takes care of these. # # However, it may be necessary to preload delegators into your # own class. PRELOAD will do this. # sub PRELOAD { my $class = shift; foreach (@_) { eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }"; } } # Preload delegators for some standard methods which we can't simply # inherit from IO::Handle... for example, some IO::Handle methods # assume that there is an underlying file descriptor. # PRELOAD IO::WrapTie::Master qw(open opened close read clearerr eof seek tell setpos getpos); #------------------------------------------------------------ package IO::WrapTie::Slave; #------------------------------------------------------------ # Teeny private class providing a new_tie constructor... # # HOW IT ALL WORKS: # # Slaves inherit from this class. # # When you send a new_tie() message to a tie-slave class (like IO::Scalar), # it first determines what class should provide its master, via TIE_MASTER. # In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master. # Then, we create a new master (an IO::Scalar::Master) with the same args # sent to new_tie. # # In general, the new() method of the master is inherited directly # from IO::WrapTie::Master. # sub new_tie { my $self = shift; $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_) } # Default class method for new_tie(). # All your tie-slave class (like IO::Scalar) has to do is override this # method with a method that returns the name of an appropriate "master" # class for tying that slave. # sub TIE_MASTER { 'IO::WrapTie::Master' } #------------------------------ 1; __END__ package IO::WrapTie; ### for doc generator =head1 NAME IO::WrapTie - wrap tieable objects in IO::Handle interface I =head1 SYNOPSIS First of all, you'll need tie(), so: require 5.004; I Use this with any existing class... use IO::WrapTie; use FooHandle; ### implements TIEHANDLE interface ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)". ### We can instead say... $FH = wraptie('FooHandle', &FOO_RDWR, 2); ### Now we can use... print $FH "Hello, "; ### traditional operator syntax... $FH->print("world!\n"); ### ...and OO syntax as well! I You can inherit from the IO::WrapTie::Slave mixin to get a nifty C constructor... #------------------------------ package FooHandle; ### a class which can TIEHANDLE use IO::WrapTie; @ISA = qw(IO::WrapTie::Slave); ### inherit new_tie() ... #------------------------------ package main; $FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master print $FH "Hello, "; ### traditional operator syntax $FH->print("world!\n"); ### OO syntax See IO::Scalar as an example. It also shows you how to create classes which work both with and without 5.004. =head1 DESCRIPTION Suppose you have a class C, where... =over 4 =item * B that is, it performs filehandle-like I/O, but to something other than an underlying file descriptor. Good examples are IO::Scalar (for printing to a string) and IO::Lines (for printing to an array of lines). =item * B (see L); that is, it provides methods TIEHANDLE, GETC, PRINT, PRINTF, READ, and READLINE. =item * B of FileHandle and IO::Handle; i.e., it contains methods like getline(), read(), print(), seek(), tell(), eof(), etc. =back Normally, users of your class would have two options: =over 4 =item * B and forsake named I/O operators like 'print'. =item * B and forsake treating it as a first-class object (i.e., class-specific methods can only be invoked through the underlying object via tied()... giving the object a "split personality"). =back But now with IO::WrapTie, you can say: $WT = wraptie('FooHandle', &FOO_RDWR, 2); $WT->print("Hello, world\n"); ### OO syntax print $WT "Yes!\n"; ### Named operator syntax too! $WT->weird_stuff; ### Other methods! And if you're authoring a class like FooHandle, just have it inherit from C and that first line becomes even prettier: $WT = FooHandle->new_tie(&FOO_RDWR, 2); B now, almost any class can look and work exactly like an IO::Handle... and be used both with OO and non-OO filehandle syntax. =head1 HOW IT ALL WORKS =head2 The data structures Consider this example code, using classes in this distribution: use IO::Scalar; use IO::WrapTie; $WT = wraptie('IO::Scalar',\$s); print $WT "Hello, "; $WT->print("world!\n"); In it, the wraptie() function creates a data structure as follows: * $WT is a blessed reference to a tied filehandle $WT glob; that glob is tied to the "Slave" object. | * You would do all your i/o with $WT directly. | | | ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle V / .-------------. | | | | * Perl i/o operators work on the tied object, | "Master" | invoking the TIEHANDLE methods. | | * Method invocations are delegated to the tied | | slave. `-------------' | tied(*$WT) | .---isa--> IO::WrapTie::Slave V / .-------------. | | | "Slave" | * Instance of FileHandle-like class which doesn't | | actually use file descriptors, like IO::Scalar. | IO::Scalar | * The slave can be any kind of object. | | * Must implement the TIEHANDLE interface. `-------------' I just as an IO::Handle is really just a blessed reference to a I filehandle glob... so also, an IO::WrapTie::Master is really just a blessed reference to a filehandle glob I =head2 How wraptie() works =over 4 =item 1. The call to function C is passed onto C. Note that class IO::WrapTie::Master is a subclass of IO::Handle. =item 2. The C method creates a new IO::Handle object, reblessed into class IO::WrapTie::Master. This object is the I, which will be returned from the constructor. At the same time... =item 3. The C method also creates the I: this is an instance of SLAVECLASS which is created by tying the master's IO::Handle to SLAVECLASS via C. This call to C creates the slave in the following manner: =item 4. Class SLAVECLASS is sent the message C; it will usually delegate this to C, resulting in a new instance of SLAVECLASS being created and returned. =item 5. Once both master and slave have been created, the master is returned to the caller. =back =head2 How I/O operators work (on the master) Consider using an i/o operator on the master: print $WT "Hello, world!\n"; Since the master ($WT) is really a [blessed] reference to a glob, the normal Perl i/o operators like C may be used on it. They will just operate on the symbol part of the glob. Since the glob is tied to the slave, the slave's PRINT method (part of the TIEHANDLE interface) will be automatically invoked. If the slave is an IO::Scalar, that means IO::Scalar::PRINT will be invoked, and that method happens to delegate to the C method of the same class. So the I work is ultimately done by IO::Scalar::print(). =head2 How methods work (on the master) Consider using a method on the master: $WT->print("Hello, world!\n"); Since the master ($WT) is blessed into the class IO::WrapTie::Master, Perl first attempts to find a C method there. Failing that, Perl next attempts to find a C method in the superclass, IO::Handle. It just so happens that there I such a method; that method merely invokes the C i/o operator on the self object... and for that, see above! But let's suppose we're dealing with a method which I part of IO::Handle... for example: my $sref = $WT->sref; In this case, the intuitive behavior is to have the master delegate the method invocation to the slave (now do you see where the designations come from?). This is indeed what happens: IO::WrapTie::Master contains an AUTOLOAD method which performs the delegation. So: when C can't be found in IO::Handle, the AUTOLOAD method of IO::WrapTie::Master is invoked, and the standard behavior of delegating the method to the underlying slave (here, an IO::Scalar) is done. Sometimes, to get this to work properly, you may need to create a subclass of IO::WrapTie::Master which is an effective master for I class, and do the delegation there. =head1 NOTES B Because that means forsaking the use of named operators like print(), and you may need to pass the object to a subroutine which will attempt to use those operators: $O = FooHandle->new(&FOO_RDWR, 2); $O->print("Hello, world\n"); ### OO syntax is okay, BUT.... sub nope { print $_[0] "Nope!\n" } X nope($O); ### ERROR!!! (not a glob ref) B Because (1) you have to use tied() to invoke methods in the object's public interface (yuck), and (2) you may need to pass the tied symbol to another subroutine which will attempt to treat it in an OO-way... and that will break it: tie *T, 'FooHandle', &FOO_RDWR, 2; print T "Hello, world\n"; ### Operator is okay, BUT... tied(*T)->other_stuff; ### yuck! AND... sub nope { shift->print("Nope!\n") } X nope(\*T); ### ERROR!!! (method "print" on unblessed ref) B I tried this, with an implementation similar to that of IO::Socket. The problem is that I. Subclassing IO::Handle will work fine for the OO stuff, and fine with named operators I you tie()... but if you just attempt to say: $IO = FooHandle->new(&FOO_RDWR, 2); print $IO "Hello!\n"; you get a warning from Perl like: Filehandle GEN001 never opened because it's trying to do system-level i/o on an (unopened) file descriptor. To avoid this, you apparently have to tie() the handle... which brings us right back to where we started! At least the IO::WrapTie mixin lets us say: $IO = FooHandle->new_tie(&FOO_RDWR, 2); print $IO "Hello!\n"; and so is not I bad. C<:-)> =head1 WARNINGS Remember: this stuff is for doing FileHandle-like i/o on things I. If you have an underlying file descriptor, you're better off just inheriting from IO::Handle. B it does B return an instance of the i/o class you're tying to! Invoking some methods on the master object causes AUTOLOAD to delegate them to the slave object... so it I like you're manipulating a "FooHandle" object directly, but you're not. I have not explored all the ramifications of this use of tie(). I. =head1 VERSION $Id: WrapTie.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHOR =item Primary Maintainer Dianne Skoll (F). =item Original Author Eryq (F). President, ZeeGee Software Inc (F). =cut IO-stringy-2.111/lib/IO/Lines.pm0000644000076400007640000001033212515754666014351 0ustar dfsdfspackage IO::Lines; =head1 NAME IO::Lines - IO:: interface for reading/writing an array of lines =head1 SYNOPSIS use IO::Lines; ### See IO::ScalarArray for details =head1 DESCRIPTION This class implements objects which behave just like FileHandle (or IO::Handle) objects, except that you may use them to write to (or read from) an array of lines. They can be tiehandle'd as well. This is a subclass of L in which the underlying array has its data stored in a line-oriented-format: that is, every element ends in a C<"\n">, with the possible exception of the final element. This makes C I more efficient; if you plan to do line-oriented reading/printing, you want this class. The C method will enforce this rule, so you can print arbitrary data to the line-array: it will break the data at newlines appropriately. See L for full usage and warnings. =cut use Carp; use strict; use IO::ScalarArray; use vars qw($VERSION @ISA); # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.111"; # Inheritance: @ISA = qw(IO::ScalarArray); ### also gets us new_tie :-) #------------------------------ # # getline # # Instance method, override. # Return the next line, or undef on end of data. # Can safely be called in an array context. # Currently, lines are delimited by "\n". # sub getline { my $self = shift; if (!defined $/) { return join( '', $self->_getlines_for_newlines ); } elsif ($/ eq "\n") { if (!*$self->{Pos}) { ### full line... return *$self->{AR}[*$self->{Str}++]; } else { ### partial line... my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos}); *$self->{Pos} = 0; return $partial; } } else { croak 'unsupported $/: must be "\n" or undef'; } } #------------------------------ # # getlines # # Instance method, override. # Return an array comprised of the remaining lines, or () on end of data. # Must be called in an array context. # Currently, lines are delimited by "\n". # sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); if ((defined $/) and ($/ eq "\n")) { return $self->_getlines_for_newlines(@_); } else { ### slow but steady return $self->SUPER::getlines(@_); } } #------------------------------ # # _getlines_for_newlines # # Instance method, private. # If $/ is newline, do fast getlines. # This CAN NOT invoke getline! # sub _getlines_for_newlines { my $self = shift; my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) }; my @partial = (); if ($Pos) { ### partial line... @partial = (substr( $rArray->[ $Str++ ], $Pos )); *$self->{Pos} = 0; } *$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray return (@partial, @$rArray[ $Str .. $#$rArray ]); ### remaining full lines... } #------------------------------ # # print ARGS... # # Instance method, override. # Print ARGS to the underlying line array. # sub print { if (defined $\ && $\ ne "\n") { croak 'unsupported $\: must be "\n" or undef'; } my $self = shift; ### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<>\n"; my @lines = split /^/, join('', @_); @lines or return 1; ### Did the previous print not end with a newline? ### If so, append first line: if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) { *$self->{AR}[-1] .= shift @lines; } push @{*$self->{AR}}, @lines; ### add the remainder ### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<>\n"; 1; } #------------------------------ 1; __END__ =head1 VERSION $Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHORS =head2 Primary Maintainer Dianne Skoll (F). =head2 Principal author Eryq (F). President, ZeeGee Software Inc (F). =head2 Other contributors Thanks to the following individuals for their invaluable contributions (if I've forgotten or misspelled your name, please email me!): I for his $/ patch and the new C. I for the IO::Handle inheritance and automatic tie-ing. =cut IO-stringy-2.111/lib/IO/Scalar.pm0000644000076400007640000004073712515754664014516 0ustar dfsdfspackage IO::Scalar; =head1 NAME IO::Scalar - IO:: interface for reading/writing a scalar =head1 SYNOPSIS Perform I/O on strings, using the basic OO interface... use 5.005; use IO::Scalar; $data = "My message:\n"; ### Open a handle on a string, and append to it: $SH = new IO::Scalar \$data; $SH->print("Hello"); $SH->print(", world!\nBye now!\n"); print "The string is now: ", $data, "\n"; ### Open a handle on a string, read it line-by-line, then close it: $SH = new IO::Scalar \$data; while (defined($_ = $SH->getline)) { print "Got line: $_"; } $SH->close; ### Open a handle on a string, and slurp in all the lines: $SH = new IO::Scalar \$data; print "All lines:\n", $SH->getlines; ### Get the current position (either of two ways): $pos = $SH->getpos; $offset = $SH->tell; ### Set the current position (either of two ways): $SH->setpos($pos); $SH->seek($offset, 0); ### Open an anonymous temporary scalar: $SH = new IO::Scalar; $SH->print("Hi there!"); print "I printed: ", ${$SH->sref}, "\n"; ### get at value Don't like OO for your I/O? No problem. Thanks to the magic of an invisible tie(), the following now works out of the box, just as it does with IO::Handle: use 5.005; use IO::Scalar; $data = "My message:\n"; ### Open a handle on a string, and append to it: $SH = new IO::Scalar \$data; print $SH "Hello"; print $SH ", world!\nBye now!\n"; print "The string is now: ", $data, "\n"; ### Open a handle on a string, read it line-by-line, then close it: $SH = new IO::Scalar \$data; while (<$SH>) { print "Got line: $_"; } close $SH; ### Open a handle on a string, and slurp in all the lines: $SH = new IO::Scalar \$data; print "All lines:\n", <$SH>; ### Get the current position (WARNING: requires 5.6): $offset = tell $SH; ### Set the current position (WARNING: requires 5.6): seek $SH, $offset, 0; ### Open an anonymous temporary scalar: $SH = new IO::Scalar; print $SH "Hi there!"; print "I printed: ", ${$SH->sref}, "\n"; ### get at value And for you folks with 1.x code out there: the old tie() style still works, though this is I: use IO::Scalar; ### Writing to a scalar... my $s; tie *OUT, 'IO::Scalar', \$s; print OUT "line 1\nline 2\n", "line 3\n"; print "String is now: $s\n" ### Reading and writing an anonymous scalar... tie *OUT, 'IO::Scalar'; print OUT "line 1\nline 2\n", "line 3\n"; tied(OUT)->seek(0,0); while () { print "Got line: ", $_; } Stringification works, too! my $SH = new IO::Scalar \$data; print $SH "Hello, "; print $SH "world!"; print "I printed: $SH\n"; =head1 DESCRIPTION This class is part of the IO::Stringy distribution; see L for change log and general information. The IO::Scalar class implements objects which behave just like IO::Handle (or FileHandle) objects, except that you may use them to write to (or read from) scalars. These handles are automatically tiehandle'd (though please see L<"WARNINGS"> for information relevant to your Perl version). Basically, this: my $s; $SH = new IO::Scalar \$s; $SH->print("Hel", "lo, "); ### OO style $SH->print("world!\n"); ### ditto Or this: my $s; $SH = tie *OUT, 'IO::Scalar', \$s; print OUT "Hel", "lo, "; ### non-OO style print OUT "world!\n"; ### ditto Causes $s to be set to: "Hello, world!\n" =head1 PUBLIC INTERFACE =cut use Carp; use strict; use vars qw($VERSION @ISA); use IO::Handle; use 5.005; ### Stringification, courtesy of B. K. Oxley (binkley): :-) use overload '""' => sub { ${*{$_[0]}->{SR}} }; use overload 'bool' => sub { 1 }; ### have to do this, so object is true! ### The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.111"; ### Inheritance: @ISA = qw(IO::Handle); ### This stuff should be got rid of ASAP. require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); #============================== =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I Return a new, unattached scalar handle. If any arguments are given, they're sent to open(). =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = bless \do { local *FH }, $class; tie *$self, $class, $self; $self->open(@_); ### open on anonymous by default $self; } sub DESTROY { shift->close; } #------------------------------ =item open [SCALARREF] I Open the scalar handle on a new scalar, pointed to by SCALARREF. If no SCALARREF is given, a "private" scalar is created to hold the file data. Returns the self object on success, undefined on error. =cut sub open { my ($self, $sref) = @_; ### Sanity: defined($sref) or do {my $s = ''; $sref = \$s}; (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; ### Setup: *$self->{Pos} = 0; ### seek position *$self->{SR} = $sref; ### scalar reference $self; } #------------------------------ =item opened I Is the scalar handle opened on something? =cut sub opened { *{shift()}->{SR}; } #------------------------------ =item close I Disassociate the scalar handle from its underlying scalar. Done automatically on destroy. =cut sub close { my $self = shift; %{*$self} = (); 1; } =back =cut #============================== =head2 Input and output =over 4 =cut #------------------------------ =item flush I No-op, provided for OO compatibility. =cut sub flush { "0 but true" } #------------------------------ =item fileno I No-op, returns undef =cut sub fileno { } #------------------------------ =item getc I Return the next character, or undef if none remain. =cut sub getc { my $self = shift; ### Return undef right away if at EOF; else, move pos forward: return undef if $self->eof; substr(${*$self->{SR}}, *$self->{Pos}++, 1); } #------------------------------ =item getline I Return the next line, or undef on end of string. Can safely be called in an array context. Currently, lines are delimited by "\n". =cut sub getline { my $self = shift; ### Return undef right away if at EOF: return undef if $self->eof; ### Get next line: my $sr = *$self->{SR}; my $i = *$self->{Pos}; ### Start matching at this point. ### Minimal impact implementation! ### We do the fast thing (no regexps) if using the ### classic input record separator. ### Case 1: $/ is undef: slurp all... if (!defined($/)) { *$self->{Pos} = length $$sr; return substr($$sr, $i); } ### Case 2: $/ is "\n": zoom zoom zoom... elsif ($/ eq "\012") { ### Seek ahead for "\n"... yes, this really is faster than regexps. my $len = length($$sr); for (; $i < $len; ++$i) { last if ord (substr ($$sr, $i, 1)) == 10; } ### Extract the line: my $line; if ($i < $len) { ### We found a "\n": $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); *$self->{Pos} = $i+1; ### Remember where we finished up. } else { ### No "\n"; slurp the remainder: $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); *$self->{Pos} = $len; } return $line; } ### Case 3: $/ is ref to int. Do fixed-size records. ### (Thanks to Dominique Quatravaux.) elsif (ref($/)) { my $len = length($$sr); my $i = ${$/} + 0; my $line = substr ($$sr, *$self->{Pos}, $i); *$self->{Pos} += $i; *$self->{Pos} = $len if (*$self->{Pos} > $len); return $line; } ### Case 4: $/ is either "" (paragraphs) or something weird... ### This is Graham's general-purpose stuff, which might be ### a tad slower than Case 2 for typical data, because ### of the regexps. else { pos($$sr) = $i; ### If in paragraph mode, skip leading lines (and update i!): length($/) or (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); ### If we see the separator in the buffer ahead... if (length($/) ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! : $$sr =~ m,\n\n,g ### (a paragraph) ) { *$self->{Pos} = pos $$sr; return substr($$sr, $i, *$self->{Pos}-$i); } ### Else if no separator remains, just slurp the rest: else { *$self->{Pos} = length $$sr; return substr($$sr, $i); } } } #------------------------------ =item getlines I Get all remaining lines. It will croak() if accidentally called in a scalar context. =cut sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); my ($line, @lines); push @lines, $line while (defined($line = $self->getline)); @lines; } #------------------------------ =item print ARGS... I Print ARGS to the underlying scalar. B this continues to always cause a seek to the end of the string, but if you perform seek()s and tell()s, it is still safer to explicitly seek-to-end before subsequent print()s. =cut sub print { my $self = shift; *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); 1; } sub _unsafe_print { my $self = shift; my $append = join('', @_) . $\; ${*$self->{SR}} .= $append; *$self->{Pos} += length($append); 1; } sub _old_print { my $self = shift; ${*$self->{SR}} .= join('', @_) . $\; *$self->{Pos} = length(${*$self->{SR}}); 1; } #------------------------------ =item read BUF, NBYTES, [OFFSET] I Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub read { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); $n = length($read); *$self->{Pos} += $n; ($off ? substr($_[1], $off) : $_[1]) = $read; return $n; } #------------------------------ =item write BUF, NBYTES, [OFFSET] I Write some bytes to the scalar. =cut sub write { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $data = substr($_[1], $off, $n); $n = length($data); $self->print($data); return $n; } #------------------------------ =item sysread BUF, LEN, [OFFSET] I Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub sysread { my $self = shift; $self->read(@_); } #------------------------------ =item syswrite BUF, NBYTES, [OFFSET] I Write some bytes to the scalar. =cut sub syswrite { my $self = shift; $self->write(@_); } =back =cut #============================== =head2 Seeking/telling and other attributes =over 4 =cut #------------------------------ =item autoflush I No-op, provided for OO compatibility. =cut sub autoflush {} #------------------------------ =item binmode I No-op, provided for OO compatibility. =cut sub binmode {} #------------------------------ =item clearerr I Clear the error and EOF flags. A no-op. =cut sub clearerr { 1 } #------------------------------ =item eof I Are we at end of file? =cut sub eof { my $self = shift; (*$self->{Pos} >= length(${*$self->{SR}})); } #------------------------------ =item seek OFFSET, WHENCE I Seek to a given position in the stream. =cut sub seek { my ($self, $pos, $whence) = @_; my $eofpos = length(${*$self->{SR}}); ### Seek: if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END else { croak "bad seek whence ($whence)" } ### Fixup: if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } return 1; } #------------------------------ =item sysseek OFFSET, WHENCE I Identical to C, I =cut sub sysseek { my $self = shift; $self->seek (@_); } #------------------------------ =item tell I Return the current position in the stream, as a numeric offset. =cut sub tell { *{shift()}->{Pos} } #------------------------------ # # use_RS [YESNO] # # I # Obey the current setting of $/, like IO::Handle does? # Default is false in 1.x, but cold-welded true in 2.x and later. # sub use_RS { my ($self, $yesno) = @_; carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; } #------------------------------ =item setpos POS I Set the current position, using the opaque value returned by C. =cut sub setpos { shift->seek($_[0],0) } #------------------------------ =item getpos I Return the current position in the string, as an opaque object. =cut *getpos = \&tell; #------------------------------ =item sref I Return a reference to the underlying scalar. =cut sub sref { *{shift()}->{SR} } #------------------------------ # Tied handle methods... #------------------------------ # Conventional tiehandle interface: sub TIEHANDLE { ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar")) ? $_[1] : shift->new(@_)); } sub GETC { shift->getc(@_) } sub PRINT { shift->print(@_) } sub PRINTF { shift->print(sprintf(shift, @_)) } sub READ { shift->read(@_) } sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } sub WRITE { shift->write(@_); } sub CLOSE { shift->close(@_); } sub SEEK { shift->seek(@_); } sub TELL { shift->tell(@_); } sub EOF { shift->eof(@_); } sub BINMODE { 1; } #------------------------------------------------------------ 1; __END__ =back =cut =head1 WARNINGS Perl's TIEHANDLE spec was incomplete prior to 5.005_57; it was missing support for C, C, and C. Attempting to use these functions with an IO::Scalar will not work prior to 5.005_57. IO::Scalar will not have the relevant methods invoked; and even worse, this kind of bug can lie dormant for a while. If you turn warnings on (via C<$^W> or C), and you see something like this... attempt to seek on unopened filehandle ...then you are probably trying to use one of these functions on an IO::Scalar with an old Perl. The remedy is to simply use the OO version; e.g.: $SH->seek(0,0); ### GOOD: will work on any 5.005 seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond =head1 VERSION $Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHORS =head2 Primary Maintainer Dianne Skoll (F). =head2 Principal author Eryq (F). President, ZeeGee Software Inc (F). =head2 Other contributors The full set of contributors always includes the folks mentioned in L. But just the same, special thanks to the following individuals for their invaluable contributions (if I've forgotten or misspelled your name, please email me!): I for contributing C. I for suggesting C. I for finding and fixing the bug in C. I for his offset-using read() and write() implementations. I for his patches to massively improve the performance of C and add C and C. I for stringification and inheritance improvements, and sundry good ideas. I for the IO::Handle inheritance and automatic tie-ing. =head1 SEE ALSO L, which is quite similar but which was designed more-recently and with an IO::Handle-like interface in mind, so you could mix OO- and native-filehandle usage without using tied(). I as of version 2.x, these classes all work like their IO::Handle counterparts, so we have comparable functionality to IO::String. =cut IO-stringy-2.111/lib/IO/InnerFile.pm0000644000076400007640000001346612515754666015165 0ustar dfsdfspackage IO::InnerFile; =head1 NAME IO::InnerFile - define a file inside another file =head1 SYNOPSIS ### Read a subset of a file: $inner = IO::InnerFile->new($fh, $start, $length); while (<$inner>) { ... } =head1 DESCRIPTION If you have a filehandle that can seek() and tell(), then you can open an IO::InnerFile on a range of the underlying file. =head1 PUBLIC INTERFACE =over =cut use Symbol; # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.111"; #------------------------------ =item new FILEHANDLE, [START, [LENGTH]] I Create a new inner-file opened on the given FILEHANDLE, from bytes START to START+LENGTH. Both START and LENGTH default to 0; negative values are silently coerced to zero. Note that FILEHANDLE must be able to seek() and tell(), in addition to whatever other methods you may desire for reading it. =cut sub new { my ($class, $fh, $start, $lg) = @_; $start = 0 if (!$start or ($start < 0)); $lg = 0 if (!$lg or ($lg < 0)); ### Create the underlying "object": my $a = { FH => $fh, CRPOS => 0, START => $start, LG => $lg, }; ### Create a new filehandle tied to this object: $fh = gensym; tie(*$fh, $class, $a); return bless($fh, $class); } sub TIEHANDLE { my ($class, $data) = @_; return bless($data, $class); } sub DESTROY { my ($self) = @_; $self->close() if (ref($self) eq 'SCALAR'); } #------------------------------ =item set_length LENGTH =item get_length =item add_length NBYTES I Get/set the virtual length of the inner file. =cut sub set_length { tied(${$_[0]})->{LG} = $_[1]; } sub get_length { tied(${$_[0]})->{LG}; } sub add_length { tied(${$_[0]})->{LG} += $_[1]; } #------------------------------ =item set_start START =item get_start =item add_start NBYTES I Get/set the virtual start position of the inner file. =cut sub set_start { tied(${$_[0]})->{START} = $_[1]; } sub get_start { tied(${$_[0]})->{START}; } sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; } sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; } #------------------------------ =item binmode =item close =item flush =item getc =item getline =item print LIST =item printf LIST =item read BUF, NBYTES =item readline =item seek OFFFSET, WHENCE =item tell =item write ARGS... I Standard filehandle methods. =cut sub write { shift->WRITE(@_) } sub print { shift->PRINT(@_) } sub printf { shift->PRINTF(@_) } sub flush { "0 but true"; } sub fileno { } sub binmode { 1; } sub getc { return GETC(tied(${$_[0]}) ); } sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); } sub readline { return READLINE( tied(${$_[0]}) ); } sub getline { return READLINE( tied(${$_[0]}) ); } sub close { return CLOSE(tied(${$_[0]}) ); } sub seek { my ($self, $ofs, $whence) = @_; $self = tied( $$self ); $self->{CRPOS} = $ofs if ($whence == 0); $self->{CRPOS}+= $ofs if ($whence == 1); $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2); $self->{CRPOS} = 0 if ($self->{CRPOS} < 0); $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG}); return 1; } sub tell { return tied(${$_[0]})->{CRPOS}; } sub WRITE { die "inner files can only open for reading\n"; } sub PRINT { die "inner files can only open for reading\n"; } sub PRINTF { die "inner files can only open for reading\n"; } sub GETC { my ($self) = @_; return 0 if ($self->{CRPOS} >= $self->{LG}); my $data; ### Save and seek... my $old_pos = $self->{FH}->tell; $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); ### ...read... my $lg = $self->{FH}->read($data, 1); $self->{CRPOS} += $lg; ### ...and restore: $self->{FH}->seek($old_pos, 0); $self->{LG} = $self->{CRPOS} unless ($lg); return ($lg ? $data : undef); } sub READ { my ($self, $undefined, $lg, $ofs) = @_; $undefined = undef; return 0 if ($self->{CRPOS} >= $self->{LG}); $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); return 0 unless ($lg); ### Save and seek... my $old_pos = $self->{FH}->tell; $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); ### ...read... $lg = $self->{FH}->read($_[1], $lg, $_[3] ); $self->{CRPOS} += $lg; ### ...and restore: $self->{FH}->seek($old_pos, 0); $self->{LG} = $self->{CRPOS} unless ($lg); return $lg; } sub READLINE { my ($self) = @_; return $self->_readline_helper() unless wantarray; my @arr; while(defined(my $line = $self->_readline_helper())) { push(@arr, $line); } return @arr; } sub _readline_helper { my ($self) = @_; return undef if ($self->{CRPOS} >= $self->{LG}); # Handle slurp mode (CPAN ticket #72710) if (! defined($/)) { my $text; $self->READ($text, $self->{LG} - $self->{CRPOS}); return $text; } ### Save and seek... my $old_pos = $self->{FH}->tell; $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); ### ...read... my $text = $self->{FH}->getline; ### ...and restore: $self->{FH}->seek($old_pos, 0); #### If we detected a new EOF ... unless (defined $text) { $self->{LG} = $self->{CRPOS}; return undef; } my $lg=length($text); $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); $self->{CRPOS} += $lg; return substr($text, 0,$lg); } sub CLOSE { %{$_[0]}=(); } 1; __END__ =back =head1 VERSION $Id: InnerFile.pm,v 1.4 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHOR Original version by Doru Petrescu (pdoru@kappa.ro). Documentation and by Eryq (eryq@zeegee.com). Currently maintained by Dianne Skoll (dfs@roaringpenguin.com). =cut IO-stringy-2.111/lib/IO/Wrap.pm0000644000076400007640000001174412515754667014221 0ustar dfsdfspackage IO::Wrap; # SEE DOCUMENTATION AT BOTTOM OF FILE require 5.002; use strict; use vars qw(@ISA @EXPORT $VERSION); @ISA = qw(Exporter); @EXPORT = qw(wraphandle); use FileHandle; use Carp; # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.111"; #------------------------------ # wraphandle RAW #------------------------------ sub wraphandle { my $raw = shift; new IO::Wrap $raw; } #------------------------------ # new STREAM #------------------------------ sub new { my ($class, $stream) = @_; no strict 'refs'; ### Convert raw scalar to globref: ref($stream) or $stream = \*$stream; ### Wrap globref and incomplete objects: if ((ref($stream) eq 'GLOB') or ### globref (ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) { return bless \$stream, $class; } $stream; ### already okay! } #------------------------------ # I/O methods... #------------------------------ sub close { my $self = shift; return close($$self); } sub fileno { my $self = shift; my $fh = $$self; return fileno($fh); } sub getline { my $self = shift; my $fh = $$self; return scalar(<$fh>); } sub getlines { my $self = shift; wantarray or croak("Can't call getlines in scalar context!"); my $fh = $$self; <$fh>; } sub print { my $self = shift; print { $$self } @_; } sub read { my $self = shift; return read($$self, $_[0], $_[1]); } sub seek { my $self = shift; return seek($$self, $_[0], $_[1]); } sub tell { my $self = shift; return tell($$self); } #------------------------------ 1; __END__ =head1 NAME IO::Wrap - wrap raw filehandles in IO::Handle interface =head1 SYNOPSIS use IO::Wrap; ### Do stuff with any kind of filehandle (including a bare globref), or ### any kind of blessed object that responds to a print() message. ### sub do_stuff { my $fh = shift; ### At this point, we have no idea what the user gave us... ### a globref? a FileHandle? a scalar filehandle name? $fh = wraphandle($fh); ### At this point, we know we have an IO::Handle-like object! $fh->print("Hey there!"); ... } =head1 DESCRIPTION Let's say you want to write some code which does I/O, but you don't want to force the caller to provide you with a FileHandle or IO::Handle object. You want them to be able to say: do_stuff(\*STDOUT); do_stuff('STDERR'); do_stuff($some_FileHandle_object); do_stuff($some_IO_Handle_object); And even: do_stuff($any_object_with_a_print_method); Sure, one way to do it is to force the caller to use tiehandle(). But that puts the burden on them. Another way to do it is to use B, which provides you with the following functions: =over 4 =item wraphandle SCALAR This function will take a single argument, and "wrap" it based on what it seems to be... =over 4 =item * B like C<"STDOUT"> or C<"Class::HANDLE">. In this case, the filehandle name is wrapped in an IO::Wrap object, which is returned. =item * B like C<\*STDOUT>. In this case, the filehandle glob is wrapped in an IO::Wrap object, which is returned. =item * B In this case, the FileHandle is wrapped in an IO::Wrap object if and only if your FileHandle class does not support the C method. =item * B which is assumed to be already conformant to the IO::Handle interface. In this case, you just get back that object. =back =back If you get back an IO::Wrap object, it will obey a basic subset of the IO:: interface. That is, the following methods (note: I said I, not named operators) should work on the thing you get back: close getline getlines print ARGS... read BUFFER,NBYTES seek POS,WHENCE tell =head1 NOTES Clearly, when wrapping a raw external filehandle (like \*STDOUT), I didn't want to close the file descriptor when the "wrapper" object is destroyed... since the user might not appreciate that! Hence, there's no DESTROY method in this class. When wrapping a FileHandle object, however, I believe that Perl will invoke the FileHandle::DESTROY when the last reference goes away, so in that case, the filehandle is closed if the wrapped FileHandle really was the last reference to it. =head1 WARNINGS This module does not allow you to wrap filehandle names which are given as strings that lack the package they were opened in. That is, if a user opens FOO in package Foo, they must pass it to you either as C<\*FOO> or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine. =head1 VERSION $Id: Wrap.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHOR =item Primary Maintainer Dianne Skoll (F). =item Original Author Eryq (F). President, ZeeGee Software Inc (F). =cut IO-stringy-2.111/lib/IO/AtomicFile.pm0000644000076400007640000001145412515754667015322 0ustar dfsdfspackage IO::AtomicFile; ### DOCUMENTATION AT BOTTOM OF FILE # Be strict: use strict; # External modules: use IO::File; #------------------------------ # # GLOBALS... # #------------------------------ use vars qw($VERSION @ISA); # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.111"; # Inheritance: @ISA = qw(IO::File); #------------------------------ # new ARGS... #------------------------------ # Class method, constructor. # Any arguments are sent to open(). # sub new { my $class = shift; my $self = $class->SUPER::new(); ${*$self}{'io_atomicfile_suffix'} = ''; $self->open(@_) if @_; $self; } #------------------------------ # DESTROY #------------------------------ # Destructor. # sub DESTROY { shift->close(1); ### like close, but raises fatal exception on failure } #------------------------------ # open PATH, MODE #------------------------------ # Class/instance method. # sub open { my ($self, $path, $mode) = @_; ref($self) or $self = $self->new; ### now we have an instance! ### Create tmp path, and remember this info: my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'}; ${*$self}{'io_atomicfile_temp'} = $temp; ${*$self}{'io_atomicfile_path'} = $path; ### Open the file! Returns filehandle on success, for use as a constructor: $self->SUPER::open($temp, $mode) ? $self : undef; } #------------------------------ # _closed [YESNO] #------------------------------ # Instance method, private. # Are we already closed? Argument sets new value, returns previous one. # sub _closed { my $self = shift; my $oldval = ${*$self}{'io_atomicfile_closed'}; ${*$self}{'io_atomicfile_closed'} = shift if @_; $oldval; } #------------------------------ # close #------------------------------ # Instance method. # Close the handle, and rename the temp file to its final name. # sub close { my ($self, $die) = @_; unless ($self->_closed(1)) { ### sentinel... if ($self->SUPER::close()) { rename(${*$self}{'io_atomicfile_temp'}, ${*$self}{'io_atomicfile_path'}) or ($die ? die "close (rename) atomic file: $!\n" : return undef); } else { ($die ? die "close atomic file: $!\n" : return undef); } } 1; } #------------------------------ # delete #------------------------------ # Instance method. # Close the handle, and delete the temp file. # sub delete { my $self = shift; unless ($self->_closed(1)) { ### sentinel... $self->SUPER::close(); return unlink(${*$self}{'io_atomicfile_temp'}); } 1; } #------------------------------ # detach #------------------------------ # Instance method. # Close the handle, but DO NOT delete the temp file. # sub detach { my $self = shift; $self->SUPER::close() unless ($self->_closed(1)); 1; } #------------------------------ 1; __END__ =head1 NAME IO::AtomicFile - write a file which is updated atomically =head1 SYNOPSIS use IO::AtomicFile; ### Write a temp file, and have it install itself when closed: my $FH = IO::AtomicFile->open("bar.dat", "w"); print $FH "Hello!\n"; $FH->close || die "couldn't install atomic file: $!"; ### Write a temp file, but delete it before it gets installed: my $FH = IO::AtomicFile->open("bar.dat", "w"); print $FH "Hello!\n"; $FH->delete; ### Write a temp file, but neither install it nor delete it: my $FH = IO::AtomicFile->open("bar.dat", "w"); print $FH "Hello!\n"; $FH->detach; =head1 DESCRIPTION This module is intended for people who need to update files reliably in the face of unexpected program termination. For example, you generally don't want to be halfway in the middle of writing I and have your program terminate! Even the act of writing a single scalar to a filehandle is I atomic. But this module gives you true atomic updates, via rename(). When you open a file I via this module, you are I opening a temporary file I, and writing your output there. The act of closing this file (either explicitly via close(), or implicitly via the destruction of the object) will cause rename() to be called... therefore, from the point of view of the outside world, the file's contents are updated in a single time quantum. To ensure that problems do not go undetected, the "close" method done by the destructor will raise a fatal exception if the rename() fails. The explicit close() just returns undef. You can also decide at any point to trash the file you've been building. =head1 AUTHOR =head2 Primary Maintainer Dianne Skoll (F). =head2 Original Author Eryq (F). President, ZeeGee Software Inc (F). =head1 REVISION $Revision: 1.2 $ =cut IO-stringy-2.111/lib/IO/Stringy.pm0000644000076400007640000002750712515754667014753 0ustar dfsdfspackage IO::Stringy; use vars qw($VERSION); $VERSION = "2.111"; 1; __END__ =head1 NAME IO-stringy - I/O on in-core objects like strings and arrays =head1 SYNOPSIS IO:: ::AtomicFile adpO Write a file which is updated atomically ERYQ ::Lines bdpO I/O handle to read/write to array of lines ERYQ ::Scalar RdpO I/O handle to read/write to a string ERYQ ::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ ::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ ::WrapTie adpO Tie your handles & retain full OO interface ERYQ =head1 DESCRIPTION This toolkit primarily provides modules for performing both traditional and object-oriented i/o) on things I than normal filehandles; in particular, L, L, and L. In the more-traditional IO::Handle front, we have L which may be used to painlessly create files which are updated atomically. And in the "this-may-prove-useful" corner, we have L, whose exported wraphandle() function will clothe anything that's not a blessed object in an IO::Handle-like wrapper... so you can just use OO syntax and stop worrying about whether your function's caller handed you a string, a globref, or a FileHandle. =head1 WARNINGS Perl's TIEHANDLE spec was incomplete prior to 5.005_57; it was missing support for C, C, and C. Attempting to use these functions with an IO::Scalar, IO::ScalarArray, IO::Lines, etc. B prior to 5.005_57. None of the relevant methods will be invoked by Perl; and even worse, this kind of bug can lie dormant for a while. If you turn warnings on (via C<$^W> or C), and you see something like this... seek() on unopened file ...then you are probably trying to use one of these functions on one of our IO:: classes with an old Perl. The remedy is to simply use the OO version; e.g.: $SH->seek(0,0); ### GOOD: will work on any 5.005 seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond =head1 INSTALLATION =head2 Requirements As of version 2.x, this toolkit requires Perl 5.005 for the IO::Handle subclasses, and 5.005_57 or better is B recommended. See L<"WARNINGS"> for details. =head2 Directions Most of you already know the drill... perl Makefile.PL make make test make install For everyone else out there... if you've never installed Perl code before, or you're trying to use this in an environment where your sysadmin or ISP won't let you do interesting things, B since this module contains no binary extensions, you can cheat. That means copying the directory tree under my "./lib" directory into someplace where your script can "see" it. For example, under Linux: cp -r IO-stringy-1.234/lib/* /path/to/my/perl/ Now, in your Perl code, do this: use lib "/path/to/my/perl"; use IO::Scalar; ### or whatever Ok, now you've been told. At this point, anyone who whines about not being given enough information gets an unflattering haiku written about them in the next change log. I'll do it. Don't think I won't. =head1 VERSION $Id: Stringy.pm,v 1.3 2005/02/10 21:24:05 dfs Exp $ =head1 TO DO =over 4 =item (2000/08/02) Finalize $/ support Graham Barr submitted this patch half a I ago; Like a moron, I lost his message under a ton of others, and only now have the experimental implementation done. Will the sudden sensitivity to $/ hose anyone out there? I'm worried, so you have to enable it explicitly in 1.x. It will be on by default in 2.x, though only IO::Scalar has been implemented. =item (2001/08/08) Remove IO::WrapTie from new IO:: classes It's not needed. Backwards compatibility could be maintained by having new_tie() be identical to new(). Heck, I'll bet that IO::WrapTie should be reimplemented so the returned object is just like an IO::Scalar in its use of globrefs. =back =head1 CHANGE LOG =over 4 =item Version 2.110 (2005/02/10) Maintainership taken over by DSKOLL Closed the following bugs at https://rt.cpan.org/NoAuth/Bugs.html?Dist=IO-stringy: =item 2208 IO::ScalarArray->getline does not return undef for EOF if undef($/) =item 7132 IO-stringy/Makefile.PL bug - name should be module name =item 11249 IO::Scalar flush shouldn't return undef =item 2172 $\ (output record separator) not respected =item 8605 IO::InnerFile::seek() should return 1 on success =item 4798 *.html in lib/ =item 4369 Improvement: handling of fixed-size reads in IO::Scalar (Actually, bug 4369 was closed in Version 2.109) =item Version 2.109 (2003/12/21) IO::Scalar::getline now works with ref to int. I =item Version 2.108 (2001/08/20) The terms-of-use have been placed in the distribution file "COPYING". Also, small documentation tweaks were made. =item Version 2.105 (2001/08/09) Added support for various seek() whences to IO::ScalarArray. Added support for consulting $/ in IO::Scalar and IO::ScalarArray. The old C is not even an option. Unsupported record separators will cause a croak(). Added a lot of regression tests to supoprt the above. Better on-line docs (hyperlinks to individual functions). =item Version 2.103 (2001/08/08) After sober consideration I have reimplemented IO::Scalar::print() so that it once again always seeks to the end of the string. Benchmarks show the new implementation to be just as fast as Juergen's contributed patch; until someone can convince me otherwise, the current, safer implementation stays. I thought more about giving IO::Scalar two separate handles, one for reading and one for writing, as suggested by Binkley. His points about what tell() and eof() return are, I think, show-stoppers for this feature. Even the manpages for stdio's fseek() seem to imply a I file position indicator, not two. So I think I will take this off the TO DO list. B you can always have two handles open on the same scalar, one which you only write to, and one which you only read from. That should give the same effect. =item Version 2.101 (2001/08/07) B This is the initial release of the "IO::Scalar and friends are now subclasses of IO::Handle". I'm flinging it against the wall. Please tell me if the banana sticks. When it does, the banana will be called 2.2x. First off, I, who has provided an I service by patching IO::Scalar and friends so that they (1) inherit from IO::Handle, (2) automatically tie themselves so that the C objects can be used in native i/o constructs, and (3) doing it so that the whole damn thing passes its regression tests. As Doug knows, my globref Kung-Fu was not up to the task; he graciously provided the patches. This has earned him a seat at the L table, and the right to have me address him as I. Performance of IO::Scalar::print() has been improved by as much as 2x for lots of little prints, with the cost of forcing those who print-then-seek-then-print to explicitly seek to end-of-string before printing again. I Added the COPYING file, which had been missing from prior versions. I IO::Scalar consults $/ by default (1.x ignored it by default). Yes, I still need to support IO::ScalarArray. =item Version 1.221 (2001/08/07) I threatened in L<"INSTALLATION"> to write an unflattering haiku about anyone who whined that I gave them insufficient information... but it turns out that I left out a crucial direction. D'OH! I Enough info there? Here's unflattering haiku: Forgot the line, "make"! ;-) =item Version 1.220 (2001/04/03) Added untested SEEK, TELL, and EOF methods to IO::Scalar and IO::ScalarArray to support corresponding functions for tied filehandles: untested, because I'm still running 5.00556 and Perl is complaining about "tell() on unopened file". I Removed not-fully-blank lines from modules; these were causing lots of POD-related warnings. I =item Version 1.219 (2001/02/23) IO::Scalar objects can now be made sensitive to $/ . Pains were taken to keep the fast code fast while adding this feature. I =item Version 1.218 (2001/02/23) IO::Scalar has a new sysseek() method. I New "TO DO" section, because people who submit patches/ideas should at least know that they're in the system... and that I won't lose their stuff. Please read it. New entries in L<"AUTHOR">. Please read those too. =item Version 1.216 (2000/09/28) B I thought I'd remembered a problem with this ages ago, related to the fact that these IO:: modules don't have "real" filehandles, but the problem apparently isn't surfacing now. If you suddenly encounter Perl warnings during global destruction (especially if you're using tied filehandles), then please let me know! I B Apparently, the offset and the number-of-bytes arguments were, for all practical purposes, I You were okay if you did all your writing with print(), but boy was I a stupid bug! I Newspaper headline typeset by dyslexic man loses urgency BABY EATS FISH is simply not equivalent to FISH EATS BABY B I =item Version 1.215 (2000/09/05) Added 'bool' overload to '""' overload, so object always evaluates to true. (Whew. Glad I caught this before it went to CPAN.) =item Version 1.214 (2000/09/03) Evaluating an IO::Scalar in a string context now yields the underlying string. I =item Version 1.213 (2000/08/16) Minor documentation fixes. =item Version 1.212 (2000/06/02) Fixed IO::InnerFile incompatibility with Perl5.004. I =item Version 1.210 (2000/04/17) Added flush() and other no-op methods. I =item Version 1.209 (2000/03/17) Small bug fixes. =item Version 1.208 (2000/03/14) Incorporated a number of contributed patches and extensions, mostly related to speed hacks, support for "offset", and WRITE/CLOSE methods. I =item Version 1.206 (1999/04/18) Added creation of ./testout when Makefile.PL is run. =item Version 1.205 (1999/01/15) Verified for Perl5.005. =item Version 1.202 (1998/04/18) New IO::WrapTie and IO::AtomicFile added. =item Version 1.110 Added IO::WrapTie. =item Version 1.107 Added IO::Lines, and made some bug fixes to IO::ScalarArray. Also, added getc(). =item Version 1.105 No real changes; just upgraded IO::Wrap to have a $VERSION string. =back =head1 AUTHOR =over 4 =item Primary Maintainer Dianne Skoll (F). =item Original Author Eryq (F). President, ZeeGee Software Inc (F). =item Co-Authors For all their bug reports and patch submissions, the following are officially recognized: Richard Jones B. K. Oxley (binkley) Doru Petrescu Doug Wilson (for picking up the ball I dropped, and doing tie() right) =back Go to F for the latest downloads and on-line documentation for this module. Enjoy. Yell if it breaks. =cut IO-stringy-2.111/lib/IO/ScalarArray.pm0000644000076400007640000004246112515754667015514 0ustar dfsdfspackage IO::ScalarArray; =head1 NAME IO::ScalarArray - IO:: interface for reading/writing an array of scalars =head1 SYNOPSIS Perform I/O on strings, using the basic OO interface... use IO::ScalarArray; @data = ("My mes", "sage:\n"); ### Open a handle on an array, and append to it: $AH = new IO::ScalarArray \@data; $AH->print("Hello"); $AH->print(", world!\nBye now!\n"); print "The array is now: ", @data, "\n"; ### Open a handle on an array, read it line-by-line, then close it: $AH = new IO::ScalarArray \@data; while (defined($_ = $AH->getline)) { print "Got line: $_"; } $AH->close; ### Open a handle on an array, and slurp in all the lines: $AH = new IO::ScalarArray \@data; print "All lines:\n", $AH->getlines; ### Get the current position (either of two ways): $pos = $AH->getpos; $offset = $AH->tell; ### Set the current position (either of two ways): $AH->setpos($pos); $AH->seek($offset, 0); ### Open an anonymous temporary array: $AH = new IO::ScalarArray; $AH->print("Hi there!"); print "I printed: ", @{$AH->aref}, "\n"; ### get at value Don't like OO for your I/O? No problem. Thanks to the magic of an invisible tie(), the following now works out of the box, just as it does with IO::Handle: use IO::ScalarArray; @data = ("My mes", "sage:\n"); ### Open a handle on an array, and append to it: $AH = new IO::ScalarArray \@data; print $AH "Hello"; print $AH ", world!\nBye now!\n"; print "The array is now: ", @data, "\n"; ### Open a handle on a string, read it line-by-line, then close it: $AH = new IO::ScalarArray \@data; while (<$AH>) { print "Got line: $_"; } close $AH; ### Open a handle on a string, and slurp in all the lines: $AH = new IO::ScalarArray \@data; print "All lines:\n", <$AH>; ### Get the current position (WARNING: requires 5.6): $offset = tell $AH; ### Set the current position (WARNING: requires 5.6): seek $AH, $offset, 0; ### Open an anonymous temporary scalar: $AH = new IO::ScalarArray; print $AH "Hi there!"; print "I printed: ", @{$AH->aref}, "\n"; ### get at value And for you folks with 1.x code out there: the old tie() style still works, though this is I: use IO::ScalarArray; ### Writing to a scalar... my @a; tie *OUT, 'IO::ScalarArray', \@a; print OUT "line 1\nline 2\n", "line 3\n"; print "Array is now: ", @a, "\n" ### Reading and writing an anonymous scalar... tie *OUT, 'IO::ScalarArray'; print OUT "line 1\nline 2\n", "line 3\n"; tied(OUT)->seek(0,0); while () { print "Got line: ", $_; } =head1 DESCRIPTION This class is part of the IO::Stringy distribution; see L for change log and general information. The IO::ScalarArray class implements objects which behave just like IO::Handle (or FileHandle) objects, except that you may use them to write to (or read from) arrays of scalars. Logically, an array of scalars defines an in-core "file" whose contents are the concatenation of the scalars in the array. The handles created by this class are automatically tiehandle'd (though please see L<"WARNINGS"> for information relevant to your Perl version). For writing large amounts of data with individual print() statements, this class is likely to be more efficient than IO::Scalar. Basically, this: my @a; $AH = new IO::ScalarArray \@a; $AH->print("Hel", "lo, "); ### OO style $AH->print("world!\n"); ### ditto Or this: my @a; $AH = new IO::ScalarArray \@a; print $AH "Hel", "lo, "; ### non-OO style print $AH "world!\n"; ### ditto Causes @a to be set to the following array of 3 strings: ( "Hel" , "lo, " , "world!\n" ) See L and compare with this class. =head1 PUBLIC INTERFACE =cut use Carp; use strict; use vars qw($VERSION @ISA); use IO::Handle; # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.111"; # Inheritance: @ISA = qw(IO::Handle); require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); #============================== =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I Return a new, unattached array handle. If any arguments are given, they're sent to open(). =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = bless \do { local *FH }, $class; tie *$self, $class, $self; $self->open(@_); ### open on anonymous by default $self; } sub DESTROY { shift->close; } #------------------------------ =item open [ARRAYREF] I Open the array handle on a new array, pointed to by ARRAYREF. If no ARRAYREF is given, a "private" array is created to hold the file data. Returns the self object on success, undefined on error. =cut sub open { my ($self, $aref) = @_; ### Sanity: defined($aref) or do {my @a; $aref = \@a}; (ref($aref) eq "ARRAY") or croak "open needs a ref to a array"; ### Setup: $self->setpos([0,0]); *$self->{AR} = $aref; $self; } #------------------------------ =item opened I Is the array handle opened on something? =cut sub opened { *{shift()}->{AR}; } #------------------------------ =item close I Disassociate the array handle from its underlying array. Done automatically on destroy. =cut sub close { my $self = shift; %{*$self} = (); 1; } =back =cut #============================== =head2 Input and output =over 4 =cut #------------------------------ =item flush I No-op, provided for OO compatibility. =cut sub flush { "0 but true" } #------------------------------ =item fileno I No-op, returns undef =cut sub fileno { } #------------------------------ =item getc I Return the next character, or undef if none remain. This does a read(1), which is somewhat costly. =cut sub getc { my $buf = ''; ($_[0]->read($buf, 1) ? $buf : undef); } #------------------------------ =item getline I Return the next line, or undef on end of data. Can safely be called in an array context. Currently, lines are delimited by "\n". =cut sub getline { my $self = shift; my ($str, $line) = (undef, ''); ### Minimal impact implementation! ### We do the fast thing (no regexps) if using the ### classic input record separator. ### Case 1: $/ is undef: slurp all... if (!defined($/)) { return undef if ($self->eof); ### Get the rest of the current string, followed by remaining strings: my $ar = *$self->{AR}; my @slurp = ( substr($ar->[*$self->{Str}], *$self->{Pos}), @$ar[(1 + *$self->{Str}) .. $#$ar ] ); ### Seek to end: $self->_setpos_to_eof; return join('', @slurp); } ### Case 2: $/ is "\n": elsif ($/ eq "\012") { ### Until we hit EOF (or exited because of a found line): until ($self->eof) { ### If at end of current string, go fwd to next one (won't be EOF): if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0}; ### Get ref to current string in array, and set internal pos mark: $str = \(*$self->{AR}[*$self->{Str}]); ### get current string pos($$str) = *$self->{Pos}; ### start matching from here ### Get from here to either \n or end of string, and add to line: $$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS $line .= $1.$2; ### add it *$self->{Pos} += length($1.$2); ### move fwd by len matched return $line if $3; ### done, got line with "\n" } return ($line eq '') ? undef : $line; ### return undef if EOF } ### Case 3: $/ is ref to int. Bail out. elsif (ref($/)) { croak '$/ given as a ref to int; currently unsupported'; } ### Case 4: $/ is either "" (paragraphs) or something weird... ### Bail for now. else { croak '$/ as given is currently unsupported'; } } #------------------------------ =item getlines I Get all remaining lines. It will croak() if accidentally called in a scalar context. =cut sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); my ($line, @lines); push @lines, $line while (defined($line = $self->getline)); @lines; } #------------------------------ =item print ARGS... I Print ARGS to the underlying array. Currently, this always causes a "seek to the end of the array" and generates a new array entry. This may change in the future. =cut sub print { my $self = shift; push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data $self->_setpos_to_eof; 1; } #------------------------------ =item read BUF, NBYTES, [OFFSET]; I Read some bytes from the array. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub read { my $self = $_[0]; ### we must use $_[1] as a ref my $n = $_[2]; my $off = $_[3] || 0; ### print "getline\n"; my $justread; my $len; ($off ? substr($_[1], $off) : $_[1]) = ''; ### Stop when we have zero bytes to go, or when we hit EOF: my @got; until (!$n or $self->eof) { ### If at end of current string, go forward to next one (won't be EOF): if ($self->_eos) { ++*$self->{Str}; *$self->{Pos} = 0; } ### Get longest possible desired substring of current string: $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n); $len = length($justread); push @got, $justread; $n -= $len; *$self->{Pos} += $len; } $_[1] .= join('', @got); return length($_[1])-$off; } #------------------------------ =item write BUF, NBYTES, [OFFSET]; I Write some bytes into the array. =cut sub write { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $data = substr($_[1], $n, $off); $n = length($data); $self->print($data); return $n; } =back =cut #============================== =head2 Seeking/telling and other attributes =over 4 =cut #------------------------------ =item autoflush I No-op, provided for OO compatibility. =cut sub autoflush {} #------------------------------ =item binmode I No-op, provided for OO compatibility. =cut sub binmode {} #------------------------------ =item clearerr I Clear the error and EOF flags. A no-op. =cut sub clearerr { 1 } #------------------------------ =item eof I Are we at end of file? =cut sub eof { ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n"; ### print "SR = ", $#{*$self->{AR}}, "\n"; return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA ### ### at EOA, past EOS: ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos)); } #------------------------------ # # _eos # # I Are we at end of the CURRENT string? # sub _eos { (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char } #------------------------------ =item seek POS,WHENCE I Seek to a given position in the stream. Only a WHENCE of 0 (SEEK_SET) is supported. =cut sub seek { my ($self, $pos, $whence) = @_; ### Seek: if ($whence == 0) { $self->_seek_set($pos); } elsif ($whence == 1) { $self->_seek_cur($pos); } elsif ($whence == 2) { $self->_seek_end($pos); } else { croak "bad seek whence ($whence)" } return 1; } #------------------------------ # # _seek_set POS # # Instance method, private. # Seek to $pos relative to start: # sub _seek_set { my ($self, $pos) = @_; ### Advance through array until done: my $istr = 0; while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) { if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string! return $self->setpos([$istr, $pos]); } else { ### it's in next string $pos -= length(*$self->{AR}[$istr++]); ### move forward one string } } ### If we reached this point, pos is at or past end; zoom to EOF: return $self->_setpos_to_eof; } #------------------------------ # # _seek_cur POS # # Instance method, private. # Seek to $pos relative to current position. # sub _seek_cur { my ($self, $pos) = @_; $self->_seek_set($self->tell + $pos); } #------------------------------ # # _seek_end POS # # Instance method, private. # Seek to $pos relative to end. # We actually seek relative to beginning, which is simple. # sub _seek_end { my ($self, $pos) = @_; $self->_seek_set($self->_tell_eof + $pos); } #------------------------------ =item tell I Return the current position in the stream, as a numeric offset. =cut sub tell { my $self = shift; my $off = 0; my ($s, $str_s); for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars defined($str_s = *$self->{AR}[$s]) or $str_s = ''; ###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n"; $off += length($str_s); } ###print STDERR "COUNTING POS ($self->{Pos})\n"; return ($off += *$self->{Pos}); ### plus the final, partial one } #------------------------------ # # _tell_eof # # Instance method, private. # Get position of EOF, as a numeric offset. # This is identical to the size of the stream - 1. # sub _tell_eof { my $self = shift; my $len = 0; foreach (@{*$self->{AR}}) { $len += length($_) } $len; } #------------------------------ =item setpos POS I Seek to a given position in the array, using the opaque getpos() value. Don't expect this to be a number. =cut sub setpos { my ($self, $pos) = @_; (ref($pos) eq 'ARRAY') or die "setpos: only use a value returned by getpos!\n"; (*$self->{Str}, *$self->{Pos}) = @$pos; } #------------------------------ # # _setpos_to_eof # # Fast-forward to EOF. # sub _setpos_to_eof { my $self = shift; $self->setpos([scalar(@{*$self->{AR}}), 0]); } #------------------------------ =item getpos I Return the current position in the array, as an opaque value. Don't expect this to be a number. =cut sub getpos { [*{$_[0]}->{Str}, *{$_[0]}->{Pos}]; } #------------------------------ =item aref I Return a reference to the underlying array. =cut sub aref { *{shift()}->{AR}; } =back =cut #------------------------------ # Tied handle methods... #------------------------------ ### Conventional tiehandle interface: sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray")) ? $_[1] : shift->new(@_) } sub GETC { shift->getc(@_) } sub PRINT { shift->print(@_) } sub PRINTF { shift->print(sprintf(shift, @_)) } sub READ { shift->read(@_) } sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } sub WRITE { shift->write(@_); } sub CLOSE { shift->close(@_); } sub SEEK { shift->seek(@_); } sub TELL { shift->tell(@_); } sub EOF { shift->eof(@_); } sub BINMODE { 1; } #------------------------------------------------------------ 1; __END__ # SOME PRIVATE NOTES: # # * The "current position" is the position before the next # character to be read/written. # # * Str gives the string index of the current position, 0-based # # * Pos gives the offset within AR[Str], 0-based. # # * Inital pos is [0,0]. After print("Hello"), it is [1,0]. =head1 WARNINGS Perl's TIEHANDLE spec was incomplete prior to 5.005_57; it was missing support for C, C, and C. Attempting to use these functions with an IO::ScalarArray will not work prior to 5.005_57. IO::ScalarArray will not have the relevant methods invoked; and even worse, this kind of bug can lie dormant for a while. If you turn warnings on (via C<$^W> or C), and you see something like this... attempt to seek on unopened filehandle ...then you are probably trying to use one of these functions on an IO::ScalarArray with an old Perl. The remedy is to simply use the OO version; e.g.: $AH->seek(0,0); ### GOOD: will work on any 5.005 seek($AH,0,0); ### WARNING: will only work on 5.005_57 and beyond =head1 VERSION $Id: ScalarArray.pm,v 1.7 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHOR =head2 Primary Maintainer Dianne Skoll (F). =head2 Principal author Eryq (F). President, ZeeGee Software Inc (F). =head2 Other contributors Thanks to the following individuals for their invaluable contributions (if I've forgotten or misspelled your name, please email me!): I for suggesting C. I for suggesting C. I for his offset-using read() and write() implementations. I for the IO::Handle inheritance and automatic tie-ing. =cut #------------------------------ 1;