Commit | Line | Data |
---|---|---|
8a73d5dd RGS |
1 | #!./perl -w |
2 | ||
feafb1eb | 3 | # Tests for the command-line switches: |
fed0ca7f | 4 | # -0, -c, -l, -s, -m, -M, -V, -v, -h, -i, -E and all unknown |
48eaf804 | 5 | # Some switches have their own tests, see MANIFEST. |
8a73d5dd RGS |
6 | |
7 | BEGIN { | |
8 | chdir 't' if -d 't'; | |
9 | @INC = '../lib'; | |
7620c903 | 10 | require Config; import Config; |
8a73d5dd RGS |
11 | } |
12 | ||
629eeaee | 13 | BEGIN { require "./test.pl"; require "./loc_tools.pl"; } |
8a73d5dd | 14 | |
7896dde7 | 15 | plan(tests => 137); |
8a73d5dd | 16 | |
a09a0aa2 JH |
17 | use Config; |
18 | ||
b734d6c9 | 19 | # due to a bug in VMS's piping which makes it impossible for runperl() |
e54d2dfa JH |
20 | # to emulate echo -n (ie. stdin always winds up with a newline), these |
21 | # tests almost totally fail. | |
b734d6c9 MS |
22 | $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS'; |
23 | ||
8a73d5dd RGS |
24 | my $r; |
25 | my @tmpfiles = (); | |
a29d0261 | 26 | END { unlink_all @tmpfiles } |
8a73d5dd RGS |
27 | |
28 | # Tests for -0 | |
29 | ||
30 | $r = runperl( | |
31 | switches => [ '-0', ], | |
32 | stdin => 'foo\0bar\0baz\0', | |
33 | prog => 'print qq(<$_>) while <>', | |
34 | ); | |
35 | is( $r, "<foo\0><bar\0><baz\0>", "-0" ); | |
36 | ||
37 | $r = runperl( | |
38 | switches => [ '-l', '-0', '-p' ], | |
39 | stdin => 'foo\0bar\0baz\0', | |
40 | prog => '1', | |
41 | ); | |
42 | is( $r, "foo\nbar\nbaz\n", "-0 after a -l" ); | |
43 | ||
44 | $r = runperl( | |
45 | switches => [ '-0', '-l', '-p' ], | |
46 | stdin => 'foo\0bar\0baz\0', | |
47 | prog => '1', | |
48 | ); | |
49 | is( $r, "foo\0bar\0baz\0", "-0 before a -l" ); | |
50 | ||
51 | $r = runperl( | |
52 | switches => [ sprintf("-0%o", ord 'x') ], | |
53 | stdin => 'fooxbarxbazx', | |
54 | prog => 'print qq(<$_>) while <>', | |
55 | ); | |
56 | is( $r, "<foox><barx><bazx>", "-0 with octal number" ); | |
57 | ||
58 | $r = runperl( | |
59 | switches => [ '-00', '-p' ], | |
60 | stdin => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n', | |
61 | prog => 's/\n/-/g;$_.=q(/)', | |
62 | ); | |
63 | is( $r, 'abc-def--/ghi-jkl-mno--/pq-/', '-00 (paragraph mode)' ); | |
64 | ||
65 | $r = runperl( | |
66 | switches => [ '-0777', '-p' ], | |
67 | stdin => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n', | |
68 | prog => 's/\n/-/g;$_.=q(/)', | |
69 | ); | |
70 | is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' ); | |
71 | ||
7f9e821f RGS |
72 | $r = runperl( |
73 | switches => [ '-066' ], | |
0fbedf1d | 74 | prog => 'BEGIN { print qq{($/)} } print qq{[$/]}', |
7f9e821f RGS |
75 | ); |
76 | is( $r, "(\066)[\066]", '$/ set at compile-time' ); | |
77 | ||
8a73d5dd RGS |
78 | # Tests for -c |
79 | ||
2d90ac95 | 80 | my $filename = tempfile(); |
8a73d5dd | 81 | SKIP: { |
b734d6c9 MS |
82 | local $TODO = ''; # this one works on VMS |
83 | ||
8a73d5dd RGS |
84 | open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); |
85 | print $f <<'SWTEST'; | |
86 | BEGIN { print "block 1\n"; } | |
87 | CHECK { print "block 2\n"; } | |
88 | INIT { print "block 3\n"; } | |
89 | print "block 4\n"; | |
90 | END { print "block 5\n"; } | |
91 | SWTEST | |
d1e4d418 | 92 | close $f or die "Could not close: $!"; |
8a73d5dd RGS |
93 | $r = runperl( |
94 | switches => [ '-c' ], | |
95 | progfile => $filename, | |
96 | stderr => 1, | |
97 | ); | |
98 | # Because of the stderr redirection, we can't tell reliably the order | |
99 | # in which the output is given | |
100 | ok( | |
101 | $r =~ /$filename syntax OK/ | |
102 | && $r =~ /\bblock 1\b/ | |
103 | && $r =~ /\bblock 2\b/ | |
104 | && $r !~ /\bblock 3\b/ | |
105 | && $r !~ /\bblock 4\b/ | |
106 | && $r !~ /\bblock 5\b/, | |
107 | '-c' | |
108 | ); | |
8a73d5dd RGS |
109 | } |
110 | ||
ae7bdbc5 | 111 | SKIP: { |
629eeaee | 112 | skip 'locales not available', 1 unless locales_enabled('LC_ALL'); |
ae7bdbc5 | 113 | |
1044e8d2 JK |
114 | my $tempdir = tempfile; |
115 | mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!"; | |
cdd06489 | 116 | |
5e4d35e6 RS |
117 | local $ENV{'LC_ALL'} = 'C'; # Keep the test simple: expect English |
118 | local $ENV{LANGUAGE} = 'C'; | |
2e3d3246 | 119 | setlocale(LC_ALL, "C"); |
5e4d35e6 | 120 | |
cdd06489 RS |
121 | # Win32 won't let us open the directory, so we never get to die with |
122 | # EISDIR, which happens after open. | |
dbab6833 FC |
123 | require Errno; |
124 | import Errno qw(EACCES EISDIR); | |
125 | my $error = do { | |
126 | local $! = $^O eq 'MSWin32' ? &EACCES : &EISDIR; "$!" | |
127 | }; | |
1044e8d2 JK |
128 | like( |
129 | runperl( switches => [ '-c' ], args => [ $tempdir ], stderr => 1), | |
5e4d35e6 | 130 | qr/Can't open perl script.*$tempdir.*\Q$error/s, |
1044e8d2 JK |
131 | "RT \#61362: Cannot syntax-check a directory" |
132 | ); | |
133 | rmdir $tempdir or die "Can't rmdir '$tempdir': $!"; | |
134 | } | |
135 | ||
8a73d5dd RGS |
136 | # Tests for -l |
137 | ||
138 | $r = runperl( | |
139 | switches => [ sprintf("-l%o", ord 'x') ], | |
140 | prog => 'print for qw/foo bar/' | |
141 | ); | |
142 | is( $r, 'fooxbarx', '-l with octal number' ); | |
143 | ||
144 | # Tests for -s | |
145 | ||
146 | $r = runperl( | |
147 | switches => [ '-s' ], | |
148 | prog => 'for (qw/abc def ghi/) {print defined $$_ ? $$_ : q(-)}', | |
149 | args => [ '--', '-abc=2', '-def', ], | |
150 | ); | |
151 | is( $r, '21-', '-s switch parsing' ); | |
152 | ||
2d90ac95 | 153 | $filename = tempfile(); |
8a73d5dd RGS |
154 | SKIP: { |
155 | open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); | |
156 | print $f <<'SWTEST'; | |
59e235cb GA |
157 | #!perl -s |
158 | BEGIN { print $x,$y; exit } | |
159 | SWTEST | |
160 | close $f or die "Could not close: $!"; | |
161 | $r = runperl( | |
162 | progfile => $filename, | |
163 | args => [ '-x=foo -y' ], | |
164 | ); | |
165 | is( $r, 'foo1', '-s on the shebang line' ); | |
59e235cb GA |
166 | } |
167 | ||
ee95e30c | 168 | # Bug ID 20011106.084 (#7876) |
2d90ac95 | 169 | $filename = tempfile(); |
59e235cb GA |
170 | SKIP: { |
171 | open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); | |
172 | print $f <<'SWTEST'; | |
f0b2cf55 YST |
173 | #!perl -sn |
174 | BEGIN { print $x; exit } | |
8a73d5dd | 175 | SWTEST |
d1e4d418 | 176 | close $f or die "Could not close: $!"; |
8a73d5dd | 177 | $r = runperl( |
8a73d5dd RGS |
178 | progfile => $filename, |
179 | args => [ '-x=foo' ], | |
180 | ); | |
59e235cb | 181 | is( $r, 'foo', '-sn on the shebang line' ); |
8a73d5dd RGS |
182 | } |
183 | ||
184 | # Tests for -m and -M | |
185 | ||
2d90ac95 NC |
186 | my $package = tempfile(); |
187 | $filename = "$package.pm"; | |
8a73d5dd RGS |
188 | SKIP: { |
189 | open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 ); | |
2d90ac95 NC |
190 | print $f <<"SWTESTPM"; |
191 | package $package; | |
192 | sub import { print map "<\$_>", \@_ } | |
8a73d5dd RGS |
193 | 1; |
194 | SWTESTPM | |
d1e4d418 | 195 | close $f or die "Could not close: $!"; |
8a73d5dd | 196 | $r = runperl( |
3d7c117d | 197 | switches => [ "-I.", "-M$package" ], |
8a73d5dd RGS |
198 | prog => '1', |
199 | ); | |
2d90ac95 | 200 | is( $r, "<$package>", '-M' ); |
8a73d5dd | 201 | $r = runperl( |
3d7c117d | 202 | switches => [ "-I.", "-M$package=foo" ], |
8a73d5dd RGS |
203 | prog => '1', |
204 | ); | |
2d90ac95 | 205 | is( $r, "<$package><foo>", '-M with import parameter' ); |
8a73d5dd | 206 | $r = runperl( |
2d90ac95 | 207 | switches => [ "-m$package" ], |
8a73d5dd RGS |
208 | prog => '1', |
209 | ); | |
b734d6c9 MS |
210 | |
211 | { | |
212 | local $TODO = ''; # this one works on VMS | |
213 | is( $r, '', '-m' ); | |
214 | } | |
8a73d5dd | 215 | $r = runperl( |
3d7c117d | 216 | switches => [ "-I.", "-m$package=foo,bar" ], |
8a73d5dd RGS |
217 | prog => '1', |
218 | ); | |
2d90ac95 | 219 | is( $r, "<$package><foo><bar>", '-m with import parameters' ); |
8a73d5dd | 220 | push @tmpfiles, $filename; |
0544e6df | 221 | |
3012b817 CB |
222 | { |
223 | local $TODO = ''; # these work on VMS | |
224 | ||
0544e6df RB |
225 | is( runperl( switches => [ '-MTie::Hash' ], stderr => 1, prog => 1 ), |
226 | '', "-MFoo::Bar allowed" ); | |
227 | ||
2d90ac95 | 228 | like( runperl( switches => [ "-M:$package" ], stderr => 1, |
3d7a9343 | 229 | prog => 'die q{oops}' ), |
0544e6df RB |
230 | qr/Invalid module name [\w:]+ with -M option\b/, |
231 | "-M:Foo not allowed" ); | |
232 | ||
233 | like( runperl( switches => [ '-mA:B:C' ], stderr => 1, | |
3d7a9343 | 234 | prog => 'die q{oops}' ), |
0544e6df RB |
235 | qr/Invalid module name [\w:]+ with -m option\b/, |
236 | "-mFoo:Bar not allowed" ); | |
237 | ||
238 | like( runperl( switches => [ '-m-A:B:C' ], stderr => 1, | |
3d7a9343 | 239 | prog => 'die q{oops}' ), |
0544e6df RB |
240 | qr/Invalid module name [\w:]+ with -m option\b/, |
241 | "-m-Foo:Bar not allowed" ); | |
242 | ||
243 | like( runperl( switches => [ '-m-' ], stderr => 1, | |
3d7a9343 | 244 | prog => 'die q{oops}' ), |
0544e6df RB |
245 | qr/Module name required with -m option\b/, |
246 | "-m- not allowed" ); | |
247 | ||
248 | like( runperl( switches => [ '-M-=' ], stderr => 1, | |
3d7a9343 | 249 | prog => 'die q{oops}' ), |
0544e6df RB |
250 | qr/Module name required with -M option\b/, |
251 | "-M- not allowed" ); | |
3012b817 | 252 | } # disable TODO on VMS |
8a73d5dd | 253 | } |
bda1f081 FC |
254 | is runperl(stderr => 1, prog => '#!perl -m'), |
255 | qq 'Too late for "-m" option at -e line 1.\n', '#!perl -m'; | |
256 | is runperl(stderr => 1, prog => '#!perl -M'), | |
257 | qq 'Too late for "-M" option at -e line 1.\n', '#!perl -M'; | |
e54d2dfa JH |
258 | |
259 | # Tests for -V | |
260 | ||
261 | { | |
262 | local $TODO = ''; # these ones should work on VMS | |
263 | ||
264 | # basic perl -V should generate significant output. | |
ceda46a1 | 265 | # we don't test actual format too much since it could change |
e54d2dfa JH |
266 | like( runperl( switches => ['-V'] ), qr/(\n.*){20}/, |
267 | '-V generates 20+ lines' ); | |
268 | ||
ceda46a1 JH |
269 | like( runperl( switches => ['-V'] ), |
270 | qr/\ASummary of my perl5 .*configuration:/, | |
271 | '-V looks okay' ); | |
272 | ||
e54d2dfa JH |
273 | # lookup a known config var |
274 | chomp( $r=runperl( switches => ['-V:osname'] ) ); | |
275 | is( $r, "osname='$^O';", 'perl -V:osname'); | |
276 | ||
277 | # lookup a nonexistent var | |
278 | chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) ); | |
279 | is( $r, "this_var_makes_switches_test_fail='UNKNOWN';", | |
280 | 'perl -V:unknown var'); | |
281 | ||
282 | # regexp lookup | |
283 | # platforms that don't like this quoting can either skip this test | |
284 | # or fix test.pl _quote_args | |
285 | $r = runperl( switches => ['"-V:i\D+size"'] ); | |
286 | # should be unlike( $r, qr/^$|not found|UNKNOWN/ ); | |
287 | like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' ); | |
288 | ||
289 | # make sure each line we got matches the re | |
290 | ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' ); | |
291 | } | |
ceda46a1 JH |
292 | |
293 | # Tests for -v | |
294 | ||
295 | { | |
296 | local $TODO = ''; # these ones should work on VMS | |
e7ce59ca AC |
297 | # There may be build configs where this test will fail; DG/UX was one, |
298 | # but we no longer support it. Maybe we should remove these special cases? | |
a64c093f TC |
299 | SKIP: |
300 | { | |
301 | skip "Win32 miniperl produces a default archname in -v", 1 | |
302 | if $^O eq 'MSWin32' && is_miniperl; | |
303 | my $v = sprintf "%vd", $^V; | |
304 | my $ver = $Config{PERL_VERSION}; | |
305 | my $rel = $Config{PERL_SUBVERSION}; | |
306 | like( runperl( switches => ['-v'] ), | |
307 | qr/This is perl 5, version \Q$ver\E, subversion \Q$rel\E \(v\Q$v\E(?:[-*\w]+| \([^)]+\))?\) built for \Q$Config{archname}\E.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s, | |
308 | '-v looks okay' ); | |
309 | } | |
ceda46a1 | 310 | } |
b8e3af44 JH |
311 | |
312 | # Tests for -h | |
313 | ||
314 | { | |
315 | local $TODO = ''; # these ones should work on VMS | |
316 | ||
317 | like( runperl( switches => ['-h'] ), | |
a09a0aa2 | 318 | qr/Usage: .+(?i:perl(?:$Config{_exe})?).+switches.+programfile.+arguments/, |
b8e3af44 JH |
319 | '-h looks okay' ); |
320 | ||
321 | } | |
322 | ||
fed0ca7f | 323 | # Tests for switches which do not exist |
b8e3af44 | 324 | |
96889982 | 325 | foreach my $switch (split //, "ABbGgHJjKkLNOoPQqRrYyZz123456789_") |
b8e3af44 JH |
326 | { |
327 | local $TODO = ''; # these ones should work on VMS | |
328 | ||
fed0ca7f | 329 | like( runperl( switches => ["-$switch"], stderr => 1, |
3d7a9343 | 330 | prog => 'die q{oops}' ), |
fed0ca7f NC |
331 | qr/\QUnrecognized switch: -$switch (-h will show valid options)./, |
332 | "-$switch correctly unknown" ); | |
b8e3af44 | 333 | |
b7e077d0 FC |
334 | # [perl #104288] |
335 | like( runperl( stderr => 1, prog => "#!perl -$switch" ), | |
336 | qr/^Unrecognized switch: -$switch \(-h will show valid (?x: | |
337 | )options\) at -e line 1\./, | |
338 | "-$switch unrecognised on #! line" ); | |
339 | } | |
340 | ||
341 | # Tests for unshebangable switches | |
342 | for (qw( e f x E S V )) { | |
343 | $r = runperl( | |
344 | stderr => 1, | |
345 | prog => "#!perl -$_", | |
346 | ); | |
347 | is $r, "Can't emulate -$_ on #! line at -e line 1.\n","-$_ on #! line"; | |
b8e3af44 | 348 | } |
feafb1eb JH |
349 | |
350 | # Tests for -i | |
351 | ||
8200f806 | 352 | SKIP: |
feafb1eb JH |
353 | { |
354 | local $TODO = ''; # these ones should work on VMS | |
355 | ||
c0a22fcc | 356 | sub do_i_unlink { unlink_all("tmpswitches", "tmpswitches.bak") } |
feafb1eb | 357 | |
c0a22fcc | 358 | open(FILE, ">tmpswitches") or die "$0: Failed to create 'tmpswitches': $!"; |
929344c0 | 359 | my $yada = <<__EOF__; |
feafb1eb JH |
360 | foo yada dada |
361 | bada foo bing | |
362 | king kong foo | |
363 | __EOF__ | |
929344c0 | 364 | print FILE $yada; |
feafb1eb JH |
365 | close FILE; |
366 | ||
367 | END { do_i_unlink() } | |
368 | ||
c0a22fcc | 369 | runperl( switches => ['-pi.bak'], prog => 's/foo/bar/', args => ['tmpswitches'] ); |
feafb1eb | 370 | |
c0a22fcc | 371 | open(FILE, "tmpswitches") or die "$0: Failed to open 'tmpswitches': $!"; |
feafb1eb JH |
372 | chomp(my @file = <FILE>); |
373 | close FILE; | |
374 | ||
c0a22fcc | 375 | open(BAK, "tmpswitches.bak") or die "$0: Failed to open 'tmpswitches.bak': $!"; |
feafb1eb JH |
376 | chomp(my @bak = <BAK>); |
377 | close BAK; | |
378 | ||
379 | is(join(":", @file), | |
380 | "bar yada dada:bada bar bing:king kong bar", | |
381 | "-i new file"); | |
382 | is(join(":", @bak), | |
383 | "foo yada dada:bada foo bing:king kong foo", | |
384 | "-i backup file"); | |
82f96200 JL |
385 | |
386 | my $out1 = runperl( | |
387 | switches => ['-i.bak -p'], | |
388 | prog => 'exit', | |
389 | stderr => 1, | |
390 | stdin => "1\n", | |
391 | ); | |
392 | is( | |
393 | $out1, | |
394 | "-i used with no filenames on the command line, reading from STDIN.\n", | |
395 | "warning when no files given" | |
396 | ); | |
397 | my $out2 = runperl( | |
398 | switches => ['-i.bak -p'], | |
399 | prog => 'exit', | |
400 | stderr => 1, | |
401 | stdin => "1\n", | |
c0a22fcc | 402 | args => ['tmpswitches'], |
82f96200 JL |
403 | ); |
404 | is($out2, "", "no warning when files given"); | |
5f92e204 | 405 | |
c0a22fcc | 406 | open my $f, ">", "tmpswitches" or die "$0: failed to create 'tmpswitches': $!"; |
5f92e204 TC |
407 | print $f "foo\nbar\n"; |
408 | close $f; | |
409 | ||
410 | # a backup extension is no longer required on any platform | |
411 | my $out3 = runperl( | |
412 | switches => [ '-i', '-p' ], | |
413 | prog => 's/foo/quux/', | |
414 | stderr => 1, | |
c0a22fcc | 415 | args => [ 'tmpswitches' ], |
5f92e204 TC |
416 | ); |
417 | is($out3, "", "no warnings/errors without backup extension"); | |
c0a22fcc | 418 | open $f, "<", "tmpswitches" or die "$0: cannot open 'tmpswitches': $!"; |
5f92e204 TC |
419 | chomp(my @out4 = <$f>); |
420 | close $f; | |
421 | is(join(":", @out4), "quux:bar", "correct output without backup extension"); | |
422 | ||
8200f806 TC |
423 | eval { require File::Spec; 1 } |
424 | or skip "Cannot load File::Spec - miniperl?", 20; | |
425 | ||
719b7c2b TC |
426 | my $tmpinplace = tempfile(); |
427 | ||
428 | require File::Path; | |
429 | END { | |
430 | File::Path::rmtree($tmpinplace) | |
431 | if $tmpinplace && -d $tmpinplace; | |
432 | } | |
433 | ||
434 | # test.pl's tempfile() doesn't create the file so we can | |
435 | # safely mkdir it | |
436 | mkdir $tmpinplace | |
437 | or die "Cannot create $tmpinplace: $!"; | |
438 | ||
439 | my $work = File::Spec->catfile($tmpinplace, "foo"); | |
929344c0 TC |
440 | |
441 | # exit or die should leave original content in file | |
442 | for my $inplace (qw/-i -i.bak/) { | |
85d2f7ca | 443 | for my $prog ("die", "exit 1") { |
929344c0 TC |
444 | open my $fh, ">", $work or die "$0: failed to open '$work': $!"; |
445 | print $fh $yada; | |
446 | close $fh or die "Failed to close: $!"; | |
447 | my $out = runperl ( | |
448 | switches => [ $inplace, '-n' ], | |
449 | prog => "print q(foo\n); $prog", | |
450 | stderr => 1, | |
451 | args => [ $work ], | |
452 | ); | |
453 | open my $in, "<", $work or die "$0: failed to open '$work': $!"; | |
454 | my $data = do { local $/; <$in> }; | |
455 | close $in; | |
456 | is ($data, $yada, "check original content still in file"); | |
85d2f7ca | 457 | unlink $work, "$work.bak"; |
929344c0 TC |
458 | } |
459 | } | |
460 | ||
461 | # test that path parsing is correct | |
5f92e204 TC |
462 | open $f, ">", $work or die "Cannot create $work: $!"; |
463 | print $f "foo\nbar\n"; | |
464 | close $f; | |
465 | ||
466 | my $out4 = runperl | |
467 | ( | |
468 | switches => [ "-i", "-p" ], | |
469 | prog => 's/foo/bar/', | |
470 | stderr => 1, | |
471 | args => [ $work ], | |
472 | ); | |
473 | is ($out4, "", "no errors or warnings"); | |
474 | open $f, "<", $work or die "Cannot open $work: $!"; | |
475 | chomp(my @file4 = <$f>); | |
476 | close $f; | |
477 | is(join(":", @file4), "bar:bar", "check output"); | |
478 | ||
977bd6d6 TC |
479 | SKIP: |
480 | { | |
481 | # this needs to match how ARGV_USE_ATFUNCTIONS is defined in doio.c | |
482 | skip "Not enough *at functions", 3 | |
483 | unless $Config{d_unlinkat} && $Config{d_renameat} && $Config{d_fchmodat} | |
484 | && ($Config{d_dirfd} || $Config{d_dir_dd_fd}) | |
b416949b | 485 | && $Config{d_linkat} |
977bd6d6 | 486 | && $Config{ccflags} !~ /-DNO_USE_ATFUNCTIONS\b/; |
184f90dc TC |
487 | my ($osvers) = ($Config{osvers} =~ /^(\d+(?:\.\d+)?)/); |
488 | skip "NetBSD 6 libc defines at functions, but they're incomplete", 3 | |
719b7c2b TC |
489 | if $^O eq "netbsd" && $osvers < 7; |
490 | my $code = <<'CODE'; | |
c0a22fcc | 491 | @ARGV = ("tmpinplace/foo"); |
977bd6d6 TC |
492 | $^I = ""; |
493 | while (<>) { | |
494 | chdir ".."; | |
495 | print "xx\n"; | |
496 | } | |
497 | print "ok\n"; | |
498 | CODE | |
719b7c2b TC |
499 | $code =~ s/tmpinplace/$tmpinplace/; |
500 | fresh_perl_is($code, "ok\n", { }, | |
977bd6d6 TC |
501 | "chdir while in-place editing"); |
502 | ok(open(my $fh, "<", $work), "open out file"); | |
503 | is(scalar <$fh>, "xx\n", "file successfully saved after chdir"); | |
504 | close $fh; | |
505 | } | |
506 | ||
8ab93df0 TC |
507 | SKIP: |
508 | { | |
509 | skip "Need threads and full perl", 3 | |
510 | if !$Config{useithreads} || is_miniperl(); | |
719b7c2b TC |
511 | |
512 | my $code = <<'CODE'; | |
8ab93df0 TC |
513 | use threads; |
514 | use strict; | |
c0a22fcc | 515 | @ARGV = ("tmpinplace/foo"); |
8ab93df0 TC |
516 | $^I = ""; |
517 | while (<>) { | |
518 | threads->create(sub { })->join; | |
519 | print "yy\n"; | |
520 | } | |
521 | print "ok\n"; | |
522 | CODE | |
719b7c2b TC |
523 | $code =~ s/tmpinplace/$tmpinplace/; |
524 | fresh_perl_is($code, "ok\n", { stderr => 1 }, | |
8ab93df0 TC |
525 | "threads while in-place editing"); |
526 | ok(open(my $fh, "<", $work), "open out file"); | |
527 | is(scalar <$fh>, "yy\n", "file successfully saved after chdir"); | |
528 | close $fh; | |
529 | } | |
530 | ||
05df5c88 TC |
531 | SKIP: |
532 | { | |
533 | skip "Need fork", 3 if !$Config{d_fork}; | |
534 | open my $fh, ">", $work | |
535 | or die "Cannot open $work: $!"; | |
536 | # we want only a single line for this test, otherwise | |
537 | # it attempts to close the file twice | |
538 | print $fh "foo\n"; | |
539 | close $fh or die "Cannot close $work: $!"; | |
719b7c2b | 540 | my $code = <<'CODE'; |
05df5c88 | 541 | use strict; |
c0a22fcc | 542 | @ARGV = ("tmpinplace/foo"); |
05df5c88 TC |
543 | $^I = ""; |
544 | while (<>) { | |
545 | my $pid = fork; | |
546 | if (defined $pid && !$pid) { | |
547 | # child | |
548 | close ARGVOUT or die "Cannot close in child\n"; # this shouldn't do ARGVOUT magic | |
549 | exit 0; | |
550 | } | |
551 | wait; | |
552 | print "yy\n"; | |
553 | close ARGVOUT or die "Cannot close in parent\n"; # this should | |
554 | } | |
555 | print "ok\n"; | |
556 | CODE | |
719b7c2b TC |
557 | $code =~ s/tmpinplace/$tmpinplace/; |
558 | fresh_perl_is($code, "ok\n", { stderr => 1 }, | |
05df5c88 TC |
559 | "fork while in-place editing"); |
560 | ok(open($fh, "<", $work), "open out file"); | |
184f90dc | 561 | is(scalar <$fh>, "yy\n", "file successfully saved after fork"); |
05df5c88 TC |
562 | close $fh; |
563 | } | |
564 | ||
83419aa9 TC |
565 | { |
566 | # test we handle the rename to the backup failing | |
a33b278e CB |
567 | if ($^O eq 'VMS') { |
568 | # make it fail by creating a .bak file with a version than which no higher can be created | |
569 | # can't make a directory because foo.bak and foo^.bak.DIR do not conflict. | |
570 | open my $fh, '>', "$work.bak;32767" or die "Cannot make mask backup file: $!"; | |
571 | close $fh or die "Failed to close: $!"; | |
572 | } | |
573 | else { | |
574 | # make it fail by creating a directory of the backup name | |
575 | mkdir "$work.bak" or die "Cannot make mask backup directory: $!"; | |
576 | } | |
719b7c2b | 577 | my $code = <<'CODE'; |
c0a22fcc | 578 | @ARGV = ("tmpinplace/foo"); |
83419aa9 TC |
579 | $^I = ".bak"; |
580 | while (<>) { | |
581 | print; | |
582 | } | |
583 | print "ok\n"; | |
584 | CODE | |
719b7c2b TC |
585 | $code =~ s/tmpinplace/$tmpinplace/; |
586 | fresh_perl_like($code, qr/Can't rename/, { stderr => 1 }, "fail backup rename"); | |
a33b278e CB |
587 | if ($^O eq 'VMS') { |
588 | 1 while unlink "$work.bak"; | |
589 | } | |
590 | else { | |
591 | rmdir "$work.bak" or die "Cannot remove mask backup directory: $!"; | |
592 | } | |
83419aa9 TC |
593 | } |
594 | ||
84dbe61c TC |
595 | { |
596 | # test with absolute paths, this was failing on FreeBSD 11ish due | |
597 | # to a bug in renameat() | |
598 | my $abs_work = File::Spec->rel2abs($work); | |
599 | fresh_perl_is(<<'CODE', "", | |
600 | while (<>) { | |
601 | print; | |
602 | } | |
603 | CODE | |
604 | { stderr => 1, args => [ $abs_work ], switches => [ "-i" ] }, | |
605 | "abs paths"); | |
606 | } | |
607 | ||
5f92e204 TC |
608 | # we now use temp files for in-place editing, make sure we didn't leave |
609 | # any behind in the above test | |
719b7c2b | 610 | opendir my $d, $tmpinplace or die "Cannot opendir $tmpinplace: $!"; |
a33b278e | 611 | my @names = grep !/^\.\.?$/ && $_ ne 'foo' && $_ ne 'foo.', readdir $d; |
5f92e204 TC |
612 | closedir $d; |
613 | is(scalar(@names), 0, "no extra files") | |
614 | or diag "Found @names, expected none"; | |
929344c0 | 615 | |
bb082417 TC |
616 | # the following tests might leave work files behind |
617 | ||
dddabd86 TC |
618 | # this test can leave the work file in the directory, since making |
619 | # the directory non-writable also prevents removing the work file | |
620 | SKIP: | |
621 | { | |
622 | # test we handle the rename of the work to the original failing | |
623 | # make it fail by removing write perms from the directory | |
624 | # but first check that doesn't prevent writing | |
719b7c2b TC |
625 | chmod 0500, $tmpinplace; |
626 | my $check = File::Spec->catfile($tmpinplace, "check"); | |
dddabd86 TC |
627 | my $canwrite = open my $fh, ">", $check; |
628 | unlink $check; | |
719b7c2b TC |
629 | chmod 0700, $tmpinplace or die "Cannot make $tmpinplace writable again: $!"; |
630 | skip "Cannot make $tmpinplace read only", 1 | |
dddabd86 | 631 | if $canwrite; |
719b7c2b | 632 | my $code = <<'CODE'; |
c0a22fcc | 633 | @ARGV = ("tmpinplace/foo"); |
dddabd86 TC |
634 | $^I = ""; |
635 | while (<>) { | |
c0a22fcc | 636 | chmod 0500, "tmpinplace"; |
dddabd86 TC |
637 | print; |
638 | } | |
639 | print "ok\n"; | |
640 | CODE | |
719b7c2b TC |
641 | $code =~ s/tmpinplace/$tmpinplace/g; |
642 | fresh_perl_like($code, qr/failed to rename/, { stderr => 1 }, "fail final rename"); | |
643 | chmod 0700, $tmpinplace or die "Cannot make $tmpinplace writable again: $!"; | |
dddabd86 TC |
644 | } |
645 | ||
bb082417 TC |
646 | SKIP: |
647 | { | |
648 | # this needs to reverse match how ARGV_USE_ATFUNCTIONS is defined in doio.c | |
649 | skip "Testing without *at functions", 1 | |
650 | if $Config{d_unlinkat} && $Config{d_renameat} && $Config{d_fchmodat} | |
651 | && ($Config{d_dirfd} || $Config{d_dir_dd_fd}) | |
b416949b | 652 | && $Config{d_linkat} |
bb082417 | 653 | && $Config{ccflags} !~ /-DNO_USE_ATFUNCTIONS\b/; |
719b7c2b | 654 | my $code = <<'CODE'; |
c0a22fcc | 655 | @ARGV = ("tmpinplace/foo"); |
bb082417 TC |
656 | $^I = ""; |
657 | while (<>) { | |
658 | chdir ".."; | |
659 | print "xx\n"; | |
660 | } | |
661 | print "ok\n"; | |
662 | CODE | |
719b7c2b TC |
663 | $code =~ s/tmpinplace/$tmpinplace/; |
664 | fresh_perl_like($code, qr/^Cannot complete in-place edit of \Q$tmpinplace\E\/foo: .* - line 5, <> line \d+\./, { }, | |
bb082417 TC |
665 | "chdir while in-place editing (no at-functions)"); |
666 | } | |
667 | ||
dddabd86 TC |
668 | unlink $work; |
669 | ||
719b7c2b | 670 | opendir $d, $tmpinplace or die "Cannot opendir $tmpinplace: $!"; |
bb082417 | 671 | @names = grep !/^\.\.?$/ && !/foo$/aai, readdir $d; |
dddabd86 TC |
672 | closedir $d; |
673 | ||
5a39f542 | 674 | # clean up in case the above failed |
719b7c2b | 675 | unlink map File::Spec->catfile($tmpinplace, $_), @names; |
5a39f542 | 676 | |
719b7c2b TC |
677 | rmdir $tmpinplace; |
678 | undef $tmpinplace; | |
feafb1eb | 679 | } |
bc9b29db RH |
680 | |
681 | # Tests for -E | |
682 | ||
3012b817 CB |
683 | $TODO = ''; # the -E tests work on VMS |
684 | ||
bc9b29db RH |
685 | $r = runperl( |
686 | switches => [ '-E', '"say q(Hello, world!)"'] | |
687 | ); | |
688 | is( $r, "Hello, world!\n", "-E say" ); | |
689 | ||
690 | ||
691 | $r = runperl( | |
7896dde7 Z |
692 | switches => [ '-E', '"no warnings q{experimental::smartmatch}; undef ~~ undef and say q(Hello, world!)"'] |
693 | ); | |
694 | is( $r, "Hello, world!\n", "-E ~~" ); | |
695 | ||
696 | $r = runperl( | |
697 | switches => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(undef) { say q(Hello, world!)"}}'] | |
bc9b29db RH |
698 | ); |
699 | is( $r, "Hello, world!\n", "-E given" ); | |
9f639728 FR |
700 | |
701 | $r = runperl( | |
f21873d1 | 702 | switches => [ '-nE', q("} END { say q/affe/") ], |
9f639728 FR |
703 | stdin => 'zomtek', |
704 | ); | |
705 | is( $r, "affe\n", '-E works outside of the block created by -n' ); | |
d3133c89 | 706 | |
53eb19dd S |
707 | $r = runperl( |
708 | switches => [ '-E', q("*{'bar'} = sub{}; print 'Hello, world!',qq|\n|;")] | |
709 | ); | |
710 | is( $r, "Hello, world!\n", "-E does not enable strictures" ); | |
711 | ||
d3133c89 NC |
712 | # RT #30660 |
713 | ||
714 | $filename = tempfile(); | |
715 | SKIP: { | |
716 | open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); | |
717 | print $f <<'SWTEST'; | |
718 | #!perl -w -iok | |
719 | print "$^I\n"; | |
720 | SWTEST | |
721 | close $f or die "Could not close: $!"; | |
722 | $r = runperl( | |
723 | progfile => $filename, | |
724 | ); | |
725 | like( $r, qr/ok/, 'Spaces on the #! line (#30660)' ); | |
726 | } |