1#!./perl 2 3BEGIN { 4 require Config; 5 if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){ 6 print "1..0 # Skip -- Perl configured without PerlIO::via module\n"; 7 exit 0; 8 } 9} 10 11use strict; 12use warnings; 13 14my $tmp = "via$$"; 15 16use Test::More tests => 26; 17 18my $fh; 19my $a = join("", map { chr } 0..255) x 10; 20my $b; 21 22BEGIN { use_ok('PerlIO::via::QuotedPrint'); } 23 24ok( !open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input fails'); 25ok( open($fh,">via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for output'); 26ok( (print $fh $a), "print to output file"); 27ok( close($fh), 'close output file'); 28 29ok( open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input'); 30{ local $/; $b = <$fh> } 31ok( close($fh), "close input file"); 32 33is($a, $b, 'compare original data with filtered version'); 34 35 36{ 37 my $warnings = ''; 38 local $SIG{__WARN__} = sub { $warnings = join '', @_ }; 39 40 use warnings 'layer'; 41 42 # Find fd number we should be using 43 my $fd = open($fh,'>',$tmp) && fileno($fh); 44 print $fh "Hello\n"; 45 close($fh); 46 47 ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail'); 48 like( $warnings, qr/^Cannot find package 'Unknown::Module'/, 'warn about unknown package' ); 49 50 # Now open normally again to see if we get right fileno 51 my $fd2 = open($fh,'<',$tmp) && fileno($fh); 52 is($fd2,$fd,"Wrong fd number after failed open"); 53 54 my $data = <$fh>; 55 56 is($data,"Hello\n","File clobbered by failed open"); 57 58 close($fh); 59 60{ 61package Incomplete::Module; 62} 63 64 $warnings = ''; 65 no warnings 'layer'; 66 ok( ! open($fh,">via(Incomplete::Module)", $tmp), 'open via Incomplete::Module will fail'); 67 is( $warnings, "", "don't warn about unknown package" ); 68 69 $warnings = ''; 70 no warnings 'layer'; 71 ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail'); 72 is( $warnings, "", "don't warn about unknown package" ); 73} 74 75my $obj = ''; 76sub Foo::PUSHED { $obj = shift; -1; } 77sub PerlIO::via::Bar::PUSHED { $obj = shift; -1; } 78open $fh, '<:via(Foo)', "foo"; 79is( $obj, 'Foo', 'search for package Foo' ); 80open $fh, '<:via(Bar)', "bar"; 81is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' ); 82 83{ 84 # [perl #131221] 85 ok(open(my $fh1, ">", $tmp), "open $tmp"); 86 ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it"); 87 ok(open(my $fh2, ">&", $fh1), "dup it"); 88 close $fh1; 89 close $fh2; 90 91 # make sure the old workaround still works 92 ok(open($fh1, ">", $tmp), "open $tmp"); 93 ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it"); 94 ok(open($fh2, ">&", $fh1), "dup it"); 95 print $fh2 "XZXZ"; 96 close $fh1; 97 close $fh2; 98 99 ok(open($fh1, "<", $tmp), "open $tmp for check"); 100 { local $/; $b = <$fh1> } 101 close $fh1; 102 is($b, "XZXZ", "check result is from non-filtering class"); 103 104 package PerlIO::via::XXX; 105 106 sub PUSHED { 107 my $class = shift; 108 bless {}, $class; 109 } 110 111 sub WRITE { 112 my ($self, $buffer, $handle) = @_; 113 114 print $handle $buffer; 115 return length($buffer); 116 } 117 package PerlIO::via::YYY; 118 119 sub PUSHED { 120 my $class = shift; 121 bless {}, $class; 122 } 123 124 sub WRITE { 125 my ($self, $buffer, $handle) = @_; 126 127 $buffer =~ tr/X/Y/; 128 print $handle $buffer; 129 return length($buffer); 130 } 131 132 sub GETARG { 133 "XXX"; 134 } 135} 136 137END { 138 1 while unlink $tmp; 139} 140 141