+++ /dev/null
-#!/usr/local/bin/perl -w
-
-use strict ;
-use File::Slurp ;
-
-use Carp ;
-use POSIX qw( :fcntl_h ) ;
-use Socket ;
-use Symbol ;
-use Test::More ;
-
-# in case SEEK_SET isn't defined in older perls. it seems to always be 0
-
-BEGIN {
- *SEEK_SET = sub() { 0 } unless defined \&SEEK_SET ;
-}
-
-my @pipe_data = (
- '',
- 'abc',
- 'abc' x 100_000,
- 'abc' x 1_000_000,
-) ;
-
-plan( tests => scalar @pipe_data ) ;
-
-#test_data_slurp() ;
-
-#test_fork_pipe_slurp() ;
-
-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 ;
-
- socketpair( $read_fh, $write_fh,
- AF_UNIX, SOCK_STREAM, PF_UNSPEC);
-
- if ( fork() ) {
-
-#warn "PARENT SOCKET\n" ;
- close( $write_fh ) ;
- my $read_buf = read_file( $read_fh ) ;
-
- is( $read_buf, $data,
- "socket slurp/spew of $size bytes" ) ;
-
- }
- else {
-
-#child
-#warn "CHILD SOCKET\n" ;
- close( $read_fh ) ;
- eval { 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
-
- ok( eq_array( \@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 ;
-# return ;
- }
- 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 ;
-# return ;
- }
- 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;
-
- return ;
-}
-
-__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
projects / urisagit/Perl-Docs.git / blobdiff