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