IO-Callback-2.00000755001750001750 013722453414 12156 5ustar00taitai000000000000IO-Callback-2.00/Build.PL000444001750001750 155313722453414 13613 0ustar00taitai000000000000use 5.006; use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'IO::Callback', license => 'perl', dist_author => 'Dave Taylor ', dist_version_from => 'lib/IO/Callback.pm', requires => { 'perl' => 5.006, 'Carp' => 0, 'Errno' => 0, 'IO::String' => 0, }, build_requires => { 'Fatal' => 0, 'Fcntl' => 0, 'File::Slurp' => 0, 'File::Temp' => 0, 'IO::Handle' => 0, 'Module::Build' => 0, 'Test::Exception' => 0, 'Test::More' => 0, 'Test::NoWarnings' => 0, }, add_to_cleanup => [ 'IO::Callback-*' ], create_makefile_pl => 'small', ); $builder->create_build_script(); IO-Callback-2.00/Changes000444001750001750 442513722453414 13613 0ustar00taitai000000000000Revision history for IO::Callback 2.00 2020-08-29 cpan:TOBYINK Change slot keys to be lowercase, fixes RT#132961. Workaround difficulties with Test::NoWarnings, fixes RT#98861. 1.12 2014-05-25 cpan:TOBYINK No functional changes since 1.11_01. 1.11_01 2014-05-18 cpan:TOBYINK Rename SLOW_TESTS environment variable to EXTENDED_TESTING in line with Lancaster Consensus. Skip t/read-sha.t for Digest::SHA 5.89 and 5.90. 1.10 2012-09-10 cpan:TOBYINK No functional changes since 1.09_01. 1.09_01 2012-07-16 cpan:TOBYINK Fix failing tests. Skip slower tests unless SLOW_TESTS environment variable set to true. 1.08 2010-03-29 cpan:PUBNOOP Abandon filesystem write intensive tests if they take too long 1.07 2010-03-25 cpan:PUBNOOP Fix failing tests under perl 5.11 1.06 2009-08-20 cpan:PUBNOOP Made some of the slower tests author only 1.05 2009-08-17 cpan:PUBNOOP Reduce the memory footprint of the test suite 1.04 2009-08-06 cpan:PUBNOOP Fix failing tests under 5.8.0 to 5.8.8 1.03 2009-08-03 cpan:PUBNOOP Fix failing tests under 5.6.2 made tell() set $., to better mimic perl's behavior 1.02 2009-08-02 cpan:PUBNOOP Fixed another test failure under 5.8 Corrected the dates in this file 1.01 2009-08-02 cpan:PUBNOOP Minor doc tweaks. Fixed failing test due to an uncaught warning under 5.8.8 1.00 2009-08-01 cpan:PUBNOOP Renamed from IO::Coderef to IO::Callback Subclassed IO::String. Allowed the callbacks to simulate non-fatal file I/O errors. Implemented setting $. and input_line_number(). More tests, fixed offset handling in sysread(). 0.94 2009-07-30 cpan:PUBNOOP Added tests for ungetc, watched them fail, fixed it. Prevented extra callback call on double close of write handle. Made use of File::Slurp in the test suite. 0.93 2009-07-29 cpan:PUBNOOP Even more tests. Pillaged some test scripts from IO::String. Added tell() support. 0.92 2009-07-29 cpan:PUBNOOP More tests 0.91 2009-07-28 cpan:PUBNOOP POD tweak 0.90 2009-07-28 cpan:PUBNOOP Initial release. IO-Callback-2.00/MANIFEST000444001750001750 123713722453414 13447 0ustar00taitai000000000000Build.PL Changes lib/IO/Callback.pm Makefile.PL MANIFEST This list of files META.json META.yml README t/build-test-scripts t/callback.t t/constructor-args.t t/error-handling.t t/examples-from-pod.t t/file-copy.t t/io-compress-bzip2.t t/io-compress-gzip.t t/io-compress.ttmpl t/iostring-close.t t/iostring-para.t t/iostring-read.t t/iostring-write.t t/misc.t t/pod.t t/read-sha.t t/read-variations.inc t/stat.t t/sysread-params.t t/syswrite-params.t t/write-close.t t/wrongway-ebadf.t t/z5-write-variations.t t/z9-read-variations-1.t t/z9-read-variations-10.t t/z9-read-variations-1_000_000.t t/z9-read-variations-2.t t/z9-read-variations-3.t t/z9-read-variations.ttmpl IO-Callback-2.00/META.json000444001750001750 255013722453414 13736 0ustar00taitai000000000000{ "abstract" : "Emulate file interface for a code reference", "author" : [ "Dave Taylor " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "IO-Callback", "prereqs" : { "build" : { "requires" : { "Fatal" : "0", "Fcntl" : "0", "File::Slurp" : "0", "File::Temp" : "0", "IO::Handle" : "0", "Module::Build" : "0", "Test::Exception" : "0", "Test::More" : "0", "Test::NoWarnings" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Carp" : "0", "Errno" : "0", "IO::String" : "0", "perl" : "5.006" } } }, "provides" : { "IO::Callback" : { "file" : "lib/IO/Callback.pm", "version" : "2.00" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "2.00", "x_serialization_backend" : "JSON::PP version 2.27400_02" } IO-Callback-2.00/META.yml000444001750001750 150613722453414 13566 0ustar00taitai000000000000--- abstract: 'Emulate file interface for a code reference' author: - 'Dave Taylor ' build_requires: Fatal: '0' Fcntl: '0' File::Slurp: '0' File::Temp: '0' IO::Handle: '0' Module::Build: '0' Test::Exception: '0' Test::More: '0' Test::NoWarnings: '0' configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: IO-Callback provides: IO::Callback: file: lib/IO/Callback.pm version: '2.00' requires: Carp: '0' Errno: '0' IO::String: '0' perl: '5.006' resources: license: http://dev.perl.org/licenses/ version: '2.00' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IO-Callback-2.00/Makefile.PL000444001750001750 44413722453414 14247 0ustar00taitai000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4224 require 5.006; use Module::Build::Compat 0.02; Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); IO-Callback-2.00/README000444001750001750 310113722453414 13166 0ustar00taitai000000000000"IO::Callback" provides an easy way to produce a phoney read-only filehandle that calls back to your own code when it needs data to satisfy a read. This is useful if you want to use a library module that expects to read data from a filehandle, but you want the data to come from some other source and you don't want to read it all into memory and use IO::String. use IO::Callback; my $fh = IO::Callback->new('<', sub { ... ; return $data }); my $object = Some::Class->new_from_file($fh); Similarly, IO::Callback allows you to wrap up a coderef as a write-only filehandle, which you can pass to a library module that expects to write its output to a filehandle. my $fh = IO::Callback->new('>', sub { my $data = shift ; ... }); $object->dump_to_file($fh); INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc IO::Callback You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=IO::Callback AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/IO::Callback CPAN Ratings http://cpanratings.perl.org/d/IO::Callback Search CPAN http://search.cpan.org/dist/IO::Callback COPYRIGHT AND LICENCE Copyright 1998-2005 Gisle Aas. Copyright 2009-2010 Dave Taylor. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. IO-Callback-2.00/lib000755001750001750 013722453414 12724 5ustar00taitai000000000000IO-Callback-2.00/lib/IO000755001750001750 013722453414 13233 5ustar00taitai000000000000IO-Callback-2.00/lib/IO/Callback.pm000444001750001750 4114313722453414 15445 0ustar00taitai000000000000package IO::Callback; use warnings; use strict; =head1 NAME IO::Callback - Emulate file interface for a code reference =head1 VERSION Version 2.00 =cut our $VERSION = '2.00'; =head1 SYNOPSIS C provides an easy way to produce a phoney read-only filehandle that calls back to your own code when it needs data to satisfy a read. This is useful if you want to use a library module that expects to read data from a filehandle, but you want the data to come from some other source and you don't want to read it all into memory and use L. use IO::Callback; my $fh = IO::Callback->new('<', sub { ... ; return $data }); my $object = Some::Class->new_from_file($fh); Similarly, IO::Callback allows you to wrap up a coderef as a write-only filehandle, which you can pass to a library module that expects to write its output to a filehandle. my $fh = IO::Callback->new('>', sub { my $data = shift ; ... }); $object->dump_to_file($fh); =head1 CONSTRUCTOR =head2 C Returns a filehandle object encapsulating the coderef. MODE must be either C> for a read-only filehandle or C> for a write-only filehandle. For a read-only filehandle, the callback coderef will be invoked in a scalar context each time more data is required to satisfy a read. It must return some more input data (at least one byte) as a string. If there is no more data to be read, then the callback should return either C or the empty string. If ARG values were supplied to the constructor, then they will be passed to the callback each time it is invoked. For a write-only filehandle, the callback will be invoked each time there is data to be written. The first argument will be the data as a string, which will always be at least one byte long. If ARG values were supplied to the constructor, then they will be passed as additional arguments to the callback. When the filehandle is closed, the callback will be invoked once with the empty string as its first argument. To simulate a non-fatal error on the file, the callback should set C<$!> and return the special value C. See examples 6 and 7 below. =head1 EXAMPLES =over 4 =item Example 1 To generate a filehandle from which an infinite number of C characters can be read: =for test "ex1" begin my $fh = IO::Callback->new('<', sub {"xxxxxxxxxxxxxxxxxxxxxxxxxxx"}); my $x = $fh->getc; # $x now contains "x" read $fh, $x, 5; # $x now contains "xxxxx" =for test "ex1" end =item Example 2 A filehandle from which 1000 C lines can be read before EOF: =for test "ex2" begin my $count = 0; my $fh = IO::Callback->new('<', sub { return if ++$count > 1000; # EOF return "foo\n"; }); my $x = <$fh>; # $x now contains "foo\n" read $fh, $x, 2; # $x now contains "fo" read $fh, $x, 2; # $x now contains "o\n" read $fh, $x, 20; # $x now contains "foo\nfoo\nfoo\nfoo\nfoo\n" my @foos = <$fh>; # @foos now contains ("foo\n") x 993 =for test "ex2" end The example above uses a C (a special kind of anonymous sub, see L) to allow the callback to keep track of how many lines it has returned. You don't have to use a closure if you don't want to, since C will forward extra constructor arguments to the callback. This example could be re-written as: =for test "ex2a" begin my $count = 0; my $fh = IO::Callback->new('<', \&my_callback, \$count); my $x = <$fh>; # $x now contains "foo\n" read $fh, $x, 2; # $x now contains "fo" read $fh, $x, 2; # $x now contains "o\n" read $fh, $x, 20; # $x now contains "foo\nfoo\nfoo\nfoo\nfoo\n" my @foos = <$fh>; # @foos now contains ("foo\n") x 993 sub my_callback { my $count_ref = shift; return if ++$$count_ref > 1000; # EOF return "foo\n"; }; =for test "ex2a" end =item Example 3 To generate a filehandle interface to data drawn from an SQL table: =for test "ex3" begin my $sth = $dbh->prepare("SELECT ..."); $sth->execute; my $fh = IO::Callback->new('<', sub { my @row = $sth->fetchrow_array; return unless @row; # EOF return join(',', @row) . "\n"; }); # ... =for test "ex3" end =item Example 4 You want a filehandle to which data can be written, where the data is discarded but an exception is raised if the data includes the string C. =for test "ex4" begin my $buf = ''; my $fh = IO::Callback->new('>', sub { $buf .= shift; die "foo written" if $buf =~ /foo/; if ($buf =~ /(fo?)\z/) { # Part way through a "foo", carry over to the next block. $buf = $1; } else { $buf = ''; } }); =for test "ex4" end =item Example 5 You have been given an object with a copy_data_out() method that takes a destination filehandle as an argument. You don't want the data written to a file though, you want it split into 1024-byte blocks and inserted into an SQL database. =for test "ex5" begin my $blocksize = 1024; my $sth = $dbh->prepare('INSERT ...'); my $buf = ''; my $fh = IO::Callback->new('>', sub { $buf .= shift; while (length $buf >= $blocksize) { $sth->execute(substr $buf, 0, $blocksize, ''); } }); $thing->copy_data_out($fh); if (length $buf) { # There is a remainder of < $blocksize $sth->execute($buf); } =for test "ex5" end =item Example 6 You're testing some code that reads data from a file, you want to check that it behaves as expected if it gets an IO error part way through the file. =for test "ex6" begin use IO::Callback; use Errno qw/EIO/; my $block1 = "x" x 10240; my $block2 = "y" x 10240; my @blocks = ($block1, $block2); my $fh = IO::Callback->new('<', sub { return shift @blocks if @blocks; $! = EIO; return IO::Callback::Error; }); # ... =for test "ex6" end =item Example 7 You're testing some code that writes data to a file handle, you want to check that it behaves as expected if it gets a C error after it has written the first 100k of data. =for test "ex7" begin use IO::Callback; use Errno qw/ENOSPC/; my $wrote = 0; my $fh = IO::Callback->new('>', sub { $wrote += length $_[0]; if ($wrote > 100_000) { $! = ENOSPC; return IO::Callback::Error; } }); # ... =for test "ex7" end =back =cut use Carp; use Errno qw/EBADF/; use IO::String; use base qw/IO::String/; sub open { my $self = shift; return $self->new(@_) unless ref($self); my $mode = shift or croak "mode missing in IO::Callback::new"; if ($mode eq '<') { *$self->{r} = 1; } elsif ($mode eq '>') { *$self->{w} = 1; } else { croak qq{invalid mode "$mode" in IO::Callback::new}; } my $code = shift or croak "coderef missing in IO::Callback::new"; ref $code eq "CODE" or croak "non-coderef second argument in IO::Callback::new"; my $buf = ''; *$self->{buf} = \$buf; *$self->{pos} = 0; *$self->{err} = 0; *$self->{lno} = 0; if (@_) { my @args = @_; *$self->{code} = sub { $code->(@_, @args) }; } else { *$self->{code} = $code; } } sub close { my $self = shift; return unless defined *$self->{code}; return if *$self->{err}; if (*$self->{w}) { my $ret = *$self->{code}(''); if ($ret and ref $ret eq 'IO::Callback::ErrorMarker') { *$self->{err} = 1; return; } } foreach my $key (qw/code buf eof r w pos lno/) { delete *$self->{$key}; } *$self->{err} = -1; undef *$self if $] eq "5.008"; # cargo culted from IO::String return 1; } sub opened { my $self = shift; return defined *$self->{r} || defined *$self->{w}; } sub getc { my $self = shift; *$self->{r} or return $self->_ebadf; my $buf; return $buf if $self->read($buf, 1); return undef; } sub ungetc { my ($self, $char) = @_; *$self->{r} or return $self->_ebadf; my $buf = *$self->{buf}; $$buf = chr($char) . $$buf; --*$self->{pos}; delete *$self->{eof}; return 1; } sub eof { my $self = shift; return *$self->{eof}; } # Use something very distinctive for the error return code, since write callbacks # may pay no attention to what they are returning, and it would be bad to mistake # returned noise for an error indication. sub Error () { return bless {}, 'IO::Callback::ErrorMarker'; } sub _doread { my $self = shift; return unless *$self->{code}; my $newbit = *$self->{code}(); if (defined $newbit) { if (ref $newbit) { if (ref $newbit eq 'IO::Callback::ErrorMarker') { *$self->{err} = 1; return; } else { confess "unexpected reference type ".ref($newbit)." returned by callback"; } } if (length $newbit) { ${*$self->{buf}} .= $newbit; return 1; } } # fall-through for both undef and '' delete *$self->{code}; return; } sub getline { my $self = shift; *$self->{r} or return $self->_ebadf; return if *$self->{eof} || *$self->{err}; my $buf = *$self->{buf}; $. = *$self->{lno}; unless (defined $/) { # slurp 1 while $self->_doread; return if *$self->{err}; *$self->{pos} += length $$buf; *$self->{eof} = 1; *$self->{buf} = \(my $newbuf = ''); $. = ++ *$self->{lno}; return $$buf; } my $rs = length $/ ? $/ : "\n\n"; for (;;) { # In paragraph mode, discard extra newlines. if ($/ eq '' and $$buf =~ s/^(\n+)//) { *$self->{pos} += length $1; } my $pos = index $$buf, $rs; if ($pos >= 0) { *$self->{pos} += $pos+length($rs); my $ret = substr $$buf, 0, $pos+length($rs), ''; unless (length $/) { # paragraph mode, discard extra trailing newlines $$buf =~ s/^(\n+)// and *$self->{pos} += length $1; while (*$self->{code} and length $$buf == 0) { $self->_doread; return if *$self->{err}; $$buf =~ s/^(\n+)// and *$self->{pos} += length $1; } } $self->_doread while *$self->{code} and length $$buf == 0 and not *$self->{err}; if (length $$buf == 0 and not *$self->{code}) { *$self->{eof} = 1; } $. = ++ *$self->{lno}; return $ret; } if (*$self->{code}) { $self->_doread; return if *$self->{err}; } else { # EOL not in buffer and no more data to come - the last line is missing its EOL. *$self->{eof} = 1; *$self->{pos} += length $$buf; *$self->{buf} = \(my $newbuf = ''); $. = ++ *$self->{lno} if length $$buf; return $$buf if length $$buf; return; } } } sub getlines { croak "getlines() called in scalar context" unless wantarray; my $self = shift; *$self->{r} or return $self->_ebadf; return if *$self->{err} || *$self->{eof}; # To exactly match Perl's behavior on real files, getlines() should not # increment $. if there is no more input, but getline() should. I won't # call getline() until I've established that there is more input. my $buf = *$self->{buf}; unless (length $$buf) { $self->_doread; return unless length $$buf; } my($line, @lines); push(@lines, $line) while defined($line = $self->getline); return @lines; } sub READLINE { goto &getlines if wantarray; goto &getline; } sub read { my $self = shift; *$self->{r} or return $self->_ebadf; my $len = $_[1]||0; croak "Negative length" if $len < 0; return if *$self->{err}; return 0 if *$self->{eof}; my $buf = *$self->{buf}; 1 while *$self->{code} and $len > length $$buf and $self->_doread; return if *$self->{err}; if ($len > length $$buf) { $len = length $$buf; *$self->{eof} = 1 unless $len; } if (@_ > 2) { # read offset my $offset = $_[2]||0; if ($offset < -1 * length $_[0]) { croak "Offset outside string"; } if ($offset > length $_[0]) { $_[0] .= "\0" x ($offset - length $_[0]); } substr($_[0], $offset) = substr($$buf, 0, $len, ''); } else { $_[0] = substr($$buf, 0, $len, ''); } *$self->{pos} += $len; return $len; } *sysread = \&read; *syswrite = \&write; sub stat { my $self = shift; return unless $self->opened; return 1 unless wantarray; my @stat = $self->SUPER::stat(); # size unknown, report 0 $stat[7] = 0; $stat[12] = 1; return @stat; } sub print { my $self = shift; my $result; if (defined $\) { if (defined $,) { $result = $self->write(join($,, @_).$\); } else { $result = $self->write(join("",@_).$\); } } else { if (defined $,) { $result = $self->write(join($,, @_)); } else { $result = $self->write(join("",@_)); } } return unless defined $result; return 1; } *printflush = \*print; sub printf { my $self = shift; my $fmt = shift; my $result = $self->write(sprintf($fmt, @_)); return unless defined $result; return 1; } sub getpos { my $self = shift; $. = *$self->{lno}; return *$self->{pos}; } *tell = \&getpos; *pos = \&getpos; sub setpos { croak "setpos not implemented for IO::Callback"; } sub truncate { croak "truncate not implemented for IO::Callback"; } sub seek { croak "Illegal seek"; } *sysseek = \&seek; sub write { my $self = shift; *$self->{w} or return $self->_ebadf; return if *$self->{err}; my $slen = length($_[0]); my $len = $slen; my $off = 0; if (@_ > 1) { my $xlen = defined $_[1] ? $_[1] : 0; $len = $xlen if $xlen < $len; croak "Negative length" if $len < 0; if (@_ > 2) { $off = $_[2] || 0; if ( $off >= $slen and $off > 0 and ($] < 5.011 or $off > $slen) ) { croak "Offset outside string"; } if ($off < 0) { $off += $slen; croak "Offset outside string" if $off < 0; } my $rem = $slen - $off; $len = $rem if $rem < $len; } } return $len if $len == 0; my $ret = *$self->{code}(substr $_[0], $off, $len); if (defined $ret and ref $ret eq 'IO::Callback::ErrorMarker') { *$self->{err} = 1; return; } *$self->{pos} += $len; return $len; } sub error { my $self = shift; return *$self->{err}; } sub clearerr { my $self = shift; *$self->{err} = 0; } sub _ebadf { my $self = shift; $! = EBADF; *$self->{err} = -1; return; } *GETC = \&getc; *PRINT = \&print; *PRINTF = \&printf; *READ = \&read; *WRITE = \&write; *SEEK = \&seek; *TELL = \&getpos; *EOF = \&eof; *CLOSE = \&close; =head1 AUTHOR Dave Taylor, C<< >> =head1 BUGS AND LIMITATIONS Fails to inter-operate with some library modules that read or write filehandles from within XS code. I am aware of the following specific cases, please let me know if you run into any others: =over 4 =item C =back Please report any other bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc IO::Callback You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 SEE ALSO L, L, L =head1 ACKNOWLEDGEMENTS Adapted from code in L by Gisle Aas. =head1 MANITAINER This module is currently being maintained by Toby Inkster (TOBYINK) for bug fixes. No substantial changes or new features are planned. =head1 COPYRIGHT & LICENSE Copyright 1998-2005 Gisle Aas. Copyright 2009-2010 Dave Taylor. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of IO::Callback IO-Callback-2.00/t000755001750001750 013722453414 12421 5ustar00taitai000000000000IO-Callback-2.00/t/build-test-scripts000555001750001750 452213722453414 16250 0ustar00taitai000000000000#!/usr/bin/perl use strict; use warnings; =head1 NAME build-test-scripts - rebuild t/*.t from t/*.ttmpl =head1 SYNOPSIS t/build-test-scripts =head1 DESCRIPTION When run from the root of the IO::Callback distribution, this script rebuilds some of the test files in F from test template files in the same directory. Each test template gives rise to one or more test files, with a test file generated for each possible combination of values for the C directives in the template. =cut use autodie; use File::Slurp; use File::Spec; use Template; our $tt =Template->new({ START_TAG => '<<<', END_TAG => '>>>', }); my $dirhandle; opendir $dirhandle, "t"; while ( my $f = readdir $dirhandle ) { next unless $f =~ m{^(.+)\.ttmpl$}; my $base_test_name = $1; my $src_filename = File::Spec->catfile("t", $f); my $auto_warning = < $value }); } } sub output_test_script { my ($test_name, $input, $vars) = @_; my $outfile = File::Spec->catfile("t", "$test_name.t"); $tt->process(\$input, $vars, $outfile) or die "Template $outfile: ".$tt->error; } IO-Callback-2.00/t/callback.t000444001750001750 333713722453414 14505 0ustar00taitai000000000000# IO::Callback 1.08 t/callback.t # Check the interface to the callback coderef use strict; use warnings; use Test::More tests => 11; use Test::Exception; use Test::NoWarnings; use IO::Callback; foreach my $ret_eof ('return', 'return undef', 'return ""') { my @blocks = ('foo', 'bar', 'RETURN_EOF', 'baz'); my $callback = eval <new('<', $callback, \@blocks); my $got = join '', <$fh>; is $got, "foobar", "recognised '$ret_eof' as EOF"; } our $fh = IO::Callback->new("<", sub { return }); my $ret = read $fh, $_, 100; is $_, "", "empty string read if callback sends nothing"; is $ret, 0, "0 len reported if callback sends nothing"; $fh = IO::Callback->new('<', sub { return IO::Callback::Error }); $ret = read $fh, $_, 100; ok ! defined $ret, "error reported if read callback returns Error"; $fh = IO::Callback->new('<', sub { return [] }); SKIP: { skip "perl too old", 1 if $] < 5.008; # Running this under 5.6.2 causes the test script to exit with status 0, # feels like an old perl bug. throws_ok { read $fh, $_, 100 } '/^unexpected reference type ARRAY returned by callback/', "invalid read callback ref return trapped"; }; $fh = IO::Callback->new('>', sub { return IO::Callback::Error }); $ret = print $fh "foo\n"; ok ! defined $ret, "error reported if write callback returns Error"; $fh = IO::Callback->new('>', sub { return [] }); lives_ok { $ret = print $fh "foo\n" } "arbitrary write callback ref return: no croak"; ok $ret, "arbitrary write callback ref return: no fail"; IO-Callback-2.00/t/constructor-args.t000444001750001750 454713722453414 16274 0ustar00taitai000000000000# IO::Callback 1.08 t/constructor-args.t # Check that invalid constructor args are caught # Check that extra constructor args are passed on to the callback use strict; use warnings; use Test::More; use Test::NoWarnings; use Test::Exception; use IO::Callback; my $fh_src = IO::Callback->new('<', sub {}); my %constructor_source = ( package => 'IO::Callback', object => $fh_src, ); my @extra_constructor_args = ( [], [[]], [{}], [0], [[0]], [[1,2,3]], [undef], [[undef]], [1, 2, 3], [undef, undef, undef], [{}, [], {}, \$fh_src], ); my $consarg; sub read_callback { is flat(@_), flat(@$consarg), "flattened constructor args consistent"; return; } plan tests => 2 * (@extra_constructor_args + 10) + 1; while ( my ($src_name, $src) = each %constructor_source ) { foreach my $c (@extra_constructor_args) { $consarg = $c; IO::Callback->new("<", \&read_callback, @$consarg)->getc; } my $res; throws_ok { $res = $src->new } q{/^mode missing in IO::Callback::new at /}, "$src_name no mode no sub"; throws_ok { $res = $src->new(undef) } q{/^mode missing in IO::Callback::new at /}, "$src_name undef mode no sub"; throws_ok { $res = $src->new('r') } q{/^invalid mode "r" in IO::Callback::new at /}, "$src_name invalid mode no sub"; throws_ok { $res = $src->new(undef, undef) } q{/^mode missing in IO::Callback::new at /}, "$src_name undef mode undef sub"; throws_ok { $res = $src->new('r', undef) } q{/invalid mode "r" in IO::Callback::new at /}, "$src_name invalid mode undef sub"; throws_ok { $res = $src->new('r', 'not a coderef') } q{/^invalid mode "r" in IO::Callback::new at /}, "$src_name invalid mode invalid sub"; throws_ok { $res = $src->new('r', sub {}) } q{/^invalid mode "r" in IO::Callback::new at /}, "$src_name invalid mode valid sub"; throws_ok { $res = $src->new('<') } q{/^coderef missing in IO::Callback::new at /}, "$src_name valid mode no sub"; throws_ok { $res = $src->new('<', undef) } q{/^coderef missing in IO::Callback::new at /}, "$src_name valid mode undef sub"; throws_ok { $res = $src->new('<', 1) } q{/^non-coderef second argument in IO::Callback::new at /}, "$src_name valid mode invalid sub"; } sub flat { return join ",", map { defined() ? "{$_}" : "undef" } @ARGV; } IO-Callback-2.00/t/error-handling.t000444001750001750 1155313722453414 15703 0ustar00taitai000000000000# IO::Callback 1.08 t/error-handling.t # Check that IO::Callback's error handling is consistent with the way Perl # handles errors on real files. use strict; use warnings; use Test::More tests => 347; use Test::Exception; use Test::NoWarnings; our $test_nowarnings_hook = $SIG{__WARN__}; $SIG{__WARN__} = sub { my $warning = shift; return if $warning =~ /stat\(\) on unopened filehandle/i; $test_nowarnings_hook->($warning); }; use IO::Callback; # Closed files and writing on read files and visa versa my %code_for_operation = ( '<' => [ 'read $fh, $_, 10', '$fh->getc' ], '>' => [ q{print $fh "foo\n"}, q{$fh->print("foo\n")}, q{$fh->write("foo\n")}, q{syswrite $fh, "foo\n"}, q{printf $fh '%s', 0}, q{$fh->printf('%s', 0)}, ], ); foreach my $rw ('>', '<') { foreach my $close_it_first (0, 1) { foreach my $operation ('>', '<') { foreach my $code (@{ $code_for_operation{$operation} }) { my $test_name = "file $rw, op '$code', closed $close_it_first"; my $fh = IO::Callback->new($rw, sub {"x"}); ok $fh->opened, "fh opened after open"; close $fh if $close_it_first; my $ret = eval $code; ok !$@, "$test_name non-fatal error, no croak"; my $should_be_ok = $rw eq $operation && not $close_it_first; is defined($ret), $should_be_ok, "$test_name returned"; is $fh->error, ($should_be_ok ? 0 : -1), "$test_name fh->error as expected"; is $fh->clearerr, 0, "clearerr returned 0"; is $fh->error, 0, "$test_name fh->error after clear as expected"; } } } } # close should fail on a write fh if the callback returns error. { my $wfh = IO::Callback->new(">", sub { IO::Callback::Error }); my $ret = $wfh->close; ok ! defined $ret, "undef return on failing close"; is $wfh->error, 1, "error flag set on failing close"; $wfh->clearerr; is $wfh->error, 0, "error flag cleared after failing close"; } # a failed write should leave the error flag set, and should lead to a failed close. { my $wfh = IO::Callback->new(">", sub { return IO::Callback::Error if $_[0] eq "foo" }); # fail on the write, but not on the close my $ret = $wfh->print("foo"); ok ! defined $ret, "errored write returned undef"; is $wfh->error, 1, "error flag set on failed write"; $ret = $wfh->close; ok ! defined $ret, "errored write lead to undef on close"; is $wfh->error, 1, "error flag still set after close after failed write"; } my $fh = IO::Callback->new('<', sub {}); throws_ok { $fh->getlines } qr{^getlines\(\) called in scalar context at }, "getlines() croaks in scalar context"; throws_ok { seek $fh, 0, 0 } qr{^Illegal seek at }, "seek croaks"; throws_ok { $fh->setpos(1234) } qr{^setpos not implemented for IO::Callback at }, "setpos croaks"; throws_ok { $fh->truncate(1234) } qr{^truncate not implemented for IO::Callback at }, "truncate croaks"; is_deeply [stat $fh], [], "stat returns empty list"; my $stat = stat $fh; ok !$stat, "stat returns false in a scalar context"; # getline/getlines should fail if there's a read error before the first eol my @readcode = ( '$ret = <$fh>', 'local $/; $ret = <$fh>', 'local $/=""; $ret = <$fh>', '($ret) = <$fh>', 'local $/; ($ret) = <$fh>', 'local $/=""; ($ret) = <$fh>', ); foreach my $readcode (@readcode) { my $block = "x" x 10240; my @ret = ($block, $block, $block, IO::Callback::Error, $block, $block); my $fh = IO::Callback->new('<', sub { shift @{$_[0]} }, \@ret); my $ret; eval $readcode; die $@ if $@; ok ! defined $ret, "getline(s) ($readcode) failed on error"; foreach my $readcode2 (@readcode) { eval $readcode2; die $@ if $@; ok ! defined $ret, "getline(s) continued to fail after error ($readcode) / ($readcode2)"; } } # All write ops should fail if the callback returns error my @writecode = ( q{$ret = print $fh $_}, q{$ret = $fh->print($_)}, q{$ret = printf $fh $_}, q{$ret = $fh->printf($_)}, q{$ret = printf $fh 'foo%s', $_}, q{$ret = $fh->printf('foo%s', $_)}, q{$ret = $fh->write($_)}, q{$ret = $fh->syswrite($_)}, q{$ret = syswrite $fh, $_}, ); foreach my $writecode (@writecode) { my $fh = IO::Callback->new('>', sub { return IO::Callback::Error if $_[0] =~ /poison/ }); my $ret; $_ = "foo"; eval $writecode; die $@ if $@; ok $ret, "no error without poison ($writecode)"; $_ = "poison"; eval $writecode; die $@ if $@; ok ! defined $ret, "error with poison ($writecode)"; $_ = "bar"; foreach my $writecode2 (@writecode) { eval $writecode2; die $@ if $@; ok ! defined $ret, "error in write after error ($writecode) / ($writecode2)"; } } IO-Callback-2.00/t/examples-from-pod.t000444001750001750 1056513722453414 16331 0ustar00taitai000000000000# IO::Callback 1.08 t/examples-from-pod.t # Check that the examples in the POD work as described use strict; use warnings; use IO::Callback; our $pm_fh; use Test::More; BEGIN { eval 'use Pod::Snippets'; plan skip_all => 'Pod::Snippets required' if $@; my $pm_file = $INC{'IO/Callback.pm'}; unless ($pm_file and open $pm_fh, "<", $pm_file) { plan skip_all => 'Unable to open my own .pm file'; } } use Test::NoWarnings; my $snips = load Pod::Snippets($pm_fh, -markup => 'test', -named_snippets => "strict", ); # Some fake objects our $fake_dbh_cycle = 0; my $dbh = bless {}, 'IO::Callback::Fake'; my $ex5_had_lastblock = 0; my $ex5_data = ''; my $ex5_expect = "qwerty7890" x 150; my $thing = $dbh; # Some of the examples are missing code to access the fh and # assertions about the results. Add that here. my %extra_code = ( ex3 => <<'EOF', my $x; read $fh, $x, 1000; # $x now contains "foo,bar,baz\n0\n0,1\n" EOF ex4 => <<'EOF', my $died; eval { print $fh "02840284203842038420384\n" }; $died = $@ ? 1 : 0; # $died now contains 0 eval { print $fh "02840284203842038fg42038f" }; $died = $@ ? 1 : 0; # $died now contains 0 eval { print $fh "o" }; $died = $@ ? 1 : 0; # $died now contains 0 eval { print $fh "o284028420384203842038f\n" }; $died = $@ ? 1 : 0; # $died now contains 1 EOF ex5 => <<'EOF', my $x = $ex5_data; # $x now contains $ex5_expect EOF ex6 => <<'EOF', my $died; eval { my $x = read $fh, $_, 1000; defined $x or die "read: $!" }; $died = $@ ? 1 : 0; # $died now contains 0 eval { my $x = read $fh, $_, 1_000_000; defined $x or die "read: $!" }; $died = $@ ? 1 : 0; # $died now contains 1 EOF ex7 => <<'EOF', my $died; my $block1 = "x" x 1000; my $block2 = "x" x 1_000_000; eval { print $fh $block1 or die "write: $!" }; $died = $@ ? 1 : 0; # $died now contains 0 eval { print $fh $block2 or die "write: $!" }; $died = $@ ? 1 : 0; # $died now contains 1 EOF ); my @test_name = qw/ex1 ex2 ex2a ex3 ex4 ex5 ex6 ex7/; my @test_code; my $test_count = @test_name; my %skip_example; my %example_needs = ( ex4 => 'use Digest::SHA', ex6 => 'use Errno qw/EIO/', ex7 => 'use Errno qw/ENOSPC/', ); foreach my $test (@test_name) { my $code_snippet = $snips->named($test)->as_data; $code_snippet or die "failed to extract $test from pod"; if ($example_needs{$test}) { eval $example_needs{$test}; if ($@) { $skip_example{$test} = 1; push @test_code, ''; next; } } if ($test eq "ex4") { $code_snippet = "use Digest::SHA;\n$code_snippet"; } $code_snippet .= "\n" . ($extra_code{$test}||''); push @test_code, snippet_to_testcode($test, $code_snippet, \$test_count); } plan tests => $test_count + 1; foreach my $i (0 .. $#test_name) { SKIP: { skip "can't $example_needs{$test_name[$i]}]", 1 if $skip_example{$test_name[$i]}; eval $test_code[$i]; my $err = $@ || ''; is( $err, '', "$test_name[$i] ran" ); }; } sub snippet_to_testcode { my ($name, $code, $count_ref) = @_; ++$$count_ref while $code =~ s/^\s*(.+?);\s*#\s*(.+?) now contains (.+?)\s*$/ $1 ; is_deeply([$2], [$3], q{$name $1 => $3});\n/m; $code =~ /now contains/i and die "failed to munge a 'now contains' in $name: $code"; return $code; } sub IO::Callback::Fake::prepare { my $self = shift; return $self; } sub IO::Callback::Fake::execute { if (@_ == 2) { # Example 5, storing stuff in a dbh. if (length $_[1] != 1024) { $ex5_had_lastblock++ and die "multiple runt blocks"; } $ex5_data .= $_[1]; } } sub IO::Callback::Fake::fetchrow_array { my $place = $fake_dbh_cycle++; $fake_dbh_cycle %= 4; if ($place == 0) { return qw/foo bar baz/; } elsif ($place == 1) { return qw/0/; } elsif ($place == 2) { return qw/0 1/; } else { return; } } # for example 4 sub store_fh { my $fh = shift; my ($buf, $got); do { $got = read $fh, $buf, 11; defined $got or die "read failed in ex4: $!"; } while $got; } # for example 5 sub IO::Callback::Fake::copy_data_out { my ($self, $fh) = @_; for (1 .. 10) { print $fh "qwerty7890" x 15; } close $fh; } IO-Callback-2.00/t/file-copy.t000444001750001750 340613722453414 14635 0ustar00taitai000000000000# IO::Callback 1.08 t/file-copy.t # Check that IO::Callback inter-operates with File::Copy use strict; use warnings; use Test::More; BEGIN { eval 'use File::Copy qw/copy/'; plan skip_all => 'File::Copy required' if $@; plan skip_all => 'File::Copy too old' if $File::Copy::VERSION < 2.11; plan tests => 8; } use Test::NoWarnings; use File::Slurp; use File::Temp qw/tempfile/; use Fatal qw/open close unlink/; use IO::Callback; our $test_nowarnings_hook = $SIG{__WARN__}; $SIG{__WARN__} = sub { my $warning = shift; return if $warning =~ /stat\(\) on unopened filehandle/i; $test_nowarnings_hook->($warning); }; my $test_data = "foo\n" x 100; my $line = 0; my $coderef_read_fh = IO::Callback->new('<', sub { return if $line++ >= 100; return "foo\n"; }); my $got_close = 0; my $got_data = ''; my $coderef_write_fh = IO::Callback->new('>', sub { my $buf = shift; if (length $buf) { $got_close and die "write after close"; $got_data .= $buf; } else { ++$got_close; } }); my ($tmp_fh, $tmp_file) = tempfile(); close $tmp_fh; unlink $tmp_file; ok copy($coderef_read_fh, $tmp_file), "copy coderef->realfile succeeded"; my $copy_got = read_file $tmp_file; is $copy_got, $test_data, "copy coderef->realfile copied correct data"; ok copy($tmp_file, $coderef_write_fh), "copy realfile->coderef succeeded"; close $coderef_write_fh; is $got_close, 1, "got close on fh"; is $got_data, $test_data, "copy realfile->coderef copied correct data"; my $die_fh = IO::Callback->new('>', sub { IO::Callback::Error }); is copy($tmp_file, $die_fh), 0, "copy gets write error"; unlink $tmp_file; $die_fh = IO::Callback->new('<', sub { IO::Callback::Error }); is copy($die_fh, $tmp_file), 0, "copy gets read error"; unlink $tmp_file; IO-Callback-2.00/t/io-compress-bzip2.t000444001750001750 323113722453414 16226 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/io-compress.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Check that IO::Callback inter-operates with IO::Compress::Bzip2 use strict; use warnings; use Test::More; BEGIN { eval 'use IO::Compress::Bzip2 qw/bzip2/'; plan skip_all => 'IO::Compress::Bzip2 required' if $@; eval 'use IO::Uncompress::Bunzip2 qw/bunzip2/'; plan skip_all => 'IO::Uncompress::Bunzip2 required' if $@; plan tests => 6; } use Test::NoWarnings; use Fatal qw/close/; use IO::Callback; sub is_zipped ($$;$) { my ($zgot, $want, $comment) = @_; my $got; bunzip2(\$zgot, \$got) or die "bunzip2 failed"; is( $got, $want, $comment ); } my $test_data = "foo\n" x 100; my $lines = 0; my $coderef_read_fh = IO::Callback->new('<', sub { return if $lines++ >= 100; return "foo\n"; }); my $compressed; ok bzip2($coderef_read_fh, \$compressed), "bzip2 from read coderef succeeded"; is_zipped $compressed, $test_data, "bzip2 from read coderef correct"; my $got_close = 0; my $got_data = ''; my $coderef_write_fh = IO::Callback->new('>', sub { my $buf = shift; if (length $buf) { $got_close and die "write after close"; $got_data .= $buf; } else { ++$got_close; } }); ok bzip2(\$test_data, $coderef_write_fh), "bzip2 to write coderef succeeded"; close $coderef_write_fh; is $got_close, 1, "write fh got close"; is_zipped $got_data, $test_data, "bzip2 to write coderef correct"; IO-Callback-2.00/t/io-compress-gzip.t000444001750001750 321213722453414 16150 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/io-compress.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Check that IO::Callback inter-operates with IO::Compress::Gzip use strict; use warnings; use Test::More; BEGIN { eval 'use IO::Compress::Gzip qw/gzip/'; plan skip_all => 'IO::Compress::Gzip required' if $@; eval 'use IO::Uncompress::Gunzip qw/gunzip/'; plan skip_all => 'IO::Uncompress::Gunzip required' if $@; plan tests => 6; } use Test::NoWarnings; use Fatal qw/close/; use IO::Callback; sub is_zipped ($$;$) { my ($zgot, $want, $comment) = @_; my $got; gunzip(\$zgot, \$got) or die "gunzip failed"; is( $got, $want, $comment ); } my $test_data = "foo\n" x 100; my $lines = 0; my $coderef_read_fh = IO::Callback->new('<', sub { return if $lines++ >= 100; return "foo\n"; }); my $compressed; ok gzip($coderef_read_fh, \$compressed), "gzip from read coderef succeeded"; is_zipped $compressed, $test_data, "gzip from read coderef correct"; my $got_close = 0; my $got_data = ''; my $coderef_write_fh = IO::Callback->new('>', sub { my $buf = shift; if (length $buf) { $got_close and die "write after close"; $got_data .= $buf; } else { ++$got_close; } }); ok gzip(\$test_data, $coderef_write_fh), "gzip to write coderef succeeded"; close $coderef_write_fh; is $got_close, 1, "write fh got close"; is_zipped $got_data, $test_data, "gzip to write coderef correct"; IO-Callback-2.00/t/io-compress.ttmpl000444001750001750 317613722453414 16107 0ustar00taitai000000000000<<< IF vary!!zip!!gzip,bzip2 == 'gzip'; unzip = 'gunzip'; modpkg = 'IO::Compress::Gzip'; modpkgu = 'IO::Uncompress::Gunzip'; ELSE; unzip = 'bunzip2'; modpkg = 'IO::Compress::Bzip2'; modpkgu = 'IO::Uncompress::Bunzip2'; END ->>> # Check that IO::Callback inter-operates with <<< modpkg >>> use strict; use warnings; use Test::More; BEGIN { eval 'use <<< modpkg >>> qw/<<< zip >>>/'; plan skip_all => '<<< modpkg >>> required' if $@; eval 'use <<< modpkgu >>> qw/<<< unzip >>>/'; plan skip_all => '<<< modpkgu >>> required' if $@; plan tests => 6; } use Test::NoWarnings; use Fatal qw/close/; use IO::Callback; sub is_zipped ($$;$) { my ($zgot, $want, $comment) = @_; my $got; <<< unzip >>>(\$zgot, \$got) or die "<<< unzip >>> failed"; is( $got, $want, $comment ); } my $test_data = "foo\n" x 100; my $lines = 0; my $coderef_read_fh = IO::Callback->new('<', sub { return if $lines++ >= 100; return "foo\n"; }); my $compressed; ok <<< zip >>>($coderef_read_fh, \$compressed), "<<< zip >>> from read coderef succeeded"; is_zipped $compressed, $test_data, "<<< zip >>> from read coderef correct"; my $got_close = 0; my $got_data = ''; my $coderef_write_fh = IO::Callback->new('>', sub { my $buf = shift; if (length $buf) { $got_close and die "write after close"; $got_data .= $buf; } else { ++$got_close; } }); ok <<< zip >>>(\$test_data, $coderef_write_fh), "<<< zip >>> to write coderef succeeded"; close $coderef_write_fh; is $got_close, 1, "write fh got close"; is_zipped $got_data, $test_data, "<<< zip >>> to write coderef correct"; IO-Callback-2.00/t/iostring-close.t000444001750001750 120113722453414 15676 0ustar00taitai000000000000# # IO::Callback 1.08 t/iostring-close.t # This is t/close.t from IO::String 1.08, adapted to IO::Callback. use strict; use warnings; use Test::More tests => 7; use Test::NoWarnings; use IO::Callback; my $str = "abcd"; my $eof = 0; my $destroyed = 0; { package MyStr; @MyStr::ISA = qw(IO::Callback); sub DESTROY { $destroyed++; } } my $rounds = 5; for (1..$rounds) { $eof = 0; my $io = MyStr->new("<", sub { return if $eof++; return $str }); is ( $io->getline, "abcd", "getline correct on round $_" ); $io->close; undef($io); } is( $destroyed, $rounds, "destructor called $rounds times" ); IO-Callback-2.00/t/iostring-para.t000444001750001750 154013722453414 15522 0ustar00taitai000000000000# IO::Callback 1.08 t/iostring-para.t # This is t/para.t from IO::String 1.08, adapted to IO::Callback. use strict; use warnings; use Test::More tests => 9; use Test::NoWarnings; use IO::Callback; my $fh; my $str; my $callback_state; sub reset_test { $str = shift; $callback_state = 0; $fh = IO::Callback->new("<", \&callback); } sub callback { if ($callback_state == 0) { $callback_state = 1; return $str; } elsif ($callback_state == 1) { $callback_state = 2; return; } else { die "callback called again after eof"; } } reset_test(<, "a\n\n"); is(<$fh>, "a\nb\n\n"); is(<$fh>, "a\nb\nc\n\n"); is(<$fh>, "a\nb\nc\nd\n"); is(<$fh>, undef); reset_test(<, "a\nb\n\n"); is(<$fh>, undef); is(<$fh>, undef); IO-Callback-2.00/t/iostring-read.t000444001750001750 524113722453414 15514 0ustar00taitai000000000000# IO::Callback 1.08 t/iostring-read.t # This is t/read.t from IO::String 1.08, adapted to IO::Callback. use strict; use warnings; use Test::More tests => 23; use Test::NoWarnings; use IO::Callback; my $str = <new('<', \&callback); } sub callback { defined $callback_pos or die "callback called again after returning eof"; if ($callback_pos < length $str) { my $oldpos = $callback_pos; $callback_pos = length $str; return substr $str, $oldpos; } else { undef $callback_pos; return; } } reset_test(); my @lines = <$io>; is_deeply( [@lines], ["This is an example\n","of a paragraph\n","\n","and a single line.\n","\n"], "read all lines" ); use vars qw(@tmp $buf); ok( ! defined ($io->getline), "$io->getline false after eof" ); ok( ! (@tmp = $io->getlines), "$io->getlines false after eof" ); ok( ! defined (<$io>), "<$io> false after eof" ); ok( ! defined ($io->getc), "$io->getc false after eof" ); ok( ! read($io, $buf, 100), "read $io false after eof" ); { local $/; # slurp mode reset_test(); @lines = $io->getlines; is_deeply( \@lines, [$str], "slurp got whole string" ); reset_test(index($str, "and")); my $line = <$io>; is( $line, "and a single line.\n\n", "slurp 2nd part of string" ); } { local $/ = ""; # paragraph mode reset_test(); @lines = <$io>; is_deeply( \@lines, ["This is an example\nof a paragraph\n\n", "and a single line.\n\n"], "para mode" ); } { local $/ = "is"; reset_test(); @lines = (); while (<$io>) { push(@lines, $_); } is_deeply( \@lines, ["This", " is", " an example\n" . "of a paragraph\n\n" . "and a single line.\n\n"], "getlines with \$/ = is" ); } # Test read reset_test(); is( read($io, $buf, 3), 3, "read returned 3" ); is( $buf, "Thi", "read got correct data" ); is( sysread($io, $buf, 3, 2), 3, "sysread returned 3" ); is( $buf, "Ths i", "sysread got correct data" ); reset_test(length($str) - 4); ok( ! $io->eof, "no eof with 4 bytes to go" ); is( read($io, $buf, 20), 4, "read got 4 bytes" ); is( $buf, "e.\n\n", "read got the final 4 bytes of the string" ); is( read($io, $buf, 20), 0, "read at eof returned 0" ); ok( $io->eof, "eof indicator set" ); reset_test(); is( read($io, $buf, 0), 0, "0 len read returned 0" ); is( read($io, $buf, 4), 4, "got 4 bytes after 0len read" ); is( $buf, "This", "got correct 4 bytes after 0len read" ); IO-Callback-2.00/t/iostring-write.t000444001750001750 155013722453414 15732 0ustar00taitai000000000000# IO::Callback 1.08 t/iostring-write.t # This is t/write.t from IO::String 1.08, adapted to IO::Callback. use strict; use warnings; use Test::More tests => 2; use Test::NoWarnings; use IO::Callback; my $str = ''; my $io = IO::Callback->new('>', sub { $str .= shift }); print $io "Heisan\n"; $io->print("a", "b", "c"); { local($\) = "\n"; print $io "d", "e"; local($,) = ","; print $io "f", "g", "h"; } my $foo = "1234567890"; syswrite($io, $foo, length($foo)); $io->syswrite($foo); $io->syswrite($foo, length($foo)); $io->write($foo, length($foo), 5); $io->write("xxx\n", 100, -1); for (1..3) { printf $io "i(%d)", $_; $io->printf("[%d]\n", $_); } select $io; print "\n"; is( $str, "Heisan\nabcde\nf,g,h\n" . ("1234567890" x 3) . "67890\n" . "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n", 'data written to $str as expected' ); IO-Callback-2.00/t/misc.t000444001750001750 133013722453414 13673 0ustar00taitai000000000000# IO::Callback 1.08 t/misc.t # Check that IO::Callback is consistent with real files in a few misc places. use strict; use warnings; use Test::More tests => 9; use Test::NoWarnings; use IO::Callback; use IO::Handle; use File::Temp qw/tempdir/; our $tmpfile = tempdir(CLEANUP => 1) . "/testfile"; foreach my $rw ('>', '<') { foreach my $close_it (0, 1) { my $ioc_fh = IO::Callback->new($rw, sub {}); open my $real_fh, $rw, $tmpfile or die "open: $!"; if ($close_it) { close $ioc_fh; close $real_fh; } foreach my $method (qw/opened error/) { is $ioc_fh->$method, $real_fh->$method, "$method consistent with perl ($close_it)"; } } } IO-Callback-2.00/t/pod.t000444001750001750 35013722453414 13503 0ustar00taitai000000000000#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); IO-Callback-2.00/t/read-sha.t000444001750001750 131313722453414 14425 0ustar00taitai000000000000# IO::Callback 1.08 t/read-sha.t # Check that IO::Callback inter-operates with Digest::SHA use strict; use warnings; use Test::More; BEGIN { eval 'use Digest::SHA'; plan skip_all => 'Digest::SHA required' if $@; plan skip_all => "Bad Digest::SHA" if Digest::SHA->VERSION eq '5.89' || Digest::SHA->VERSION eq '5.90'; plan tests => 2; } use Test::NoWarnings; use IO::Callback; my $block = "foo\n" x 1000; my $lines = 0; my $fh = IO::Callback->new('<', sub { return if $lines++ >= 1000; return $block; }); my $digest = Digest::SHA->new(256)->addfile($fh)->hexdigest; is( $digest, "df1c1217e3256c67362044595cfe27918f43b25287721174c96726c078e3ecbe", "digest as expected" ); IO-Callback-2.00/t/read-variations.inc000444001750001750 1540613722453414 16367 0ustar00taitai000000000000 # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. use strict; use warnings; our $seglen; use Test::More; BEGIN { unless ($ENV{EXTENDED_TESTING}) { plan skip_all => "EXTENDED_TESTING environment variable not set", } plan tests => 99145; } use Test::NoWarnings; use IO::Callback; use IO::Handle; use File::Temp qw/tempdir/; use File::Slurp; use Fatal qw/open close/; use Fcntl 'SEEK_CUR'; our $testfile = tempdir(CLEANUP => 1) . "/testfile"; our %tell_result_sequence; our %lno_result_sequence; our $start_lineno = 999999; if ($] >= 5.008000 and $] < 5.008009) { # $. sometimes gets 0ed at the tie() in IO::String::new() under # these perls, start with $. set to 0 to avoid test failures. $start_lineno = 0; } # the block size for the coderef to serve up data my @test_block_sizes = (1, 2, 3, 10, 1_000_000); my %data_strings = ( empty => '', 0 => '0', 1 => '1', newline => "\n", newline2 => "\n\n", newline3 => "\n\n\n", null => "\0", foo => "foo", foon => "foo\n", foobar => "foo\nbar", foobarn => "foo\nbar\n", para2 => "hello\n\n", para22 => "\n\nhello\n\n", para3 => "hello\n\n\n", para33 => "\n\n\nhello\n\n\n", para323 => "\n\n\nfoo\n\nbar\nbaz\n\n\n", allbytes => join('', map {chr} (0..255)), ); our $use_sysread; our $do_ungetc; foreach $use_sysread (0, 1) { foreach $do_ungetc (0, 1) { next if $use_sysread and $do_ungetc; my @readcode = build_read_code($use_sysread, \@test_block_sizes); foreach my $str (keys %data_strings) { write_file $testfile, $data_strings{$str}; foreach my $readcode1 (@readcode) { foreach my $readcode2 (@readcode) { run_test($str, $testfile, $seglen, $readcode1, $readcode2); } } } } } sub run_test { my ($str, $file_holding_str, $seglen, @readcode) = @_; my $srccode = join "::", map {$_->{SrcCode}} @readcode; my $para_mode_used = grep {$_->{ParaMode}} @readcode; my $testname = "$srccode $str $seglen/$do_ungetc"; my $segs = segment_input($data_strings{$str}, $seglen); $. = $start_lineno; my $fh = IO::Callback->new('<', \&readsub, $segs); my $got_via_io_coderef = do_test_reads($fh, 1, map {$_->{CodeRef}} @readcode); # Use a real file to determine what the results should be with this combination # of read ops. $. = $start_lineno; open my $real_fh, "<", $file_holding_str; my $got_via_realfile = do_test_reads($real_fh, 0, map {$_->{CodeRef}} @readcode); is $got_via_io_coderef, $got_via_realfile, "$testname matched real file results"; is $tell_result_sequence{1}, $tell_result_sequence{0}, "$testname tell() matched real file results"; is $lno_result_sequence{1}, $lno_result_sequence{0}, "$testname input_line_number() matched real file results"; # In paragraph mode newlines can be discarded, otherwise the output should # match the input exactly. unless (grep {$_->{ParaMode}} @readcode) { is $got_via_io_coderef, $data_strings{$str}, "$testname recreated input"; } } sub systell { my $ret = sysseek($_[0], 0, SEEK_CUR); return 0 if $ret eq "0 but true"; return $ret; } sub do_test_reads { my ($fh, $is_io_coderef, @coderefs) = @_; # tell() won't work on the real file if I've used sysread on it, use sysseek to emulate it in that case. my $mytell = $use_sysread && ! $is_io_coderef ? \&systell : sub { tell $_[0] }; # Use each read mechanism in turn, repeating the last until EOF. my $dest = ''; my @lno = ($fh->input_line_number . "-" . $.); my @tell = ($mytell->($fh)); push @lno, ($fh->input_line_number . "-" . $.); # verify tell-sets-$. behavior my $go = 1; while ($go and @coderefs > 1) { my $code = shift @coderefs; $code->($fh, \$dest) or $go = 0; push @lno, $fh->input_line_number . "-" . $.; push @tell, $mytell->($fh); if ($go and length $dest and $do_ungetc) { $fh->ungetc( ord(substr $dest, -1, 1, '') ); push @lno, $fh->input_line_number . "-" . $.; push @tell, $mytell->($fh); } } while ($go and $coderefs[0]->($fh, \$dest)) { push @lno, $fh->input_line_number . "-" . $.; push @tell, $mytell->($fh); } push @lno, $fh->input_line_number . "-" . $.; push @tell, $mytell->($fh); push @lno, $fh->input_line_number . "-" . $.; $tell_result_sequence{$is_io_coderef} = join ",", @tell; $lno_result_sequence{$is_io_coderef} = join ",", @lno; return $dest; } sub readsub { my $segs = shift; return unless @$segs; return shift @$segs; } sub segment_input { my ($str, $seglen) = @_; my @seg; while (length $str) { push @seg, substr $str, 0, $seglen, ''; } return \@seg; } sub build_read_code { my ($use_sysread, $block_sizes) = @_; my $read = $use_sysread ? 'sysread' : 'read'; my @readcode; unless ($use_sysread) { my @linewise_readcode = ( '$_ = <$fh>; return unless defined; $$dest .= $_', '$_ = $fh->getline; return unless defined; $$dest .= $_', '$$dest .= join "", <$fh>; return', '$$dest .= join "", $fh->getlines; return', ); @readcode = map( { {SrcCode => $_} } @linewise_readcode, map ({'local $/; '.$_} @linewise_readcode), map ({'local $/="oo"; '.$_} @linewise_readcode), '$_ = $fh->getc; return unless defined; $$dest .= $_', ); push @readcode, map { {SrcCode => "local \$/=''; $_", ParaMode => 1} } @linewise_readcode; } my $readcall_template = <<'ENDCODE'; my $got = __READCALL__; unless (defined $got) { $$dest = "*** FAIL: __READ__ returned undef ***"; return; } $got or return; $$dest .= $_; ENDCODE $readcall_template =~ s/__READ__/$read/g; foreach my $blocksize (@$block_sizes) { foreach my $readcall ("$read \$fh, \$_, $blocksize", "\$fh->$read(\$_, $blocksize)") { my $fullcode = $readcall_template; $fullcode =~ s/__READCALL__/$readcall/g; push @readcode, {SrcCode => $readcall, FullSrcCode => $fullcode}; } } foreach my $rc (@readcode) { $rc->{FullSrcCode} ||= $rc->{SrcCode}; my $src = "sub { my (\$fh, \$dest) = \@_ ; $rc->{FullSrcCode} ; return 1 }"; $rc->{CodeRef} = eval $src; die "eval [$src]: $@" if $@; } return @readcode; } 1; IO-Callback-2.00/t/stat.t000444001750001750 35313722453414 13677 0ustar00taitai000000000000use strict; use warnings FATAL => 'all'; use Test::More tests => 1; use IO::Callback; my $count = 0; my $fh = 'IO::Callback'->new( '<', sub { return if ++$count > 10; return "foo\n"; }, [] ); my @stat = $fh->stat; is $stat[7], 0; IO-Callback-2.00/t/sysread-params.t000444001750001750 576013722453414 15706 0ustar00taitai000000000000# IO::Callback 1.08 t/sysread-params.t # Check that IO::Callback's sysread() accurately emulates Perl's sysread(), # particularly in terms of parameter validation. use strict; use warnings; use Test::More; use Test::NoWarnings; use IO::Callback; use File::Slurp; use File::Temp qw/tempdir/; use Fatal qw/open close/; our $test_nowarnings_hook = $SIG{__WARN__}; $SIG{__WARN__} = sub { my $warning = shift; return if $warning =~ /^Use of uninitialized value (?:\$(?:len|offset) )?in sysread/i; $test_nowarnings_hook->($warning); }; our $tmpfile = tempdir(CLEANUP => 1) . "/testfile"; my @input_len_values = (0, 1, 2, 3); # size of input file my @buf_len_values = (0, 1, 2, 3, 10); # initial size of target buffer my @len_values = (-1, 0, 1, 2, 3, 10, undef); # length param to sysread my @offset_values = (-1, -2, -3, -10, 0, 1, 2, 3, 10, undef); # offset param to sysread plan tests => 6 * @input_len_values * @buf_len_values * @len_values * @offset_values + 1; foreach my $input_len (@input_len_values) { my $input = substr 'qwerty123456789', 0, $input_len; write_file $tmpfile, $input; foreach my $buflen (@buf_len_values) { foreach my $include_undef_params (0, 1) { foreach my $len (@len_values) { foreach my $offset (@offset_values) { my $test_name = test_name($input_len, $buflen, $include_undef_params, $len, $offset); my $save_input = $input; open my $real_fh, "<", $tmpfile; my $iocode_fh = IO::Callback->new('<', sub {shift @{$_[0]}}, [$input, '']); my @results; foreach my $fh ($iocode_fh, $real_fh) { my $ret; my $buf = substr 'QWERTYasdfghjkl', 0, $buflen; if ($include_undef_params or defined $offset) { eval { $ret = sysread $fh, $buf, $len, $offset }; } else { eval { $ret = sysread $fh, $buf, $len }; } if ($@) { $@ =~ s/(line \d+)\./$1/; push @results, "died: $@, buf {$buf}"; } else { defined $ret or $ret = '**undef**'; push @results, "returned: $ret, buf {$buf}"; } } my ($got, $want) = @results; is $got, $want, "$test_name results same as real file"; is $iocode_fh->error, $real_fh->error, "error flag same as real file"; is $input, $save_input, "$test_name left input buffer unchanged"; } } } } } sub test_name { my ($inlen, $buflen, $include_undef, $len, $offset) = @_; defined $len or $len = 'undef'; defined $offset or $offset = 'undef'; return "il=$inlen bl=$buflen iu=$include_undef len=$len offset=$offset"; } IO-Callback-2.00/t/syswrite-params.t000444001750001750 616213722453414 16122 0ustar00taitai000000000000# IO::Callback 1.08 t/syswrite-params.t # Check that IO::Callback's syswrite() accurately emulates Perl's syswrite(), # particularly in terms of parameter validation. use strict; use warnings; use Test::More; use Test::NoWarnings; use IO::Callback; use File::Slurp; use File::Temp qw/tempdir/; use Fatal qw/open close/; our $test_nowarnings_hook = $SIG{__WARN__}; $SIG{__WARN__} = sub { my $warning = shift; return if $warning =~ /^Use of uninitialized value (?:\$(?:len|offset) )?in syswrite/i; $test_nowarnings_hook->($warning); }; our $tmpfile = tempdir(CLEANUP => 1) . "/testfile"; my $input_data = 'qwerty'; my @input_len_values = (0, 1, 2, 3); my @len_values = (-1, 0, 1, 2, 3, 10, undef); my @offset_values = (-1, -2, -3, -10, 0, 1, 2, 3, 10, undef); plan tests => 6 * @input_len_values * @len_values * @offset_values + 1; foreach my $include_undef_params (0, 1) { foreach my $input_len (@input_len_values) { foreach my $len (@len_values) { foreach my $offset (@offset_values) { my $test_name = join ",", map {defined() ? $_ : 'undef'} ($include_undef_params, $input_len, $len, $offset); my $input = substr 'qwerty0987654321', 0, $input_len; my $save_input = $input; my $got_contents = ''; open my $real_fh, ">", $tmpfile; my $iocode_fh = IO::Callback->new('>', sub {$got_contents .= shift}); my @results; foreach my $fh ($iocode_fh, $real_fh) { if ($fh eq $real_fh and $input_len == 0 and defined $offset and $offset > 0) { # perl bug #67912 push @results, 'died'; next; } my $ret; if ($include_undef_params or defined $offset) { eval { $ret = syswrite $fh, $input, $len, $offset }; } elsif (defined $len) { eval { $ret = syswrite $fh, $input, $len }; } else { eval { $ret = syswrite $fh, $input }; } if ($@) { push @results, "died: $@"; } else { defined $ret or $ret = '**undef**'; push @results, "returned: $ret"; } if ($fh eq $iocode_fh) { is( $input, $save_input, "$test_name left input unchanged" ); } } my ($got, $want) = @results; $want =~ s/\.$//; if ($want eq 'died' and $got =~ /^died/) { $got = 'died'; } if ($got =~ /\.$/ and $want !~ /\.$/) { chomp $want; $want .= ".\n"; } is( $got, $want, "$test_name results same as real file" ); my $want_contents = read_file $tmpfile; is( $got_contents, $want_contents, "$test_name data written same as real file" ); } } } } IO-Callback-2.00/t/write-close.t000444001750001750 167013722453414 15204 0ustar00taitai000000000000# IO::Callback 1.08 t/write-close.t # Check that IO::Callback deals correctly with the close of a write filehandle, # calling the callback with an empty argument. use strict; use warnings; use Test::More; use Test::NoWarnings; use IO::Callback; my @close_code = ( 'close $fh', '$fh->close', 'close $fh ; close $fh', 'close $fh ; undef $fh', ); my @write_data_sets = ( [], ['q'], ['Q','W'], ); plan tests => @close_code * @write_data_sets + 1; foreach my $write_data_set (@write_data_sets) { my $want = join ',', map {"{$_}"} @$write_data_set, ''; foreach my $close_code (@close_code) { my @write; my $fh = IO::Callback->new('>', sub { push @write, shift }); foreach my $write_data (@$write_data_set) { print $fh $write_data; } eval $close_code; die $@ if $@; is( join(',', map {"{$_}"} @write), $want, "$want $close_code ok" ); } } IO-Callback-2.00/t/wrongway-ebadf.t000444001750001750 427113722453414 15663 0ustar00taitai000000000000# IO::Callback 1.08 t/wrongway-ebadf.t # Check that reads on write filehandles (and visa versa) give EBADF errors, same as real files. use strict; use warnings; use Test::More; BEGIN { eval 'use Errno qw/EBADF/'; plan skip_all => 'Errno qw/EBADF/ required' if $@; } use Test::NoWarnings; use IO::Callback; # some bits of code for reading/writing the fh my @code_bits = grep {/\S/} split /\n/, <<'EOF'; R $_ = <$fh> R $_ = $fh->getline R my @foo = <$fh> R my @foo = $fh->getlines R $_ = $fh->getc R $_ = $fh->ungetc(123) R my $x ; $_ = read $fh, $x, 1024 R my $x; $_ = sysread $fh, $x, 1024 W $_ = $fh->print(4) W $_ = print $fh 4 W $_ = $fh->printf(4) W $_ = printf $fh 4 W $_ = syswrite $fh, "asdfsadf", 3 EOF plan tests => 4 * @code_bits + 1; use vars qw/$fh/; # The tests to run with a read-only fh as $fh (checking that read ops # work and write ops fail with EBADF) as an array of coderefs. my @try_on_read_fh; # The tests to run with a write-only fh as $fh (checking that write ops # work and read ops fail with EBADF) as an array of coderefs. my @try_on_write_fh; foreach my $code_bit (@code_bits) { $code_bit =~ s/^([RW])\s*// or die $code_bit; my $type = $1; my $code = $code_bit; $code .= '; '; if ($code =~ /\@foo/) { $code .= 'my $no_error = @foo;'; } else { $code .= 'my $no_error = defined $_;'; } my $ok_sub = eval <error, "error flag set"; } EOF if ($type eq "R") { push @try_on_read_fh, $ok_sub; push @try_on_write_fh, $notok_sub; } else { push @try_on_read_fh, $notok_sub; push @try_on_write_fh, $ok_sub; } } foreach my $sub (@try_on_read_fh) { my @blocks = ("foo\nbar\n"); $fh = IO::Callback->new('<', sub {shift @blocks}); $sub->(); } foreach my $sub (@try_on_write_fh) { $fh = IO::Callback->new('>', sub {}); $sub->(); } IO-Callback-2.00/t/z5-write-variations.t000444001750001750 1252713722453414 16635 0ustar00taitai000000000000# IO::Callback 1.08 t/z5-write-variations.t # Try many combinations of write operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. use strict; use warnings; use Test::More; BEGIN { # On some systems this test can take hours, I suspect sync on file # close. if ($ENV{EXTENDED_TESTING}) { plan 'no_plan'; } else { plan skip_all => 'EXTENDED_TESTING environment variable not set'; } } require Test::NoWarnings; our $test_nowarnings_hook = $SIG{__WARN__}; $SIG{__WARN__} = sub { my $warning = shift; return if $] < 5.008 and $warning =~ /Use of uninitialized value in scalar assignment/; $test_nowarnings_hook->($warning); }; use IO::Callback; use IO::Handle; use File::Temp qw/tempdir/; use Fcntl 'SEEK_CUR'; use File::Slurp; use Fatal qw/open close/; our $test_write_dest; our %tell_result_sequence; our $failure_message; our $test_srccode; our $tmpfile = tempdir(CLEANUP => 1) . "/testfile"; our $tests_started_at = time(); our $use_syswrite; foreach $use_syswrite (0, 1) { my @writecode = build_write_code($use_syswrite); foreach my $writecode1 (@writecode) { foreach my $writecode2 (@writecode) { run_test($writecode1, $writecode2); } } } Test::NoWarnings::had_no_warnings(); done_testing(); sub run_test { my (@writecode) = @_; $test_srccode = join "::", map {$_->{SrcCode}} @writecode; $. = 999999; my $fh = IO::Callback->new('>', \&writesub); local $test_write_dest = ''; do_test_writes($fh, 1, map {$_->{CodeRef}} @writecode); my $got = $test_write_dest; if ($failure_message) { fail("$test_srccode test bailed: iocode write: $failure_message"); undef $failure_message; return; } # Check that the results are correct by applying the same sequence of # writes to a real file and comparing. $. = 999999; $fh = IO::Callback->new('>', \&writesub); open my $ref_fh, ">", $tmpfile; do_test_writes($ref_fh, 0, map {$_->{CodeRef}} @writecode); close $ref_fh; my $want = read_file $tmpfile; if ($failure_message) { fail("$test_srccode test bailed: real write: $failure_message"); undef $failure_message; return; } is( $got, $want, "$test_srccode data matched real file results" ); is( $tell_result_sequence{1}, $tell_result_sequence{0}, "$test_srccode tell() values matched real file results" ); } sub systell { my $ret = sysseek($_[0], 0, SEEK_CUR); return 0 if $ret eq "0 but true"; return $ret; } sub do_test_writes { my ($fh, $is_io_coderef, @coderefs) = @_; # tell() won't work on the real file if I've used syswrite on it, use sysseek to emulate it in that case. my $mytell = $use_syswrite && ! $is_io_coderef ? \&systell : sub { tell $_[0] }; my @tell = ($mytell->($fh)); foreach my $code (@coderefs) { $code->($fh); push @tell, $mytell->($fh); } $tell_result_sequence{$is_io_coderef} = join ",", @tell; } sub writesub { $test_write_dest .= $_[0]; } sub build_write_code { my ($use_syswrite) = @_; my @writecode; if ($use_syswrite) { my $writecall_template = <<'ENDCODE'; my $wrote = eval { __WRITECALL__ }; if ($@) { $failure_message = "died within test: $@"; } elsif (not defined $wrote) { $failure_message = "syswrite returned undef"; } ENDCODE my @write_src_code = ( 'syswrite $fh, ""', 'syswrite $fh, "", 0', 'syswrite $fh, "", 0, 0', 'syswrite $fh, "123456", 0, 5', 'syswrite $fh, "0"', 'syswrite $fh, "abcdefg"', 'syswrite $fh, "ABCDEFG", 2', 'syswrite $fh, "qwertyz", 2, 2', 'syswrite $fh, "QWERTYZ", 0, 2', 'syswrite $fh, "QWERTYZ", 0, -2', 'syswrite $fh, "fobabz8", 2, -4', ); foreach my $short_code (@write_src_code) { my $long_code = $writecall_template; $long_code =~ s/__WRITECALL__/$short_code/; push @writecode, { SrcCode => $short_code, FullSrcCode => $long_code, }; } } else { my @src_code; my @printf_argsets = ( q{''}, q{'%s', ''}, q{'%s', 'foo'}, q{'%s', 0}, q{0}, ); foreach my $as (@printf_argsets) { push @src_code, "printf \$fh $as", "\$fh->printf($as)"; } my @print_argsets = ( q{''}, q{'', ''}, q{0}, q{0, 0}, q{'foo', '', 'bar'}, ); foreach my $ors ('undef', "''", 0, "'foo'") { foreach my $ofs ('undef', "''", 0, "'bar'") { my $prefix = "local \$\\=$ors; local \$,=$ofs;"; foreach my $as (@print_argsets) { push @src_code, "$prefix print \$fh $as", "$prefix \$fh->print($as)"; } } } @writecode = map { {SrcCode => $_} } @src_code; } foreach my $wc (@writecode) { $wc->{FullSrcCode} ||= $wc->{SrcCode}; my $src = "sub { my \$fh = shift; $wc->{FullSrcCode} }"; $wc->{CodeRef} = eval $src; die "eval [$src]: $@" if $@; } return @writecode; } IO-Callback-2.00/t/z9-read-variations-1.t000444001750001750 132413722453414 16531 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/z9-read-variations.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use strict; use warnings; # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. our $seglen; $seglen = 1; use lib 't'; require 'read-variations.inc'; IO-Callback-2.00/t/z9-read-variations-10.t000444001750001750 132513722453414 16612 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/z9-read-variations.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use strict; use warnings; # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. our $seglen; $seglen = 10; use lib 't'; require 'read-variations.inc'; IO-Callback-2.00/t/z9-read-variations-1_000_000.t000444001750001750 133413722453414 17470 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/z9-read-variations.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use strict; use warnings; # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. our $seglen; $seglen = 1_000_000; use lib 't'; require 'read-variations.inc'; IO-Callback-2.00/t/z9-read-variations-2.t000444001750001750 132413722453414 16532 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/z9-read-variations.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use strict; use warnings; # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. our $seglen; $seglen = 2; use lib 't'; require 'read-variations.inc'; IO-Callback-2.00/t/z9-read-variations-3.t000444001750001750 132413722453414 16533 0ustar00taitai000000000000# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # # This file was automatically built from t/z9-read-variations.ttmpl # # Do not edit this file, instead edit the template and rebuild by running # t/build-test-scripts # # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use strict; use warnings; # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. our $seglen; $seglen = 3; use lib 't'; require 'read-variations.inc'; IO-Callback-2.00/t/z9-read-variations.ttmpl000444001750001750 67213722453414 17255 0ustar00taitai000000000000use strict; use warnings; # Try many combinations of read operations on an IO::Callback, checking that each # gives exactly the same results as Perl does for a real file. # This test is split into several .t files (one for each $seglen value), since the # large number of tests uses too much memory if run as a single .t file. our $seglen; $seglen = <<< vary!!seglen!!1,2,3,10,1_000_000 >>>; use lib 't'; require 'read-variations.inc';