1# IO::Callback 1.08 t/wrongway-ebadf.t 2# Check that reads on write filehandles (and visa versa) give EBADF errors, same as real files. 3 4use strict; 5use warnings; 6 7use Test::More; 8BEGIN { 9 eval 'use Errno qw/EBADF/'; 10 plan skip_all => 'Errno qw/EBADF/ required' if $@; 11} 12use Test::NoWarnings; 13 14use IO::Callback; 15 16# some bits of code for reading/writing the fh 17my @code_bits = grep {/\S/} split /\n/, <<'EOF'; 18R $_ = <$fh> 19R $_ = $fh->getline 20R my @foo = <$fh> 21R my @foo = $fh->getlines 22R $_ = $fh->getc 23R $_ = $fh->ungetc(123) 24R my $x ; $_ = read $fh, $x, 1024 25R my $x; $_ = sysread $fh, $x, 1024 26W $_ = $fh->print(4) 27W $_ = print $fh 4 28W $_ = $fh->printf(4) 29W $_ = printf $fh 4 30W $_ = syswrite $fh, "asdfsadf", 3 31EOF 32 33plan tests => 4 * @code_bits + 1; 34 35use vars qw/$fh/; 36 37# The tests to run with a read-only fh as $fh (checking that read ops 38# work and write ops fail with EBADF) as an array of coderefs. 39my @try_on_read_fh; 40 41# The tests to run with a write-only fh as $fh (checking that write ops 42# work and read ops fail with EBADF) as an array of coderefs. 43my @try_on_write_fh; 44 45foreach my $code_bit (@code_bits) { 46 $code_bit =~ s/^([RW])\s*// or die $code_bit; 47 my $type = $1; 48 49 my $code = $code_bit; 50 $code .= '; '; 51 if ($code =~ /\@foo/) { 52 $code .= 'my $no_error = @foo;'; 53 } else { 54 $code .= 'my $no_error = defined $_;'; 55 } 56 my $ok_sub = eval <<EOF; die $@ if $@; 57 sub { 58 $code 59 ok \$no_error, q{'$code_bit' gave no error}; 60 } 61EOF 62 my $notok_sub = eval <<EOF; die $@ if $@; 63 sub { 64 $code 65 ok !\$no_error, q{'$code_bit' gave an error}; 66 ok \$!{EBADF}, 'errno set to EBADF'; 67 ok \$fh->error, "error flag set"; 68 } 69EOF 70 if ($type eq "R") { 71 push @try_on_read_fh, $ok_sub; 72 push @try_on_write_fh, $notok_sub; 73 } else { 74 push @try_on_read_fh, $notok_sub; 75 push @try_on_write_fh, $ok_sub; 76 } 77} 78 79foreach my $sub (@try_on_read_fh) { 80 my @blocks = ("foo\nbar\n"); 81 $fh = IO::Callback->new('<', sub {shift @blocks}); 82 $sub->(); 83} 84 85foreach my $sub (@try_on_write_fh) { 86 $fh = IO::Callback->new('>', sub {}); 87 $sub->(); 88} 89 90