diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..c3cfc23 --- /dev/null +++ b/COPYING @@ -0,0 +1,41 @@ +The "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 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..6298fe4 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,24 @@ +COPYING +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) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..a49228b --- /dev/null +++ b/META.yml @@ -0,0 +1,20 @@ +--- #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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100755 index 0000000..629288b --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,21 @@ +#!/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', + } + ); + diff --git a/README b/README new file mode 100644 index 0000000..903be74 --- /dev/null +++ b/README @@ -0,0 +1,315 @@ +NAME + 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. + diff --git a/contrib/Clever.pm b/contrib/Clever.pm new file mode 100644 index 0000000..084a900 --- /dev/null +++ b/contrib/Clever.pm @@ -0,0 +1,36 @@ +package 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; diff --git a/examples/IO_Scalar_synopsis b/examples/IO_Scalar_synopsis new file mode 100755 index 0000000..7b05d50 --- /dev/null +++ b/examples/IO_Scalar_synopsis @@ -0,0 +1,112 @@ +#!/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; diff --git a/lib/IO/AtomicFile.pm b/lib/IO/AtomicFile.pm new file mode 100644 index 0000000..1a6f33e --- /dev/null +++ b/lib/IO/AtomicFile.pm @@ -0,0 +1,199 @@ +package 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 diff --git a/lib/IO/InnerFile.pm b/lib/IO/InnerFile.pm new file mode 100644 index 0000000..230af3d --- /dev/null +++ b/lib/IO/InnerFile.pm @@ -0,0 +1,301 @@ +package 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 + + diff --git a/lib/IO/Lines.pm b/lib/IO/Lines.pm new file mode 100644 index 0000000..3471d3a --- /dev/null +++ b/lib/IO/Lines.pm @@ -0,0 +1,184 @@ +package 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 + diff --git a/lib/IO/Scalar.pm b/lib/IO/Scalar.pm new file mode 100644 index 0000000..262fb7e --- /dev/null +++ b/lib/IO/Scalar.pm @@ -0,0 +1,790 @@ +package 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 + diff --git a/lib/IO/ScalarArray.pm b/lib/IO/ScalarArray.pm new file mode 100644 index 0000000..1439976 --- /dev/null +++ b/lib/IO/ScalarArray.pm @@ -0,0 +1,803 @@ +package 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; + diff --git a/lib/IO/Stringy.pm b/lib/IO/Stringy.pm new file mode 100644 index 0000000..c97c1d1 --- /dev/null +++ b/lib/IO/Stringy.pm @@ -0,0 +1,446 @@ +package 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 diff --git a/lib/IO/Wrap.pm b/lib/IO/Wrap.pm new file mode 100644 index 0000000..ad64f12 --- /dev/null +++ b/lib/IO/Wrap.pm @@ -0,0 +1,228 @@ +package 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 + diff --git a/lib/IO/WrapTie.pm b/lib/IO/WrapTie.pm new file mode 100644 index 0000000..a15ada3 --- /dev/null +++ b/lib/IO/WrapTie.pm @@ -0,0 +1,491 @@ +# 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 + diff --git a/t/Common.pm b/t/Common.pm new file mode 100644 index 0000000..f58bba7 --- /dev/null +++ b/t/Common.pm @@ -0,0 +1,365 @@ +package 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; + + diff --git a/t/ExtUtils/TBone.pm b/t/ExtUtils/TBone.pm new file mode 100644 index 0000000..93bd024 --- /dev/null +++ b/t/ExtUtils/TBone.pm @@ -0,0 +1,612 @@ +package 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; + diff --git a/t/IO_InnerFile.t b/t/IO_InnerFile.t new file mode 100644 index 0000000..31d6ea6 --- /dev/null +++ b/t/IO_InnerFile.t @@ -0,0 +1,75 @@ +#!/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'); + + + + + + + + diff --git a/t/IO_Lines.t b/t/IO_Lines.t new file mode 100644 index 0000000..c436f48 --- /dev/null +++ b/t/IO_Lines.t @@ -0,0 +1,45 @@ +#!/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; + + diff --git a/t/IO_Scalar.t b/t/IO_Scalar.t new file mode 100644 index 0000000..69c1768 --- /dev/null +++ b/t/IO_Scalar.t @@ -0,0 +1,51 @@ +#!/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; + + diff --git a/t/IO_ScalarArray.t b/t/IO_ScalarArray.t new file mode 100644 index 0000000..34a5401 --- /dev/null +++ b/t/IO_ScalarArray.t @@ -0,0 +1,52 @@ +#!/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; + + + + + + + + diff --git a/t/IO_WrapTie.t b/t/IO_WrapTie.t new file mode 100644 index 0000000..2817ca4 --- /dev/null +++ b/t/IO_WrapTie.t @@ -0,0 +1,66 @@ +#!/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; + + diff --git a/t/simple.t b/t/simple.t new file mode 100644 index 0000000..5f7d2fe --- /dev/null +++ b/t/simple.t @@ -0,0 +1,63 @@ +#!/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; + diff --git a/t/two.t b/t/two.t new file mode 100644 index 0000000..7011f29 --- /dev/null +++ b/t/two.t @@ -0,0 +1,53 @@ +#!/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; +