ext/PerlIO/t/via.t

   1 #!./perl
   2
   3 use strict;
   4 use warnings;
   5
   6 BEGIN {
   7     chdir 't' if -d 't';
   8     @INC = '../lib';
   9     unless (find PerlIO::Layer 'perlio') {
  10         print "1..0 # Skip: not perlio\n";
  11         exit 0;
  12     }
  13 }
  14
  15 my $tmp = "via$$";
  16
  17 use Test::More tests => 16;
  18
  19 my $fh;
  20 my $a = join("", map { chr } 0..255) x 10;
  21 my $b;
  22
  23 BEGIN { use_ok('PerlIO::via::QuotedPrint'); }
  24
  25 ok( !open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input fails');
  26 ok(  open($fh,">via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for output');
  27 ok( (print $fh $a), "print to output file");
  28 ok( close($fh), 'close output file');
  29
  30 ok( open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input');
  31 { local $/; $b = <$fh> }
  32 ok( close($fh), "close input file");
  33
  34 is($a, $b, 'compare original data with filtered version');
  35
  36
  37 {
  38     my $warnings = '';
  39     local $SIG{__WARN__} = sub { $warnings = join '', @_ };
  40
  41     use warnings 'layer';
  42
  43     # Find fd number we should be using
  44     my $fd = open($fh,">$tmp") && fileno($fh);
  45     print $fh "Hello\n";
  46     close($fh);
  47
  48     ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
  49     like( $warnings, qr/^Cannot find package 'Unknown::Module'/,  'warn about unknown package' );
  50
  51     # Now open normally again to see if we get right fileno
  52     my $fd2 = open($fh,"<$tmp") && fileno($fh);
  53     is($fd2,$fd,"Wrong fd number after failed open");
  54
  55     my $data = <$fh>;
  56
  57     is($data,"Hello\n","File clobbered by failed open");
  58
  59     close($fh);
  60
  61
  62
  63     $warnings = '';
  64     no warnings 'layer';
  65     ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
  66     is( $warnings, "",  "don't warn about unknown package" );
  67 }
  68
  69 my $obj = '';
  70 sub Foo::PUSHED                 { $obj = shift; -1; }
  71 sub PerlIO::via::Bar::PUSHED    { $obj = shift; -1; }
  72 open $fh, '<:via(Foo)', "foo";
  73 is( $obj, 'Foo', 'search for package Foo' );
  74 open $fh, '<:via(Bar)', "bar";
  75 is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
  76
  77 END {
  78     1 while unlink $tmp;
  79 }
  80