This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Do not honor TMPDIR for anonymous temporary files when tainting
[perl5.git] / t / io / perlio.t
1 BEGIN {
2         chdir 't' if -d 't';
3         @INC = '../lib';
4         require Config; import Config;
5         unless (find PerlIO::Layer 'perlio') {
6             print "1..0 # Skip: PerlIO not used\n";
7             exit 0;
8         }
9 }
10
11 use Test::More tests => 39;
12
13 use_ok('PerlIO');
14
15 my $txt = "txt$$";
16 my $bin = "bin$$";
17 my $utf = "utf$$";
18 my $nonexistent = "nex$$";
19
20 my $txtfh;
21 my $binfh;
22 my $utffh;
23
24 ok(open($txtfh, ">:crlf", $txt));
25
26 ok(open($binfh, ">:raw",  $bin));
27
28 ok(open($utffh, ">:utf8", $utf));
29
30 print $txtfh "foo\n";
31 print $txtfh "bar\n";
32
33 ok(close($txtfh));
34
35 print $binfh "foo\n";
36 print $binfh "bar\n";
37
38 ok(close($binfh));
39
40 print $utffh "foo\x{ff}\n";
41 print $utffh "bar\x{abcd}\n";
42
43 ok(close($utffh));
44
45 ok(open($txtfh, "<:crlf", $txt));
46
47 ok(open($binfh, "<:raw",  $bin));
48
49
50 ok(open($utffh, "<:utf8", $utf));
51
52 is(scalar <$txtfh>, "foo\n");
53 is(scalar <$txtfh>, "bar\n");
54
55 is(scalar <$binfh>, "foo\n");
56 is(scalar <$binfh>, "bar\n");
57
58 is(scalar <$utffh>,  "foo\x{ff}\n");
59 is(scalar <$utffh>, "bar\x{abcd}\n");
60
61 ok(eof($txtfh));;
62
63 ok(eof($binfh));
64
65 ok(eof($utffh));
66
67 ok(close($txtfh));
68
69 ok(close($binfh));
70
71 ok(close($utffh));
72
73 # magic temporary file via 3 arg open with undef
74 {
75     ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
76     ok( defined fileno($x),     '       fileno' );
77
78     select $x;
79     ok( (print "ok\n"),         '       print' );
80
81     select STDOUT;
82     ok( seek($x,0,0),           '       seek' );
83     is( scalar <$x>, "ok\n",    '       readline' );
84     ok( tell($x) >= 3,          '       tell' );
85
86     # test magic temp file over STDOUT
87     open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
88     my $status = open(STDOUT,"+<",undef);
89     open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
90     # report after STDOUT is restored
91     ok($status, '       re-open STDOUT');
92     close OLDOUT;
93
94     SKIP: {
95       skip("TMPDIR not honored on this platform", 2)
96         if !$Config{d_mkstemp}
97         || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2';
98       local $ENV{TMPDIR} = $nonexistent;
99       ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir');
100
101       mkdir $ENV{TMPDIR};
102       ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir');
103     }
104 }
105
106 # in-memory open
107 SKIP: {
108     eval { require PerlIO::scalar };
109     unless (find PerlIO::Layer 'scalar') {
110         skip("PerlIO::scalar not found", 8);
111     }
112     my $var;
113     ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
114     ok( defined fileno($x),     '       fileno' );
115
116     select $x;
117     ok( (print "ok\n"),         '       print' );
118
119     select STDOUT;
120     ok( seek($x,0,0),           '       seek' );
121     is( scalar <$x>, "ok\n",    '       readline' );
122     ok( tell($x) >= 3,          '       tell' );
123
124   TODO: {
125         local $TODO = "broken";
126
127         # test in-memory open over STDOUT
128         open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
129         #close STDOUT;
130         my $status = open(STDOUT,">",\$var);
131         my $error = "$!" unless $status; # remember the error
132         close STDOUT unless $status;
133         open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
134         print "# $error\n" unless $status;
135         # report after STDOUT is restored
136         ok($status, '       open STDOUT into in-memory var');
137
138         # test in-memory open over STDERR
139         open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
140         #close STDERR;
141         ok( open(STDERR,">",\$var), '       open STDERR into in-memory var');
142         open STDERR,  ">&OLDERR" or die "cannot dup OLDERR: $!";
143     }
144 }
145
146
147 END {
148     1 while unlink $txt;
149     1 while unlink $bin;
150     1 while unlink $utf;
151     rmdir $nonexistent;
152 }
153