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