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 => 26; 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 87{ 88 # [perl #131221] 89 ok(open(my $fh1, ">", $tmp), "open $tmp"); 90 ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it"); 91 ok(open(my $fh2, ">&", $fh1), "dup it"); 92 close $fh1; 93 close $fh2; 94 95 # make sure the old workaround still works 96 ok(open($fh1, ">", $tmp), "open $tmp"); 97 ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it"); 98 ok(open($fh2, ">&", $fh1), "dup it"); 99 print $fh2 "XZXZ"; 100 close $fh1; 101 close $fh2; 102 103 ok(open($fh1, "<", $tmp), "open $tmp for check"); 104 { local $/; $b = <$fh1> } 105 close $fh1; 106 is($b, "XZXZ", "check result is from non-filtering class"); 107 108 package PerlIO::via::XXX; 109 110 sub PUSHED { 111 my $class = shift; 112 bless {}, $class; 113 } 114 115 sub WRITE { 116 my ($self, $buffer, $handle) = @_; 117 118 print $handle $buffer; 119 return length($buffer); 120 } 121 package PerlIO::via::YYY; 122 123 sub PUSHED { 124 my $class = shift; 125 bless {}, $class; 126 } 127 128 sub WRITE { 129 my ($self, $buffer, $handle) = @_; 130 131 $buffer =~ tr/X/Y/; 132 print $handle $buffer; 133 return length($buffer); 134 } 135 136 sub GETARG { 137 "XXX"; 138 } 139} 140 141END { 142 1 while unlink $tmp; 143} 144 145