t/handle.t

   1 #!/usr/local/bin/perl -w
   2
   3 use strict ;
   4 use File::Slurp ;
   5
   6 use Carp ;
   7 use POSIX qw( :fcntl_h ) ;
   8 use Socket ;
   9 use Symbol ;
  10 use Test::More ;
  11
  12 # in case SEEK_SET isn't defined in older perls. it seems to always be 0
  13
  14 BEGIN {
  15         *SEEK_SET = sub() { 0 } unless defined \&SEEK_SET ;
  16 }
  17
  18 my @pipe_data = (
  19         '',
  20         'abc',
  21         'abc' x 100_000,
  22         'abc' x 1_000_000,
  23 ) ;
  24
  25 plan( tests => scalar @pipe_data ) ;
  26
  27 #test_data_slurp() ;
  28
  29 #test_fork_pipe_slurp() ;
  30
  31 SKIP: {
  32
  33         eval { test_socketpair_slurp() } ;
  34
  35         skip "socketpair not found in this Perl", scalar( @pipe_data ) if $@ ;
  36 }
  37
  38 sub test_socketpair_slurp {
  39
  40         foreach my $data ( @pipe_data ) {
  41
  42                 my $size = length( $data ) ;
  43
  44                 my $read_fh = gensym ;
  45                 my $write_fh = gensym ;
  46
  47                 socketpair( $read_fh, $write_fh,
  48                                 AF_UNIX, SOCK_STREAM, PF_UNSPEC);
  49
  50                 if ( fork() ) {
  51
  52 #warn "PARENT SOCKET\n" ;
  53                         close( $write_fh ) ;
  54                         my $read_buf = read_file( $read_fh ) ;
  55
  56                         is( $read_buf, $data,
  57                                 "socket slurp/spew of $size bytes" ) ;
  58
  59                 }
  60                 else {
  61
  62 #child
  63 #warn "CHILD SOCKET\n" ;
  64                         close( $read_fh ) ;
  65                         eval { write_file( $write_fh, $data ) } ;
  66                         exit() ;
  67                 }
  68         }
  69 }
  70
  71 sub test_data_slurp {
  72
  73         my $data_seek = tell( \*DATA );
  74
  75 # first slurp in the lines
  76         my @slurp_lines = read_file( \*DATA ) ;
  77
  78 # now seek back and read all the lines with the <> op and we make
  79 # golden data sets
  80
  81         seek( \*DATA, $data_seek, SEEK_SET ) || die "seek $!" ;
  82         my @data_lines = <DATA> ;
  83         my $data_text = join( '', @data_lines ) ;
  84
  85 # now slurp in as one string and test
  86
  87         sysseek( \*DATA, $data_seek, SEEK_SET ) || die "seek $!" ;
  88         my $slurp_text = read_file( \*DATA ) ;
  89         is( $slurp_text, $data_text, 'scalar slurp DATA' ) ;
  90
  91 # test the array slurp
  92
  93         ok( eq_array( \@data_lines, \@slurp_lines ), 'list slurp of DATA' ) ;
  94 }
  95
  96 sub test_fork_pipe_slurp {
  97
  98         foreach my $data ( @pipe_data ) {
  99
 100                 test_to_pipe( $data ) ;
 101                 test_from_pipe( $data ) ;
 102         }
 103 }
 104
 105
 106 sub test_from_pipe {
 107
 108         my( $data ) = @_ ;
 109
 110         my $size = length( $data ) ;
 111
 112         if ( pipe_from_fork( \*READ_FH ) ) {
 113
 114 # parent
 115                 my $read_buf = read_file( \*READ_FH ) ;
 116 warn "PARENT read\n" ;
 117
 118                 is( $read_buf, $data, "pipe slurp/spew of $size bytes" ) ;
 119
 120                 close \*READ_FH ;
 121 #               return ;
 122         }
 123         else {
 124 # child
 125 warn "CHILD write\n" ;
 126         #       write_file( \*STDOUT, $data ) ;
 127                 syswrite( \*STDOUT, $data, length( $data ) ) ;
 128
 129                 close \*STDOUT;
 130                 exit(0);
 131         }
 132 }
 133
 134
 135 sub pipe_from_fork {
 136
 137         my ( $parent_fh ) = @_ ;
 138
 139         my $child = gensym ;
 140
 141         pipe( $parent_fh, $child ) or die;
 142
 143         my $pid = fork();
 144         die "fork() failed: $!" unless defined $pid;
 145
 146         if ($pid) {
 147
 148 warn "PARENT\n" ;
 149                 close $child;
 150                 return $pid ;
 151         }
 152
 153 warn "CHILD FILENO ", fileno($child), "\n" ;
 154         close $parent_fh ;
 155         open(STDOUT, ">&=" . fileno($child)) or die "no fileno" ;
 156
 157         return ;
 158 }
 159
 160
 161 sub test_to_pipe {
 162
 163         my( $data ) = @_ ;
 164
 165         my $size = length( $data ) ;
 166
 167         if ( pipe_to_fork( \*WRITE_FH ) ) {
 168
 169 # parent
 170                 syswrite( \*WRITE_FH, $data, length( $data ) ) ;
 171 #               write_file( \*WRITE_FH, $data ) ;
 172 warn "PARENT write\n" ;
 173
 174 #               is( $read_buf, $data, "pipe slurp/spew of $size bytes" ) ;
 175
 176                 close \*WRITE_FH ;
 177 #               return ;
 178         }
 179         else {
 180 # child
 181 warn "CHILD read FILENO ", fileno(\*STDIN), "\n" ;
 182
 183                 my $read_buf = read_file( \*STDIN ) ;
 184                 is( $read_buf, $data, "pipe slurp/spew of $size bytes" ) ;
 185                 close \*STDIN;
 186                 exit(0);
 187         }
 188 }
 189
 190 sub pipe_to_fork {
 191         my ( $parent_fh ) = @_ ;
 192
 193         my $child = gensym ;
 194
 195         pipe( $child, $parent_fh ) or die ;
 196
 197         my $pid = fork();
 198         die "fork() failed: $!" unless defined $pid;
 199
 200         if ( $pid ) {
 201                 close $child;
 202                 return $pid ;
 203         }
 204
 205         close $parent_fh ;
 206         open(STDIN, "<&=" . fileno($child)) or die;
 207
 208         return ;
 209 }
 210
 211 __DATA__
 212 line one
 213 second line
 214 more lines
 215 still more
 216
 217 enough lines
 218
 219 we don't test long handle slurps from DATA since i would have to type
 220 too much stuff :-)
 221
 222 so we will stop here