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