t/io/perlio_fail.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require "../t/test.pl";
   7     skip_all("No perlio") unless (find PerlIO::Layer 'perlio');
   8     plan (15);
   9 }
  10
  11 use warnings 'layer';
  12 my $warn;
  13 my $file = "fail$$";
  14 $SIG{__WARN__} = sub { $warn = shift };
  15
  16 END { 1 while unlink($file) }
  17
  18 ok(open(FH,">",$file),"Create works");
  19 close(FH);
  20 ok(open(FH,"<",$file),"Normal open works");
  21
  22 $warn = ''; $! = 0;
  23 ok(!binmode(FH,":-)"),"All punctuation fails binmode");
  24 print "# $!\n";
  25 isnt($!,0,"Got errno");
  26 like($warn,qr/in PerlIO layer/,"Got warning");
  27
  28 $warn = ''; $! = 0;
  29 ok(!binmode(FH,":nonesuch"),"Bad package fails binmode");
  30 print "# $!\n";
  31 isnt($!,0,"Got errno");
  32 like($warn,qr/nonesuch/,"Got warning");
  33 close(FH);
  34
  35 $warn = ''; $! = 0;
  36 ok(!open(FH,"<:-)",$file),"All punctuation fails open");
  37 print "# $!\n";
  38 isnt($!,"","Got errno");
  39 like($warn,qr/in PerlIO layer/,"Got warning");
  40
  41 $warn = ''; $! = 0;
  42 ok(!open(FH,"<:nonesuch",$file),"Bad package fails open");
  43 print "# $!\n";
  44 isnt($!,0,"Got errno");
  45 like($warn,qr/nonesuch/,"Got warning");
  46
  47 ok(open(FH,"<",$file),"Normal open (still) works");
  48 close(FH);