Hello community,
here is the log from the commit of package perl-File-Slurp for openSUSE:Factory
checked in at 2019-02-25 17:46:03
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/perl-File-Slurp (Old)
and /work/SRC/openSUSE:Factory/.perl-File-Slurp.new.28833 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-File-Slurp"
Mon Feb 25 17:46:03 2019 rev:23 rq:676043 version:9999.26
Changes:
--------
--- /work/SRC/openSUSE:Factory/perl-File-Slurp/perl-File-Slurp.changes
2018-12-08 11:19:46.782873266 +0100
+++
/work/SRC/openSUSE:Factory/.perl-File-Slurp.new.28833/perl-File-Slurp.changes
2019-02-25 17:46:05.198889530 +0100
@@ -1,0 +2,6 @@
+Thu Feb 14 06:09:36 UTC 2019 - Stephan Kulow <[email protected]>
+
+- updated to 9999.26
+ see /usr/share/doc/packages/perl-File-Slurp/Changes
+
+-------------------------------------------------------------------
Old:
----
File-Slurp-9999.25.tar.gz
New:
----
File-Slurp-9999.26.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ perl-File-Slurp.spec ++++++
--- /var/tmp/diff_new_pack.jIkKWh/_old 2019-02-25 17:46:05.842889265 +0100
+++ /var/tmp/diff_new_pack.jIkKWh/_new 2019-02-25 17:46:05.846889264 +0100
@@ -1,7 +1,7 @@
#
# spec file for package perl-File-Slurp
#
-# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2019 SUSE LINUX GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -17,7 +17,7 @@
Name: perl-File-Slurp
-Version: 9999.25
+Version: 9999.26
Release: 0
%define cpan_name File-Slurp
Summary: Perl module for reading/writing/modifying complete files
++++++ File-Slurp-9999.25.tar.gz -> File-Slurp-9999.26.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/Changes
new/File-Slurp-9999.26/Changes
--- old/File-Slurp-9999.25/Changes 2018-11-16 17:07:49.000000000 +0100
+++ new/File-Slurp-9999.26/Changes 2019-02-13 17:13:50.000000000 +0100
@@ -1,6 +1,20 @@
Revision history File::Slurp
-9999.25 2018-10-29
+9999.26 2019-02-13
+ - Reduce the size of handle.t to prevent failures on systems with limits
set
+ - Skip all tests in the suite that relied on overriding syswrite to test
+ failure mechanisms as CORE::print cannot be overridden.
+ - Refactor write_file to use print rather than syswrite.
+ - When performing an atomic write, make sure we find a good temporary
file
+ so that we don't accidentally overwrite a file that may already exist
in
+ the working directory.
+ - Stop re-working the line endings on write_file when on Windows as the
use
+ of print now allows layers to provide that functionality.
+ - Add File::Basename, File::Spec, File::Temp, and IO::Handle to the runtime
+ prereqs. These were already testing prereqs and are core.
+ - Perl 5.30 compliance is complete at this point.
+
+9999.25 2018-11-16
- The previous release contained nothing but a documentation update. That
updated documentation errantly mentioned pseudo-files. Pseudo-files
are perfectly fine to use with File::Slurp.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/META.json
new/File-Slurp-9999.26/META.json
--- old/File-Slurp-9999.25/META.json 2018-11-16 17:08:54.000000000 +0100
+++ new/File-Slurp-9999.26/META.json 2019-02-13 17:34:02.000000000 +0100
@@ -38,6 +38,10 @@
"Errno" : "0",
"Exporter" : "5.57",
"Fcntl" : "0",
+ "File::Basename" : "0",
+ "File::Spec" : "3.01",
+ "File::Temp" : "0",
+ "IO::Handle" : "0",
"POSIX" : "0",
"strict" : "0",
"warnings" : "0"
@@ -71,7 +75,7 @@
"web" : "https://github.com/perhunter/slurp";
}
},
- "version" : "9999.25",
+ "version" : "9999.26",
"x_contributors" : [
"Aristotle Pagaltzis <[email protected]>",
"Chase Whitener <[email protected]>",
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/META.yml
new/File-Slurp-9999.26/META.yml
--- old/File-Slurp-9999.25/META.yml 2018-11-16 17:08:53.000000000 +0100
+++ new/File-Slurp-9999.26/META.yml 2019-02-13 17:34:02.000000000 +0100
@@ -39,12 +39,16 @@
Errno: '0'
Exporter: '5.57'
Fcntl: '0'
+ File::Basename: '0'
+ File::Spec: '3.01'
+ File::Temp: '0'
+ IO::Handle: '0'
POSIX: '0'
strict: '0'
warnings: '0'
resources:
repository: https://github.com/perhunter/slurp.git
-version: '9999.25'
+version: '9999.26'
x_contributors:
- 'Aristotle Pagaltzis <[email protected]>'
- 'Chase Whitener <[email protected]>'
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/Makefile.PL
new/File-Slurp-9999.26/Makefile.PL
--- old/File-Slurp-9999.25/Makefile.PL 2018-10-17 01:42:44.000000000 +0200
+++ new/File-Slurp-9999.26/Makefile.PL 2019-02-13 17:06:53.000000000 +0100
@@ -41,6 +41,10 @@
'Exporter' => '5.57',
'Errno' => 0,
'Fcntl' => 0,
+ "File::Basename" => 0,
+ "File::Spec" => '3.01',
+ "File::Temp" => 0,
+ "IO::Handle" => 0,
'POSIX' => 0,
"strict" => 0,
"warnings" => 0,
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/lib/File/Slurp.pm
new/File-Slurp-9999.26/lib/File/Slurp.pm
--- old/File-Slurp-9999.25/lib/File/Slurp.pm 2018-11-16 17:06:32.000000000
+0100
+++ new/File-Slurp-9999.26/lib/File/Slurp.pm 2019-02-13 17:06:53.000000000
+0100
@@ -3,13 +3,16 @@
use strict;
use warnings ;
-our $VERSION = '9999.25';
+our $VERSION = '9999.26';
$VERSION = eval $VERSION;
use Carp ;
use Exporter qw(import);
use Fcntl qw( :DEFAULT ) ;
+use File::Basename ();
use File::Spec;
+use File::Temp qw(tempfile);
+use IO::Handle ();
use POSIX qw( :fcntl_h ) ;
use Errno ;
@@ -222,192 +225,115 @@
return ;
}
-
*wf = \&write_file ;
sub write_file {
+ my $file_name = shift;
+ my $opts = (ref $_[0] eq 'HASH') ? shift : {};
+ # options we care about:
+ # append atomic binmode buf_ref err_mode no_clobber perms
- my $file_name = shift ;
-
-# get the optional argument hash ref from @_ or an empty hash ref.
-
- my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;
-
- my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;
-
-# get the buffer ref - it depends on how the data is passed into write_file
-# after this if/else $buf_ref will have a scalar ref to the data.
-
- if ( ref $opts->{'buf_ref'} eq 'SCALAR' ) {
-
-# a scalar ref passed in %opts has the data
-# note that the data was passed by ref
-
- $buf_ref = $opts->{'buf_ref'} ;
- $data_is_ref = 1 ;
- }
- elsif ( ref $_[0] eq 'SCALAR' ) {
-
-# the first value in @_ is the scalar ref to the data
-# note that the data was passed by ref
-
- $buf_ref = shift ;
- $data_is_ref = 1 ;
- }
- elsif ( ref $_[0] eq 'ARRAY' ) {
-
-# the first value in @_ is the array ref to the data so join it.
-
- ${$buf_ref} = join '', @{$_[0]} ;
- }
- else {
-
-# good old @_ has all the data so join it.
-
- ${$buf_ref} = join '', @_ ;
- }
-
-# deal with ref for a file name
-
- if ( ref $file_name ) {
-
- my $ref_result = _check_ref( $file_name ) ;
-
- if ( ref $ref_result ) {
-
-# we got an error, deal with it
-
- @_ = ( $opts, $ref_result ) ;
- goto &_error ;
+ my $fh;
+ my $no_truncate = 0;
+ my $orig_filename;
+ # let's see if we have a stringified object or some sort of handle
+ # or globref before doing anything else
+ if (ref($file_name)) {
+ my $ref_result = _check_ref($file_name, $opts);
+ if (ref($ref_result)) {
+ # some error happened while checking for a ref
+ @_ = ($opts, $ref_result);
+ goto &_error;
}
-
- if ( $ref_result ) {
-
-# we got an overloaded object and the result is the stringified value
-# use it as the file name
-
- $file_name = $ref_result ;
+ if ($ref_result) {
+ # we have now stringified $file_name from the
overloaded obj
+ $file_name = $ref_result;
}
else {
-
-# we now have a proper handle ref.
-# make sure we don't call truncate on it.
-
- $write_fh = $file_name ;
- $no_truncate = 1 ;
+ # we now have a proper handle ref
+ # make sure we don't call truncate on it
+ $fh = $file_name;
+ $no_truncate = 1;
+ # can't do atomic or permissions on a file handle
+ delete $opts->{atomic};
+ delete $opts->{perms};
}
}
-# see if we have a path we need to open
-
- unless( $write_fh ) {
-
-# spew to regular file.
-
- if ( $opts->{'atomic'} ) {
-
-# in atomic mode, we spew to a temp file so make one and save the original
-# file name.
- $orig_file_name = $file_name ;
- $file_name .= ".$$" ;
+ # open the file for writing if we were given a filename
+ unless ($fh) {
+ $orig_filename = $file_name;
+ my $perms = defined($opts->{perms}) ? $opts->{perms} : 0666;
+ # set the mode for the sysopen
+ my $mode = O_WRONLY | O_CREAT;
+ $mode |= O_APPEND if $opts->{append};
+ $mode |= O_EXCL if $opts->{no_clobber};
+ if ($opts->{atomic}) {
+ # in an atomic write, we must open a new file in the
same directory
+ # as the original to account for ACLs. We must also set
the new file
+ # to the same permissions as the original unless
overridden by the
+ # caller's request to set a specified permission set.
+ my $dir =
File::Spec->rel2abs(File::Basename::dirname($file_name));
+ if (!defined($opts->{perms}) && -e $file_name && -f _) {
+ $perms = 07777 & (stat $file_name)[2];
+ }
+ # we must ensure we're using a good temporary filename
(doesn't already
+ # exist). This is slower, but safer.
+ (undef, $file_name) = tempfile('tempXXXXX', DIR =>
$dir, OPEN => 0);
}
-
-# set the mode for the sysopen
-
- my $mode = O_WRONLY | O_CREAT ;
- $mode |= O_APPEND if $opts->{'append'} ;
- $mode |= O_EXCL if $opts->{'no_clobber'} ;
-
- my $perms = $opts->{perms} ;
- $perms = 0666 unless defined $perms ;
-
-#printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;
-
-# open the file and handle any error.
-
- $write_fh = local( *FH ) ;
-# $write_fh = gensym ;
- unless ( sysopen( $write_fh, $file_name, $mode, $perms ) ) {
-
- @_ = ( $opts, "write_file '$file_name' - sysopen: $!");
- goto &_error ;
+ $fh = local *FH;
+ unless (sysopen($fh, $file_name, $mode, $perms)) {
+ @_ = ($opts, "write_file '$file_name' - sysopen: $!");
+ goto &_error;
}
}
-
- if ( my $binmode = $opts->{'binmode'} ) {
- binmode( $write_fh, $binmode ) ;
+ # we now have an open file handle as well as data to write to that
handle
+ if (my $binmode = $opts->{binmode}) {
+ binmode($fh, $binmode);
+ }
+
+ # get the data to print to the file
+ # get the buffer ref - it depends on how the data is passed in
+ # after this if/else $buf_ref will have a scalar ref to the data
+ my $buf_ref;
+ my $data_is_ref = 0;
+ if (ref($opts->{buf_ref}) eq 'SCALAR') {
+ # a scalar ref passed in %opts has the data
+ # note that the data was passed by ref
+ $buf_ref = $opts->{buf_ref};
+ $data_is_ref = 1;
+ }
+ elsif (ref($_[0]) eq 'SCALAR') {
+ # the first value in @_ is the scalar ref to the data
+ # note that the data was passed by ref
+ $buf_ref = shift;
+ $data_is_ref = 1;
+ }
+ elsif (ref($_[0]) eq 'ARRAY') {
+ # the first value in @_ is the array ref to the data so join it.
+ ${$buf_ref} = join '', @{$_[0]};
}
-
- sysseek( $write_fh, 0, SEEK_END ) if $opts->{'append'} ;
-
-#print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;
-
-# fix up newline to write cr/lf if this is a windows text file
-
- if ( $is_win32 && !$opts->{'binmode'} ) {
-
-# copy the write data if it was passed by ref so we don't clobber the
-# caller's data
- $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
- ${$buf_ref} =~ s/\n/\015\012/g ;
+ else {
+ # good old @_ has all the data so join it.
+ ${$buf_ref} = join '', @_;
}
-#print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;
-
-# get the size of how much we are writing and init the offset into that buffer
+ # seek and print
+ seek($fh, 0, SEEK_END) if $opts->{append};
+ print {$fh} ${$buf_ref};
+ truncate($fh, tell($fh)) unless $no_truncate;
+ close($fh);
- my $size_left = length( ${$buf_ref} ) ;
- my $offset = 0 ;
-
-# loop until we have no more data left to write
-
- do {
-
-# do the write and track how much we just wrote
-
- my $write_cnt = syswrite( $write_fh, ${$buf_ref},
- $size_left, $offset ) ;
-
-# since we're using syswrite Perl won't automatically restart the call
-# when interrupted by a signal.
-
- next if $!{EINTR};
-
- unless ( defined $write_cnt ) {
-
- @_ = ( $opts, "write_file '$file_name' - syswrite: $!");
- goto &_error ;
- }
-
-# track how much left to write and where to write from in the buffer
-
- $size_left -= $write_cnt ;
- $offset += $write_cnt ;
-
- } while( $size_left > 0 ) ;
-
-# we truncate regular files in case we overwrite a long file with a shorter
file
-# so seek to the current position to get it (same as tell()).
-
- truncate( $write_fh,
- sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;
-
- close( $write_fh ) ;
-
-# handle the atomic mode - move the temp file to the original filename.
-
- if ( $opts->{'atomic'} && !rename( $file_name, $orig_file_name ) ) {
-
- @_ = ( $opts, "write_file '$file_name' - rename: $!" ) ;
- goto &_error ;
+ if ($opts->{atomic} && !rename($file_name, $orig_filename)) {
+ @_ = ($opts, "write_file '$file_name' - rename: $!");
+ goto &_error;
}
- return 1 ;
+ return 1;
}
# this is for backwards compatibility with the previous File::Slurp module.
# write_file always overwrites an existing file
-
*overwrite_file = \&write_file ;
# the current write_file has an append mode so we use that. this
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/t/01-error_prepend_file.t
new/File-Slurp-9999.26/t/01-error_prepend_file.t
--- old/File-Slurp-9999.25/t/01-error_prepend_file.t 2018-10-16
17:11:03.000000000 +0200
+++ new/File-Slurp-9999.26/t/01-error_prepend_file.t 2019-02-13
17:06:53.000000000 +0100
@@ -42,7 +42,8 @@
# step 2: Allow step 1 to pass, then write out the newly altered contents to a
# a file called "foo.$$". This write will fail by simulating a problem with
# CORE::GLOBAL::syswrite
-{
+SKIP: {
+ skip "Skip these tests because mocking write failures can't happen", 9;
# go ahead and setup an initial file so that it can be read during the test
my $file = temp_file_path();
File::Slurp::write_file($file, '');
@@ -66,7 +67,7 @@
unlink "$file.$$";
# cleanup
unlink $file;
-}
+};
# step 3: Allow steps 1 and 2 to pass, then rename the new file called "foo.$$"
# to the original "foo". This rename will fail by simulating a problem with
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/t/01-error_write_file.t
new/File-Slurp-9999.26/t/01-error_write_file.t
--- old/File-Slurp-9999.25/t/01-error_write_file.t 2018-10-16
17:11:03.000000000 +0200
+++ new/File-Slurp-9999.26/t/01-error_write_file.t 2019-02-13
17:06:53.000000000 +0100
@@ -90,7 +90,9 @@
# Simulate a bad write
# we do this by causing CORE::syswrite to fail by overriding it
-{
+SKIP: {
+ skip "Skip these tests because mocking write failures can't happen", 36;
+
my $file = temp_file_path(); # good filename, can open
# write_file first
@@ -149,7 +151,7 @@
ok($err, 'append_file: write error, croak - got exception!');
ok(!$res, 'append_file: write error, croak - no content!');
unlink $file, "$file.$$";
-}
+};
# Simulate a bad rename when in atomic mode.
# we do this by causing CORE::rename to fail by overriding it
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/t/append_null.t
new/File-Slurp-9999.26/t/append_null.t
--- old/File-Slurp-9999.25/t/append_null.t 2018-10-16 17:11:03.000000000
+0200
+++ new/File-Slurp-9999.26/t/append_null.t 2019-02-13 17:06:53.000000000
+0100
@@ -12,7 +12,7 @@
plan(tests => 3);
my $file = temp_file_path();
-my $data = <<TEXT ;
+my $data = <<TEXT;
line 1
more text
TEXT
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/t/error.t
new/File-Slurp-9999.26/t/error.t
--- old/File-Slurp-9999.25/t/error.t 2018-10-16 17:11:03.000000000 +0200
+++ new/File-Slurp-9999.26/t/error.t 2019-02-13 17:06:53.000000000 +0100
@@ -27,14 +27,15 @@
}
# write_file write error - no syswrite
-{
+SKIP: {
+ skip "Skip these tests because mocking write failures can't happen", 3;
my $file = temp_file_path();
my ($res, $warn, $err) = trap_function_override_core('syswrite',
\&write_file, $file, '');
ok(!$warn, 'write_file: write error, no syswrite - no warning!');
like($err, qr/write/, 'write_file: write error, no syswrite - got
exception!');
ok(!$res, 'write_file: write error, no syswrite - no content!');
unlink $file;
-}
+};
# atomic rename error
SKIP: {
skip "Atomic rename on Win32 is useless", 3 if $is_win32;
@@ -63,7 +64,8 @@
ok(!$res, 'prepend_file: read error - no content!');
}
# prepend_file write error
-{
+SKIP: {
+ skip "Skip these tests because mocking write failures can't happen", 3;
my $file = temp_file_path();
write_file($file, '');
my ($res, $warn, $err) = trap_function_override_core('syswrite',
\&prepend_file, $file, '');
@@ -72,7 +74,7 @@
ok(!$res, 'prepend_file: opendir error - no content!');
unlink $file;
unlink "$file.$$";
-}
+};
# edit_file read error
{
my $file = temp_file_path();
@@ -83,7 +85,8 @@
unlink $file;
}
# edit_file write error
-{
+SKIP: {
+ skip "Skip these tests because mocking write failures can't happen", 3;
my $file = temp_file_path();
write_file($file, '');
my ($res, $warn, $err) = trap_function_override_core('syswrite',
\&edit_file, sub {}, $file);
@@ -92,7 +95,7 @@
ok(!$res, 'edit_file: write error - no content!');
unlink $file;
unlink "$file.$$";
-}
+};
# edit_file_lines read error
{
my $file = temp_file_path();
@@ -103,7 +106,8 @@
unlink $file;
}
# edit_file write error
-{
+SKIP: {
+ skip "Skip these tests because mocking write failures can't happen", 3;
my $file = temp_file_path();
write_file($file, '');
my ($res, $warn, $err) = trap_function_override_core('syswrite',
\&edit_file_lines, sub {}, $file);
@@ -112,4 +116,4 @@
ok(!$res, 'edit_file_lines: write error - no content!');
unlink $file;
unlink "$file.$$";
-}
+};
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/File-Slurp-9999.25/t/handle.t
new/File-Slurp-9999.26/t/handle.t
--- old/File-Slurp-9999.25/t/handle.t 2018-10-16 17:11:03.000000000 +0200
+++ new/File-Slurp-9999.26/t/handle.t 2019-02-07 21:00:28.000000000 +0100
@@ -1,10 +1,9 @@
use strict;
-use strict;
+use warnings;
use File::Slurp qw(read_file write_file);
use IO::Handle ();
-use POSIX qw(:fcntl_h);
use Socket;
use Symbol;
use Test::More;
@@ -12,159 +11,36 @@
my @pipe_data = (
'',
'abc',
- 'abc' x 100_000,
- 'abc' x 1_000_000,
+ 'abc' x 1000,
+ 'abc' x 10_000,
);
-plan tests => scalar @pipe_data;
-
-SKIP: {
- eval { test_socketpair_slurp() };
- skip "socketpair not found in this Perl", scalar(@pipe_data) if $@;
-}
-
-sub test_socketpair_slurp {
- foreach my $data ( @pipe_data ) {
- my $size = length( $data );
- my $read_fh = gensym;
- my $write_fh = gensym;
+plan tests => scalar(@pipe_data);
- socketpair($read_fh, $write_fh, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+foreach my $data ( @pipe_data ) {
+ my $size = length( $data );
+ my $read_fh = gensym;
+ my $write_fh = gensym;
+ my $value;
+ my $error;
+ { # catch block
+ local $@;
+ $error = $@ || 'Error' unless eval {
+ $value = socketpair($read_fh, $write_fh, AF_UNIX, SOCK_STREAM,
PF_UNSPEC);
+ 1;
+ }; # try
+ }
+ SKIP: {
+ skip "Can't use socketpair", 1 unless $value;
if (fork()) {
$write_fh->close();
- my $read_buf = read_file($read_fh);
- is($read_buf, $data, "socket slurp/spew of $size bytes");
+ my $res = read_file($read_fh);
+ is($res, $data, "read_file: socketpair of $size bytes");
}
else {
$read_fh->close();
- eval { write_file($write_fh, $data) };
+ write_file($write_fh, $data);
exit();
}
- }
-}
-
-sub test_data_slurp {
- my $data_seek = tell(\*DATA);
-
- # first slurp in the lines
- my @slurp_lines = read_file(\*DATA);
-
- # now seek back and read all the lines with the <> op and we make
- # golden data sets
- seek(\*DATA, $data_seek, SEEK_SET) || die "seek $!";
- my @data_lines = <DATA>;
- my $data_text = join('', @data_lines);
-
- # now slurp in as one string and test
- sysseek(\*DATA, $data_seek, SEEK_SET) || die "seek $!";
- my $slurp_text = read_file(\*DATA);
- is($slurp_text, $data_text, 'scalar slurp DATA');
-
- # test the array slurp
- is_deeply(\@data_lines, \@slurp_lines, 'list slurp of DATA');
-}
-
-sub test_fork_pipe_slurp {
- foreach my $data (@pipe_data) {
- test_to_pipe($data);
- test_from_pipe($data);
- }
-}
-
-sub test_from_pipe {
- my ($data) = @_;
- my $size = length($data);
-
- if (pipe_from_fork(\*READ_FH)) {
- # parent
- my $read_buf = read_file(\*READ_FH);
- warn "PARENT read\n";
- is($read_buf, $data, "pipe slurp/spew of $size bytes");
-
- close \*READ_FH;
- }
- else {
- # child
- warn "CHILD write\n";
- # write_file(\*STDOUT, $data);
- syswrite(\*STDOUT, $data, length($data));
- close \*STDOUT;
- exit(0);
- }
-}
-
-sub pipe_from_fork {
- my ($parent_fh) = @_;
-
- my $child = gensym;
- pipe($parent_fh, $child) or die;
-
- my $pid = fork();
- die "fork() failed: $!" unless defined $pid;
-
- if ($pid) {
- warn "PARENT\n";
- close $child;
- return $pid;
- }
-
- warn "CHILD FILENO ", fileno($child), "\n";
- close $parent_fh;
- open(STDOUT, ">&=" . fileno($child)) or die "no fileno";
- return;
-}
-
-sub test_to_pipe {
- my ($data) = @_;
-
- my $size = length($data);
-
- if (pipe_to_fork(\*WRITE_FH)) {
- # parent
- syswrite(\*WRITE_FH, $data, length($data));
- # write_file(\*WRITE_FH, $data);
- warn "PARENT write\n";
- # is($read_buf, $data, "pipe slurp/spew of $size bytes");
- close \*WRITE_FH ;
- }
- else {
- # child
- warn "CHILD read FILENO ", fileno(\*STDIN), "\n";
-
- my $read_buf = read_file(\*STDIN);
- is($read_buf, $data, "pipe slurp/spew of $size bytes");
- close \*STDIN;
- exit(0);
- }
+ };
}
-
-sub pipe_to_fork {
- my ($parent_fh) = @_;
- my $child = gensym;
-
- pipe($child, $parent_fh) or die;
-
- my $pid = fork();
- die "fork() failed: $!" unless defined $pid;
-
- if ($pid) {
- close $child;
- return $pid;
- }
-
- close $parent_fh;
- open(STDIN, "<&=" . fileno($child)) or die;
-}
-
-__DATA__
-line one
-second line
-more lines
-still more
-
-enough lines
-
-we don't test long handle slurps from DATA since i would have to type
-too much stuff :-)
-
-so we will stop here
