IO-Handle-Util-0.01/000755 000765 000024 00000000000 11261105410 015522 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/lib/000755 000765 000024 00000000000 11261105410 016270 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/Makefile.PL000644 000765 000024 00000000657 11260665741 017525 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl -w use strict; use ExtUtils::MakeMaker; require 5.008; WriteMakefile( NAME => 'IO::Handle::Util', VERSION_FROM => 'lib/IO/Handle/Util.pm', INSTALLDIRS => 'site', SIGN => 1, PL_FILES => { }, PREREQ_PM => { 'Scalar::Util' => 0, 'Sub::Exporter' => 0, 'asa' => 0, 'parent' => 0, 'IO::String' => 0, 'Test::use::ok' => 0, 'Test::More' => 0.88, }, ); IO-Handle-Util-0.01/MANIFEST000644 000765 000024 00000000701 11261105410 016651 0ustar00nothingmuchstaff000000 000000 lib/IO/Handle/Iterator.pm lib/IO/Handle/Prototype.pm lib/IO/Handle/Prototype/Fallback.pm lib/IO/Handle/Util.pm lib/IO/Handle/Util/Overloading.pm lib/IO/Handle/Util/Tie.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP t/basic.t t/iterator.t t/prototype.t t/prototype_fallback.t META.yml Module meta-data (added by MakeMaker) SIGNATURE Public-key signature (added by MakeMaker) IO-Handle-Util-0.01/MANIFEST.SKIP000644 000765 000024 00000001143 11260510367 017431 0ustar00nothingmuchstaff000000 000000 # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b ### DEFAULT MANIFEST.SKIP ENDS HERE #### \.DS_Store$ \.sw.$ (\w+-)*(\w+)-\d\.\d+(?:\.tar\.gz)?$ \.t\.log$ \.prove$ # XS shit \.(?:bs|c|o)$ \.gitignore$ IO-Handle-Util-0.01/META.yml000644 000765 000024 00000001164 11261105410 016775 0ustar00nothingmuchstaff000000 000000 --- #YAML:1.0 name: IO-Handle-Util version: 0.01 abstract: ~ author: [] license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: asa: 0 IO::String: 0 parent: 0 Scalar::Util: 0 Sub::Exporter: 0 Test::More: 0.88 Test::use::ok: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.55_02 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 IO-Handle-Util-0.01/SIGNATURE000644 000765 000024 00000003170 11261105410 017007 0ustar00nothingmuchstaff000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 aaaa10558a4bf9245afffe7252a7bd2df17ee351 MANIFEST SHA1 606bd6424682249397d63caf905f651178a4d6cc MANIFEST.SKIP SHA1 4b868be205250455bb80599d1cf2659705132198 META.yml SHA1 89ef726b73f8dadfe4d973bdca91d337c53eae3a Makefile.PL SHA1 4caf59bf245bea3934caa009358802ad62d3afe6 lib/IO/Handle/Iterator.pm SHA1 18e6eff724ca079cc6d760c76a6210f91984bd4a lib/IO/Handle/Prototype.pm SHA1 a5622946e85d76a1b61a26fc23196a52e278453b lib/IO/Handle/Prototype/Fallback.pm SHA1 3a52c91b6022a6650969e265b917a7aad7a30d32 lib/IO/Handle/Util.pm SHA1 2e938cbfcd28e32639e912e268f0f204999d73aa lib/IO/Handle/Util/Overloading.pm SHA1 d3237362fdaecbaa1e645195a0e6e9d989a08454 lib/IO/Handle/Util/Tie.pm SHA1 8bf8a1774221ce60241b1d93aca0caa0a7313668 t/basic.t SHA1 e35f6553fdfc12bdf3453d6670f2a08382e97aab t/iterator.t SHA1 fa9d2e98d8b6d92f1370b71aadd2c5f7fb127acd t/prototype.t SHA1 8c27be9cd04be85d1be0fcbe7b23cda0e0701ae6 t/prototype_fallback.t -----BEGIN PGP SIGNATURE----- Version: GnuPG/MacGPG2 v2.0.12 (Darwin) iEYEARECAAYFAkrEiwgACgkQVCwRwOvSdBgkuwCfdZ1Cacgla+DssffTrIOGz0NS wM8Anibcz5Kn0RisD2Gee0DFTw/HmqB9 =RbEQ -----END PGP SIGNATURE----- IO-Handle-Util-0.01/t/000755 000765 000024 00000000000 11261105410 015765 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/t/basic.t000644 000765 000024 00000014656 11260512040 017247 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use ok 'IO::Handle::Util' => qw(:all); use Scalar::Util qw(blessed); ok( IO::Handle->can("print"), "IO::Handle loaded" ); ok( FileHandle->can("tell"), "FileHandle loaded" ); ok( !blessed(*STDIN), "STDIN not blessed" ); eval { STDIN->tell }; is( $@, '', "but responds to methods" ); sub new_fh { my ( $mode, $string ) = @_; open my $fh, $mode, \$string; return wantarray ? ( $fh, \$string ) : $fh; } { my ( $fh, $buf ) = new_fh ">", ""; my $sub = io_to_write_cb($fh); is( ref $sub, 'CODE', "io_to_write_cb makes a code ref" ); $sub->("foo\n"); is( $$buf, "foo\n", "first invocation" ); $sub->("blah\n"); is( $$buf, "foo\nblah\n", "second invocation" ); } { my $str = ''; my $sub = io_to_write_cb(\$str); $sub->("foo"); is($str, "foo", "coerced from scalar ref"); local $\ = "\n"; local $, = ", "; $sub->(qw(foo bar)); is( $str, "foofoobar", "immune to ORS and OFS" ); } { my $fh = new_fh "<", "foo\nbar\n"; is( ref($fh), 'GLOB', "PerlIO handle is a glob" ); is( io_to_glob($fh), $fh, 'io_to_glob isa passthrough' ); } { my $fh = io_from_array [qw(foo bar)]; isnt( ref($fh), 'GLOB' ); my $glob = io_to_glob($fh); is( ref($glob), "GLOB", "io_to_glob" ); isa_ok( tied(*$glob), "IO::Handle::Util::Tie", "tied" ); is_deeply( [ <$glob> ], [qw(foo bar)], "readline builtin", ); } { my $fh = io_from_array [qw(foo bar)]; isnt( ref($fh), 'GLOB' ); is_deeply( [ <$fh> ], [qw(foo bar)], "readline builtin through overloading", ); } { my $fh = new_fh "<", "foo\nbar\n"; my $sub = io_to_read_cb($fh); is( ref $sub, 'CODE', "io_to_read_cb makes a code ref" ); is( $sub->(), "foo\n", "like getline" ); is( $sub->(), "bar\n", "like getline" ); is( $sub->(), undef, "like getline" ); } { my $fh = new_fh "<", "foo\nbar\nbaz\ngorch"; local $/ = "a"; is( $fh->getline, "foo\nba", "getline with IRS" ); is( io_to_string($fh), "r\nbaz\ngorch", "slurp with io_to_string" ); is( io_to_string($fh), "", "IO depleted" ); is( io_to_string("foo"), "foo", "strings pass through" ); } { my $fh = new_fh "<", "foo\nbar\nbaz\ngorch"; is_deeply( io_to_array($fh), [ "foo\n", "bar\n", "baz\n", "gorch", ], "io_to_array", ); is_deeply( [ io_to_list(new_fh "<", "foo\nbar\nbaz\n") ], [ "foo\n", "bar\n", "baz\n" ], "io_to_list", ); is_deeply( io_to_array([qw(foo bar)]), [qw(foo bar)], "passthrough", ); is_deeply( [io_to_list([qw(foo bar)])], [qw(foo bar)], "passthrough list context", ); } sub io_ok ($;$) { my ( $fh, $desc ) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; ok($fh, $desc || "got IO" ); if ( blessed($fh) ) { can_ok( $fh, "getline", "print" ); } else { ok( ref($fh) eq 'GLOB' && *{$fh}{IO}, "unblessed GLOB with IO" ); } return $fh; } { my $str = "foo\nbar\n"; foreach my $arg ( $str, \$str ) { io_ok( my $fh = io_from_any($arg), "IO from " . lc(ref(\$arg)) ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "foo\n", "getline" ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "bar\n", "getline" ); ok( $fh->eof, "eof" ); is( $fh->getline, undef, "getline" ); ok( $fh->eof, "eof" ); } } { io_ok( my $fh = io_from_any([qw(foo bar gorch)]), "from array"); isa_ok( $fh, "IO::Handle::Iterator" ); is( $fh->getline, "foo", "fake getline" ); is_deeply( [ $fh->getlines ], [ qw(bar gorch) ], "fake lines preserved", ); } { io_ok( my $fh = io_from_any([qw(foo bar gorch)]), "from array"); isa_ok( $fh, "IO::Handle::Iterator" ); is( $fh->getline, "foo", "fake getline" ); is_deeply( [ <$fh> ], [ qw(bar gorch) ], "getlines via readline operator", ); } { my $str_fh = IO::String->new("foo"); can_ok( $str_fh, qw(getline print) ); io_ok( my $fh = io_from_any($str_fh), "from IO::String" ); is( $fh, $str_fh, "passthrough" ); } { my $perlio_string = new_fh "<", "foo"; ok( !blessed($perlio_string), "PerlIO string handle not blessed" ); io_ok( my $fh = io_from_any($perlio_string), "from PerlIO string" ); is( $fh, $perlio_string, "passthrough" ); } { my $fh = io_from_thunk sub { return "foo\nbar\n"; }; io_ok( $fh, "from thunk" ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "foo\nbar\n", "getline" ); is( $fh->getline, undef, "getline" ); ok( $fh->eof, "eof" ); } { my $fh = io_from_thunk sub { return qw( foo bar ); }; io_ok( $fh, "from list thunk" ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "foo", "getline" ); is( $fh->getline, "bar", "getline" ); is( $fh->getline, undef, "getline" ); ok( $fh->eof, "eof" ); } { my @array = qw(foo bar); my $fh = io_from_getline sub { if ( @array ) { return shift @array; } else { return; } }; io_ok( $fh, "from getline callback" ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "foo", "getline" ); is( $fh->getline, "bar", "getline" ); is( $fh->getline, undef, "getline" ); ok( $fh->eof, "eof" ); } { my $buf = ''; my $fh = io_from_write_cb sub { $buf .= $_[0]; }; io_ok( $fh, "write cb" ); $fh->print("foo"); is( $buf, "foo", "print" ); $buf = ''; local $\ = "bar"; $fh->print("baz"); is( $buf, 'bazbar', "respects ORS" ); $buf = ''; $fh->say("baz"); is( $buf, "baz\n", "say localizes ORS" ); $buf = ''; local $, = ", "; $\ = "\n"; $fh->print(qw(foo bar gorch)); is( $buf, "foo, bar, gorch\n", "respects OFS" ); $buf = ''; $fh->write("foobar", 4, 2); is( $buf, 'obar', "handles offset/length in write" ); } foreach my $fake ( IO::String->new("blah"), IO::String->new(do { my $x = "blah"; \$x }), scalar(new_fh("<", "hello")), scalar(new_fh(">", "hello")), ) { ok( !is_real_fh($fake), "not a real handle ($fake)" ); } { open my $fh, "<", __FILE__ or die $!; ok( is_real_fh($fh), "real fh" ); } done_testing; # ex: set sw=4 et: IO-Handle-Util-0.01/t/iterator.t000644 000765 000024 00000002144 11260512333 020011 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use ok 'IO::Handle::Iterator'; use ok 'IO::Handle::Util' => qw(io_from_array); my $fh = &io_from_array([qw(foo bar gorch baz quxx la la dong)]); isa_ok( $fh, "IO::Handle::Iterator" ); isa_ok( $fh, "IO::Handle" ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "foo", "getline" ); ok( !$fh->eof, "not eof" ); is( $fh->read(my $buf, 2), 2, "read" ); is( $buf, "ba", "read buffer" ); ok( !$fh->eof, "not eof" ); is( $fh->read($buf, 2), 2, "read" ); is( $buf, "rg", "read buffer" ); ok( !$fh->eof, "not eof" ); is( $fh->getline, "orch", "getline" ); is( $fh->getline, "baz", "getline" ); ok( !$fh->eof, "not eof" ); is( $fh->read($buf, 7), 7, "read" ); is( $buf, "quxxlal", "read buffer" ); ok( !$fh->eof, "not eof" ); is( $fh->getc, 'a', "getc" ); ok( !$fh->eof, "not eof" ); $fh->ungetc(ord('z')); ok( !$fh->eof, "not eof" ); is( $fh->getc(), 'z', "ungetc" ); ok( !$fh->eof, "not eof" ); is( $fh->read($buf, 7, length($buf) + 1), 4, "read" ); is( $buf, "quxxlal\0dong", "read buffer" ); ok( $fh->eof, "eof" ); done_testing; # ex: set sw=4 et: IO-Handle-Util-0.01/t/prototype.t000644 000765 000024 00000001127 11257164026 020235 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use ok 'IO::Handle::Prototype'; my $buf = ''; my $fh = IO::Handle::Prototype->new( print => sub { $buf .= $_[1]; }, ); isa_ok( $fh, "IO::Handle::Prototype" ); isa_ok( $fh, "IO::Handle" ); can_ok( $fh, qw(getline read print write) ); eval { $fh->print("foo") }; is( $@, '', "no error" ); is( $buf, "foo", "callback worked" ); eval { $fh->getline }; like( $@, qr/getline/, "dies on missing callback" ); eval { $fh->write("foo") }; like( $@, qr/write/, "dies on missing callback" ); done_testing; # ex: set sw=4 et: IO-Handle-Util-0.01/t/prototype_fallback.t000644 000765 000024 00000013426 11260503224 022050 0ustar00nothingmuchstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use ok 'IO::Handle::Prototype::Fallback'; sub check_write_fh { my ( $fh, $buf ) = @_; isa_ok( $fh, "IO::Handle::Prototype::Fallback" ); isa_ok( $fh, "IO::Handle::Prototype" ); isa_ok( $fh, "IO::Handle" ); can_ok( $fh, qw(getline read print write) ); eval { $fh->getline }; like( $@, qr/getline/, "dies on missing callback" ); eval { $fh->getc }; like( $@, qr/getc/, "dies on missing callback" ); eval { $fh->read }; like( $@, qr/read/, "dies on missing callback" ); eval { $fh->print("foo") }; is( $@, '', "no error" ); is( $$buf, "foo", "print worked" ); local $\ = "\n"; local $, = " "; eval { $fh->print("foo", "bar") }; is( $@, '', "no error" ); is( $$buf, "foofoo bar\n", "print worked" ); eval { $fh->write("foo") }; is( $@, '', "no error" ); is( $$buf, "foofoo bar\nfoo", "write worked" ); eval { $fh->syswrite("foo", 1, 1) }; is( $@, '', "no error" ); is( $$buf, "foofoo bar\nfooo", "write worked" ); eval { $fh->printf("%d hens", 5) }; is( $@, '', "no error" ); is( $$buf, "foofoo bar\nfooo5 hens\n", "printf worked" ); $\ = "%%"; eval { $fh->print("foo") }; is( $@, '', "no error" ); is( $$buf, "foofoo bar\nfooo5 hens\nfoo%%", "print worked" ); eval { $fh->say("Hello, World!") }; is( $@, '', "no error" ); is( $$buf, "foofoo bar\nfooo5 hens\nfoo%%Hello, World!\n", "say worked" ); } { my $buf = ''; my $fh = IO::Handle::Prototype::Fallback->new( print => sub { my ( $self, @stuff ) = @_; no warnings 'uninitialized'; $buf .= join($,, @stuff) . $\; }, ); check_write_fh($fh, \$buf); } foreach my $write (qw(write syswrite)) { my $buf = ''; my $fh = IO::Handle::Prototype::Fallback->new( $write => sub { my ( $self, $str, $length, $offset ) = @_; $buf .= substr($str, $offset || 0, $length || length($str)); }, ); check_write_fh($fh, \$buf); } { my $buf = ''; my $fh = IO::Handle::Prototype::Fallback->new( __write => sub { $buf .= $_[1] }, ); } my $str = <<'EOF'; OH HAI I am a file with several lines it's fun to read me using methods EOF sub check_read_fh { my $make = shift; { my $fh = $make->($str); isa_ok( $fh, "IO::Handle::Prototype::Fallback" ); isa_ok( $fh, "IO::Handle::Prototype" ); isa_ok( $fh, "IO::Handle" ); can_ok( $fh, qw(getline read print write) ); eval { $fh->print("foo") }; like( $@, qr/print/, "dies on missing callback" ); eval { $fh->say("foo") }; like( $@, qr/say/, "dies on missing callback" ); local $/ = "\n"; ok( !$fh->eof, "not eof" ); my $line = <$fh>; is( $line, "OH HAI\n", "getline" ); is( $fh->read(my $buf, 4), 4, "read 4 chars" ); is($buf, "I am", "read with length"); is( $fh->read($buf, 4, 4), 4, "read 4 more chars" ); is( $buf, "I am a f", "read with offset" ); ok( !$fh->eof, "not eof" ); $buf .= $fh->getline; is( $buf, "I am a file\n", "getline interleaved with read" ); $/ = \10; $buf = $fh->getline; is( length($buf), ${ $/ }, "getline with ref in IRS" ); is( $buf, "with\nsever", "correct data" ); is( $fh->getc(), 'a', "getc" ); $fh->ungetc(ord('%')); is( $fh->getc(), '%', 'ungetc' ); $buf .= 'a'; $/ = "\n"; $buf .= $fh->getline; is( $buf, "with\nseveral lines\n", "with undef IRS" ); ok( !$fh->eof, "not eof" ); my @lines = <$fh>; ok( $fh->eof, "eof reached" ); is_deeply( \@lines, [ "\n", "it's fun to read me\n", "\n", "using\n", "methods\n", ], "getlines", ); is( $fh->getline, undef, "getline at EOF" ); } { my $fh = $make->(join "\n", qw(foo bar gorch baz)); ok( !$fh->eof, "not eof" ); is( $fh->getline, "foo\n", "getline" ); ok( !$fh->eof, "not eof" ); local $/; is( $fh->getline, "bar\ngorch\nbaz", "slurp" ); ok( $fh->eof, "eof" ); } { my $fh = $make->("foobar"); ok( !$fh->eof, "not eof" ); is( $fh->read(my $buf, 4), 4, "read" ); is( $buf, "foob" ); ok( !$fh->eof, "not eof" ); is( $fh->read($buf, 4), 2, "read to EOF" ); is( $buf, 'ar' ); ok( $fh->eof, "eof" ); } } foreach my $cb ( qw(__read getline) ) { check_read_fh(sub { my $str = shift; IO::Handle::Prototype::Fallback->new( $cb => sub { if ( defined $str ) { my $ret = $str; undef $str; return $ret; } else { return; } }, ); }); check_read_fh(sub { my $str = shift; my @array = split //, $str; IO::Handle::Prototype::Fallback->new( $cb => sub { if ( @array ) { return shift @array; } else { return; } }, ); }); } check_read_fh(sub { my $str = shift; IO::Handle::Prototype::Fallback->new( read => sub { my ( $self, undef, $length ) = @_; if ( length($str) > $length ) { $_[1] = substr($str, 0, $length, ''); } else { $_[1] = $str; $str = ''; } return length($_[1]); }, ); }); done_testing; # ex: set sw=4 et: IO-Handle-Util-0.01/lib/IO/000755 000765 000024 00000000000 11261105410 016577 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/lib/IO/Handle/000755 000765 000024 00000000000 11261105410 017772 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/lib/IO/Handle/Iterator.pm000644 000765 000024 00000011143 11260512462 022131 0ustar00nothingmuchstaff000000 000000 package IO::Handle::Iterator; use strict; use warnings; use Carp (); use parent qw(IO::Handle::Prototype); # error, clearerr, new_from_fd, fdopen sub new { my ( $class, $cb ) = @_; bless { cb => $cb, }, $class; } sub getline { shift->_cb } sub _cb { my $self = shift; if ( my $cb = $self->{cb} ) { if ( defined(my $next = $cb->()) ) { return $next; } else { $self->close; } } return; } sub _rebless_and { my $self = shift; my $method = shift; bless $self, "IO::Handle::Iterator::Buffered"; $self->$method(@_); } sub read { shift->_rebless_and( read => @_ ) } sub sysread { shift->_rebless_and( sysread => @_ ) } sub getc { shift->_rebless_and( getc => @_ ) } sub ungetc { shift->_rebless_and( ungetc => @_ ) } sub open { Carp::croak("Can't open an iterator") } sub print { Carp::croak("Can't print to iterator") } sub printflush { Carp::croak("Can't print to iterator") } sub printf { Carp::croak("Can't print to iterator") } sub say { Carp::croak("Can't print to iterator") } sub write { Carp::croak("Can't write to iterator") } sub syswrite { Carp::croak("Can't write to iterator") } sub format_write { Carp::croak("Can't write to iterator") } sub ioctl { Carp::croak("Can't ioctl on iterator") } sub fcntl { Carp::croak("Can't fcntl on iterator") } sub truncate { Carp::croak("Can't truncate iterator") } sub sync { Carp::croak("Can't sync an iterator") } sub flush { Carp::croak("Can't flush an iterator") } sub autoflush { 1 } sub opened { 1 } sub blocking { my ( $self, @args ) = @_; Carp::croak("Can't set blocking mode on iterator") if @args; return 1; } sub stat { return undef } sub fileno { return undef } sub close { delete $_[0]{cb} } sub eof { not exists $_[0]{cb} } sub getlines { my $self = shift; my @accum; while ( defined(my $next = $self->getline) ) { push @accum, $next; } return @accum; } package IO::Handle::Iterator::Buffered; # FIXME IO::Handle::BufferMixin? use parent qw(IO::Handle::Iterator); no warnings 'uninitialized'; sub eof { my $self = shift; length($self->{buf}) == 0 and $self->SUPER::eof; } sub getc { shift->read(my $c, 1); return $c; } sub ungetc { my ( $self, $ord ) = @_; substr($self->{buf}, 0, 0, chr($ord)); # yuck return; } sub sysread { shift->read(@_) } sub read { my ( $self, undef, $length, $offset ) = @_; return 0 if $self->eof; if ( $offset and length($_[1]) < $offset ) { $_[1] .= "\0" x ( $offset - length($_[1]) ); } while (length($self->{buf}) < $length) { if ( defined(my $next = $self->_cb) ) { $self->{buf} .= $next; } else { # data ended but still under $length, return all that remains and # empty the buffer my $ret = length($self->{buf}); if ( $offset ) { substr($_[1], $offset) = delete $self->{buf}; } else { $_[1] = delete $self->{buf}; } return $ret; } } my $read; if ( $length > length($self->{buf}) ) { $read = delete $self->{buf}; } else { $read = substr($self->{buf}, 0, $length, ''); } if ( $offset ) { substr($_[1], $offset) = $read; } else { $_[1] = $read; } return length($read); } sub getline { my $self = shift; my $line = delete $self->{buf}; bless $self, 'IO::Handle::Iterator'; return $line; } __PACKAGE__ # ex: set sw=4 et: __END__ =head1 NAME IO::Handle::Iterator - Iterator based read handle =head1 SYNOPSIS IO::Handle::Iterator->new(sub { return $next_line; # or undef on eof }); =head1 DESCRIPTION This class lets you define a read handle with a few fallback methods (like C) using a single callback that behaves like C. This is similar but much simpler than: IO::Handle::Prototype::Fallback->new( __read => sub { ... }, ); The reason being that the L implementation will try its very best to behave correctly (i.e. respect the value of C<$/>), whereas this implementation assumes it's fine to return things that aren't exactly lines from C, so the values are just passed through. =head1 READ BUFFERING When a method that requires buffering is invoked the handle is reblessed to a subclass which handles buffering. Calling C again on this object will return the value of the buffer and return to the normal iterator class. IO-Handle-Util-0.01/lib/IO/Handle/Prototype/000755 000765 000024 00000000000 11261105410 021777 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/lib/IO/Handle/Prototype.pm000644 000765 000024 00000003146 11260506026 022350 0ustar00nothingmuchstaff000000 000000 package IO::Handle::Prototype; use strict; use warnings; use Carp (); use parent qw(IO::Handle::Util::Overloading); sub new { my ( $class, @args ) = @_; my $cb = @args == 1 ? $args[0] : {@args}; bless { cb => $cb, }, $class; } sub _cb { my $self = shift; my $name = shift; if ( my $cb = $self->{cb}{$name} ) { return $self->$cb(@_); } else { Carp::croak("No implementation of '$name' provided for $self"); } } sub open { shift->_cb(open => @_) } sub getline { shift->_cb(getline => @_) } sub getlines { shift->_cb(getlines => @_) } sub read { shift->_cb(read => @_) } sub sysread { shift->_cb(sysread => @_) } sub getc { shift->_cb(getc => @_) } sub ungetc { shift->_cb(ungetc => @_) } sub say { shift->_cb(say => @_) } sub print { shift->_cb(print => @_) } sub printf { shift->_cb(printf => @_) } sub format_write { shift->_cb(format_write => @_) } sub write { shift->_cb(write => @_) } sub syswrite { shift->_cb(syswrite => @_) } sub ioctl { shift->_cb(ioctl => @_) } sub fcntl { shift->_cb(fcntl => @_) } sub truncate { shift->_cb(truncate => @_) } sub stat { shift->_cb(stat => @_) } sub fileno { shift->_cb(fileno => @_) } sub eof { shift->_cb(eof => @_) } sub close { shift->_cb(close => @_) } __PACKAGE__ # ex: set sw=4 et: __END__ =pod =head1 NAME IO::Handle::Prototype - base class for callback based handles. =head1 SYNOPSIS my $fh = IO::Handle::Prototype->new( getline => sub { my $fh = shift; ... }, ); =head1 DESCRIPTION You probably want L instead. =cut IO-Handle-Util-0.01/lib/IO/Handle/Util/000755 000765 000024 00000000000 11261105410 020707 5ustar00nothingmuchstaff000000 000000 IO-Handle-Util-0.01/lib/IO/Handle/Util.pm000644 000765 000024 00000031615 11261105363 021262 0ustar00nothingmuchstaff000000 000000 package IO::Handle::Util; use strict; use warnings; our $VERSION = "0.01"; $VERSION = eval $VERSION; use warnings::register; use Scalar::Util (); # we use this to create errors #use autodie (); # perl blesses IO objects into these namespaces, make sure they are loaded use IO::Handle (); use FileHandle (); # fake handle types #use IO::String (); #use IO::Handle::Iterator (); #use IO::Handle::Prototype::Fallback (); use Sub::Exporter -setup => { exports => [qw( io_to_write_cb io_to_read_cb io_to_string io_to_array io_to_list io_to_glob io_from_any io_from_ref io_from_string io_from_object io_from_array io_from_scalar_ref io_from_thunk io_from_getline io_from_write_cb io_prototype is_real_fh )], groups => { io_to => [qw( io_to_write_cb io_to_read_cb io_to_string io_to_array io_to_list io_to_glob )], io_from => [qw( io_from_any io_from_ref io_from_string io_from_object io_from_array io_from_scalar_ref io_from_thunk io_from_getline io_from_write_cb )], coercion => [qw( :io_to :io_from )], misc => [qw( io_prototype is_real_fh )], }, }; sub io_to_write_cb ($) { my $fh = io_from_any(shift); return sub { local $,; local $\; $fh->print(@_) or do { my $e = $!; require autodie; die autodie::exception->new( function => q{CORE::print}, args => [@_], message => "\$E", errno => $e, ); } } } sub io_to_read_cb ($) { my $fh = io_from_any(shift); return sub { scalar $fh->getline() }; } sub io_to_string ($) { my $thing = shift; if ( defined $thing and not ref $thing ) { return $thing; } else { my $fh = io_from_any($thing); # list context is in case ->getline ignores $/, # which is likely the case with ::Iterator local $/; return join "", <$fh>; } } sub io_to_list ($) { my $thing = shift; warnings::warnif(__PACKAGE__, "io_to_list not invoked in list context") unless wantarray; if ( ref $thing eq 'ARRAY' ) { return @$thing; } else { my $fh = io_from_any($thing); return <$fh>; } } sub io_to_array ($) { my $thing = shift; if ( ref $thing eq 'ARRAY' ) { return $thing; } else { my $fh = io_from_any($thing); return [ <$fh> ]; } } sub io_to_glob { my $thing = shift; my $fh = io_from_any($thing); if ( ref($fh) eq 'GLOB' or ref($fh) eq 'IO::Handle' ) { return $fh; } else { # wrap in a tied handle my $glob = Symbol::gensym(); require IO::Handle::Util::Tie; tie *$glob, 'IO::Handle::Util::Tie', $fh; return $glob; } } sub io_from_any ($) { my $thing = shift; if ( ref $thing ) { return io_from_ref($thing); } else { return io_from_string($thing); } } sub io_from_ref ($) { my $ref = shift; if ( Scalar::Util::blessed($ref) ) { return io_from_object($ref); } elsif ( ref $ref eq 'GLOB' and *{$ref}{IO}) { # once IO::Handle is required, entersub DWIMs method invoked on globs # there is no need to bless or IO::Wrap if there's a valid IO slot return $ref; } elsif ( ref $ref eq 'ARRAY' ) { return io_from_array($ref); } elsif ( ref $ref eq 'SCALAR' ) { return io_from_scalar_ref($ref); } elsif ( ref $ref eq 'CODE' ) { Carp::croak("Coercing an IO object from a coderef is ambiguous. Please use io_from_thunk, io_from_getline or io_from_write_cb directly."); } else { Carp::croak("Don't know how to make an IO from $ref"); } } sub io_from_object ($) { my $obj = shift; if ( $obj->isa("IO::Handle") or $obj->can("getline") && $obj->can("print") ) { return $obj; } elsif ( $obj->isa("Path::Class::File") ) { return $obj->openr; # safe default or open for rw? } else { # FIXME URI? IO::File? IO::Scalar, IO::String etc? make sure they all pass Carp::croak("Object does not seem to be an IO::Handle lookalike"); } } sub io_from_string ($) { my $string = shift; # make sure it's a copy, IO::String will use \$_[0] require IO::String; return IO::String->new($string); } sub io_from_array ($) { my $array = shift; my @array = @$array; require IO::Handle::Iterator; # IO::Lines/IO::ScalarArray is part of IO::stringy which is considered bad. IO::Handle::Iterator->new(sub { if ( @array ) { return shift @array; } else { return; } }); } sub io_from_scalar_ref ($) { my $ref = shift; require IO::String; return IO::String->new($ref); } sub io_from_thunk ($) { my $thunk = shift; my @lines; require IO::Handle::Iterator; return IO::Handle::Iterator->new(sub { if ( $thunk ) { @lines = $thunk->(); undef $thunk; } if ( @lines ) { return shift @lines; } else { return; } }); } sub io_from_getline ($) { my $cb = shift; require IO::Handle::Iterator; return IO::Handle::Iterator->new($cb); } sub io_from_write_cb ($) { my $cb = shift; io_prototype( __write => sub { local $,; local $\; $cb->($_[1]); } ); } sub io_prototype { require IO::Handle::Prototype::Fallback; IO::Handle::Prototype::Fallback->new(@_); } # returns true if the handle is (hopefully) suitable for passing to things that # want to do non method operations on it, including operations that need a # proper file descriptor sub is_real_fh ($) { my $fh = shift; my $reftype = Scalar::Util::reftype($fh); if ( $reftype eq 'IO' or $reftype eq 'GLOB' && *{$fh}{IO} ) { # if it's a blessed glob make sure to not break encapsulation with # fileno($fh) (e.g. if you are filtering output then file descriptor # based operations might no longer be valid). # then ensure that the fileno *opcode* agrees too, that there is a # valid IO object inside $fh either directly or indirectly and that it # corresponds to a real file descriptor. my $m_fileno = $fh->fileno; return '' unless defined $m_fileno; return '' unless $m_fileno >= 0; my $f_fileno = fileno($fh); return '' unless defined $f_fileno; return '' unless $f_fileno >= 0; return 1; } else { # anything else, including GLOBS without IO (even if they are blessed) # and non GLOB objects that look like filehandle objects cannot have a # valid file descriptor in fileno($fh) context so may break. return ''; } } __PACKAGE__ # ex: set sw=4 et: __END__ =pod =head1 NAME IO::Handle::Util - Functions for working with L like objects. =head1 SYNOPSIS # make something that looks like a filehandle from a random data: my $io = io_from_any $some_data; # or from a callback that returns strings: my $io = io_from_getline sub { return $another_line }; # create a callback that iterates through the handle my $read_cb = io_to_read_cb $io; =head1 DESCRIPTION This module provides a number of helpful routines to manipulate or create L like objects. =head1 EXPORTS =head2 Coercions resulting in IO objects These are available using the C<:io_from> export group. =over 4 =item io_from_any $whatever Inspects the value of C and calls the appropriate coercion function on it, either C or C. =item io_from_ref $some_ref Depending on the reference type of C<$some_ref> invokes either C, C or C. Code references are not coerced automatically because either C or C or C could all make sense. Globs are returned as is B if they have a valid C slot. =item io_from_object $obj Depending on the class of C<$obj> either returns or coerces the object. Objects that are passed through include anything that subclasses L or seems to duck type (supports the C and C methods, which might be a bit too permissive). Objects that are coerced currently only include L, which will have the C method invoked on it. Anything else is an error. =over 4 =item io_from_string $str Instantiates an L object using C<$str> as the buffer. Note that C<$str> is B passed as an alias, so writing to the IO object will not modify string. For that see C. =item io_from_array \@array Creates an L that will return the elements of C<@array> one by one. Note that a I of C<@array> is made. In order to be able to append more elements to the array or remove the ones that have been returned use L yourself directly. =item io_from_scalar_ref \$str Creates an L object using C<$str> as the buffer. Writing to the IO object will modify C<$str>. =item io_from_thunk sub { ... } Invokes the callback once in list context the first time it's needed, and then returns each element of the list like C would. =item io_from_getline sub { ... } Creates an L object using the callback. =item io_from_write_cb sub { ... } Creates an L using the callback. The callback will always be invoked with one string argument and with the values of C<$,> and C<$\> localized to C. =back =head2 Coercions utilizing IO objects These coercions will actually call C on their argument first. This allows you to do things like: my $str = ''; my $sub = io_to_write_cb(\$str); $sub->("foo"); These are available using the C<:io_to> export group. =over 4 =item io_to_write_cb $thing Creates a code ref that will invoke C on the handle with the arguments to the callback. C<$,> and C<$\> will both be localized to C. =item io_to_read_cb $thing Creates a code ref that will invoke C on the handle. C<$/> will not be localized and should probably be set to a reference to a number if you want efficient iteration. See L for details. =item io_to_string $thing Slurps a string out of the IO object by reading all the data. If a string was passed it is returned as is. =item io_to_array $thing Returns an array reference containing all the lines of the IO object. If an array reference was passed it is returned as is. =item io_to_list $thing Returns the list of lines from the IO object. Warns if not invoked in list context. If an array reference was passed it is dereferenced an its elements are returned. =item io_to_glob $thing If the filehandle is an unblessed glob returns it as is, otherwise returns a new glob which is tied to delegate to the OO interface. This lets you use most of the builtins without the method syntax: my $fh = io_to_glob($some_kind_of_OO_handle); while ( defined( my $line = <$fh> ) ) { ... } =back =head2 Misc functions =over 4 =item io_prototype %callbacks Given a key-value pair list of named callbacks, constructs an L object with those callbacks. For example: my $io = io_prototype print => sub { my $self = shift; no warnings 'uninitialized'; $string .= join($,, @_) . $\; }; $io->say("Hello"); # $string now has "Hello\n" See L for more details. =item is_real_fh $io Returns true if the IO handle probably could be passed to something like L which would break encapsulation. Checks for the following conditions: =over 4 =item * The handle has a reftype of either a C with an C slot, or is an C itself. =item * The handle's C method returns a positive number, corresponding to a filedescriptor. =item * The C builtin returns the same thing as C invoked as a method. =back If these conditions hold the handle is I OK to work with using the IO builtins directly, or passing the filedesctiptor to C land, instead of by invoking methods on it. =back =head1 SEE ALSO L, L, L, L, L =head1 VERSION CONTROL L =head1 AUTHOR Yuval Kogman =head1 COPYRIGHT & LICENSE Copyright (c) 2009 Yuval Kogman. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut IO-Handle-Util-0.01/lib/IO/Handle/Util/Overloading.pm000644 000765 000024 00000001132 11260507736 023533 0ustar00nothingmuchstaff000000 000000 package IO::Handle::Util::Overloading; use strict; use warnings; use asa 'IO::Handle'; use overload ( '*{}' => sub { my $self = shift; require IO::Handle::Util; return IO::Handle::Util::io_to_glob($self); }, # to quote overload.pm # # BUGS Even in list context, the iterator is currently called only # once and with scalar context. # #'<>' => sub { # if ( wantarray ) { # shift->getlines; # } else { # shift->getline; # } #}, fallback => 1, ); # ex: set sw=4 et: __PACKAGE__ __END__ IO-Handle-Util-0.01/lib/IO/Handle/Util/Tie.pm000644 000765 000024 00000001223 11260503224 021770 0ustar00nothingmuchstaff000000 000000 package IO::Handle::Util::Tie; use strict; use warnings; sub TIEHANDLE { my ( $class, $fh ) = @_; bless \$fh, $class; } sub WRITE { my $self = shift; $$self->write(@_); } sub PRINT { my $self = shift; $$self->print(@_); } sub PRINTF { my $self = shift; $$self->printf(@_); } sub READ { my $self = shift; $$self->read(@_); } sub READLINE { my $self = shift; if ( wantarray ) { $$self->getlines; } else { $$self->getline; } } sub GETC { my $self = shift; $$self->getc(@_); } sub CLOSE { my $self = shift; $$self->close(@_); } sub UNTIE { } __PACKAGE__ __END__ IO-Handle-Util-0.01/lib/IO/Handle/Prototype/Fallback.pm000644 000765 000024 00000024720 11260512463 024052 0ustar00nothingmuchstaff000000 000000 package IO::Handle::Prototype::Fallback; use strict; use warnings; use Carp (); use parent qw(IO::Handle::Prototype); sub new { my ( $class, @args ) = @_; $class->SUPER::new( $class->_process_callbacks(@args), ); } sub __write { shift->_cb(__write => @_) } sub __read { shift->_cb(__read => @_) } sub _process_callbacks { my ( $class, %user_cb ) = @_; if ( keys %user_cb == 1 ) { # these callbacks require wrapping of the user's callback to add # buffering, so we short circuit the entire process foreach my $fallback (qw(__read read getline)) { if ( my $cb = $user_cb{$fallback} ) { my $method = "_default_${fallback}_callbacks"; return $class->_process_callbacks( $class->$method($cb), ); } } } my @fallbacks = $class->_base_callbacks; # additional fallbacks based on explicitly provided callbacks foreach my $fallback (qw(__write print write syswrite)) { if ( exists $user_cb{$fallback} ) { push @fallbacks, $class->_default_write_callbacks($fallback); last; } } if ( exists $user_cb{getline} ) { push @fallbacks, $class->_simple_getline_callbacks; } if ( exists $user_cb{read} ) { push @fallbacks, $class->_simple_read_callbacks; } # merge everything my %cb = ( @fallbacks, %user_cb, ); return \%cb; } sub _base_callbacks { my $class = shift; return ( fileno => sub { undef }, stat => sub { undef }, opened => sub { 1 }, blocking => sub { my ( $self, @args ) = @_; Carp::croak("Can't set blocking mode on iterator") if @args; return 1; }, ); } sub _make_read_callbacks { my ( $class, $read ) = @_; no warnings 'uninitialized'; return ( # these fallbacks must wrap the underlying reading mechanism __read => sub { my $self = shift; if ( exists $self->{buf} ) { return delete $self->{buf}; } else { my $ret = $self->$read; unless ( defined $ret ) { $self->{eof}++; } return $ret; } }, getline => sub { my $self = shift; return undef if $self->{eof}; if ( ref $/ ) { $self->read(my $ret, ${$/}); return $ret; } elsif ( defined $/ ) { getline: { if ( defined $self->{buf} and (my $off = index($self->{buf}, $/)) > -1 ) { return substr($self->{buf}, 0, $off + length($/), ''); } else { if ( defined( my $chunk = $self->$read ) ) { $self->{buf} .= $chunk; redo getline; } else { $self->{eof}++; if ( length( my $buf = delete $self->{buf} ) ) { return $buf; } else { return undef; } } } } } else { my $ret = delete $self->{buf}; while ( defined( my $chunk = $self->$read ) ) { $ret .= $chunk; } $self->{eof}++; return $ret; } }, read => sub { my ( $self, undef, $length, $offset ) = @_; return 0 if $self->{eof}; if ( $offset and length($_[1]) < $offset ) { $_[1] .= "\0" x ( $offset - length($_[1]) ); } while (length($self->{buf}) < $length) { if ( defined(my $next = $self->$read) ) { $self->{buf} .= $next; } else { # data ended but still under $length, return all that remains and # empty the buffer my $ret = length($self->{buf}); if ( $offset ) { substr($_[1], $offset) = delete $self->{buf}; } else { $_[1] = delete $self->{buf}; } $self->{eof}++; return $ret; } } my $read; if ( $length > length($self->{buf}) ) { $read = delete $self->{buf}; } else { $read = substr($self->{buf}, 0, $length, ''); } if ( $offset ) { substr($_[1], $offset) = $read; } else { $_[1] = $read; } return length($read); }, eof => sub { my $self = shift; $self->{eof}; }, ungetc => sub { my ( $self, $ord ) = @_; substr( $self->{buf}, 0, 0, chr($ord) ); return; }, ); } sub _default___read_callbacks { my ( $class, $read ) = @_; $class->_make_read_callbacks($read); } sub _default_read_callbacks { my ( $class, $read ) = @_; $class->_make_read_callbacks(sub { my $self = shift; if ( $self->$read(my $buf, ref $/ ? ${ $/ } : 4096) ) { return $buf; } else { return undef; } }); } sub _default_getline_callbacks { my ( $class, $getline ) = @_; $class->_make_read_callbacks(sub { local $/ = ref $/ ? $/ : \4096; $_[0]->$getline; }); } sub _simple_read_callbacks { my $class = shift; return ( # these are generic fallbacks defined in terms of the wrapping ones sysread => sub { shift->read(@_); }, getc => sub { my $self = shift; if ( $self->read(my $str, 1) ) { return $str; } else { return undef; } }, ); } sub _simple_getline_callbacks { my $class = shift; return ( getlines => sub { my $self = shift; my @accum; while ( defined(my $next = $self->getline) ) { push @accum, $next; } return @accum; } ); } sub _default_write_callbacks { my ( $class, $canonical ) = @_; return ( autoflush => sub { 1 }, sync => sub { }, flush => sub { }, # these are defined in terms of a canonical print method, either write, # syswrite or print __write => sub { my ( $self, $str ) = @_; local $\; local $,; $self->$canonical($str); }, print => sub { my $self = shift; my $ofs = defined $, ? $, : ''; my $ors = defined $\ ? $\ : ''; $self->__write( join($ofs, @_) . $ors ); }, (map { $_ => sub { my ( $self, $str, $len, $offset ) = @_; $len = length($str) unless defined $len; $offset ||= 0; $self->__write(substr($str, $offset, $len)); } } qw(write syswrite)), # wrappers for print printf => sub { my ( $self, $f, @args ) = @_; $self->print(sprintf $f, @args); }, say => sub { local $\ = "\n"; shift->print(@_); }, printflush => sub { my $self = shift; my $autoflush = $self->autoflush; my $ret = $self->print(@_); $self->autoflush($autoflush); return $ret; } ); } __PACKAGE__ # ex: set sw=4 et: __END__ =pod =head1 NAME IO::Handle::Prototype::Fallback - Create L like objects using a set of callbacks. =head1 SYNOPSIS my $fh = IO::Handle::Prototype::Fallback->new( getline => sub { my $fh = shift; ... }, ); =head1 DESCRIPTION This class provides a way to define a filehandle based on callbacks. Fallback implementations are provided to the extent possible based on the provided callbacks, for both writing and reading. =head1 SPECIAL CALLBACKS This class provides two additional methods on top of L, designed to let you implement things with a minimal amount of baggage. The fallback methods are all best implemented using these, though these can be implemented in terms of Perl's standard methods too. However, to provide the most consistent semantics, it's better to do this: IO::Handle::Prototype::Fallback->new( __read => sub { shift @array; }, ); Than this: IO::Handle::Prototype::Fallback->new( getline => sub { shift @array; }, ); Because the fallback implementation of C implements all of the extra crap you'd need to handle to have a fully featured implementation. =over 4 =item __read Return a chunk of data of any size (could use C<$/> or not, it depends on you, unlike C which probably I respect the value of C<$/>). This avoids the annoying C stuff you need to do with C. =item __write $string Write out a string. This is like a simplified C, which can disregard C<$,> and C<$\> as well as multiple argument forms, and does not have the extra C annoyance of C or C. =back =head1 WRAPPING If you provide a B reading related callback (C<__read>, C or C) then your callback will be used to implement all of the other reading primitives using a string buffer. These implementations handle C<$/> in all forms (C, ref to number and string), all the funny calling conventions for C, etc. =head1 FALLBACKS Any callback that can be defined purely in terms of other callbacks in a way will be added. For instance C can be implemented in terms of C, C can be implemented in terms of C, C can be implemented in terms of C, C can be implemented in terms of C, etc. None of these require special wrapping and will always be added if their dependencies are present. =head1 GLOB OVERLOADING When overloaded as a glob a tied handle will be returned. This allows you to use the handle in Perl's IO builtins. For instance: my $line = <$fh> will not call the C method natively, but the tied interface arranges for that to happen. =cut