t/handle.t

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