Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
90ce63d5 | 3 | BEGIN { |
90ce63d5 RS |
4 | $| = 1; |
5 | chdir 't' if -d 't'; | |
20822f61 | 6 | @INC = '../lib'; |
5e9f035f | 7 | require './test.pl'; |
213084e4 | 8 | plan (tests => 156); |
5e9f035f FC |
9 | } |
10 | ||
11 | # Test that defined() returns true for magic variables created on the fly, | |
12 | # even before they have been created. | |
13 | # This must come first, even before turning on warnings or setting up | |
14 | # $SIG{__WARN__}, to avoid invalidating the tests. warnings.pm currently | |
15 | # does not mention any special variables, but that could easily change. | |
16 | BEGIN { | |
811a7562 | 17 | # not available in miniperl |
b82b06b8 | 18 | my %non_mini = map { $_ => 1 } qw(+ - [); |
5e9f035f FC |
19 | for (qw( |
20 | SIG ^OPEN ^TAINT ^UNICODE ^UTF8LOCALE ^WARNING_BITS 1 2 3 4 5 6 7 8 | |
23496c6e | 21 | 9 42 & ` ' : ? ! _ - [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D |
b4155db2 | 22 | ^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W ^UTF8CACHE ::12345 main::98732 |
5e9f035f FC |
23 | )) { |
24 | my $v = $_; | |
25 | # avoid using any global vars here: | |
26 | if ($v =~ s/^\^(?=.)//) { | |
27 | for(substr $v, 0, 1) { | |
28 | $_ = chr ord() - 64; | |
29 | } | |
30 | } | |
811a7562 TC |
31 | SKIP: |
32 | { | |
33 | skip_if_miniperl("the module for *$_ may not be available in " | |
34 | . "miniperl", 1) if $non_mini{$_}; | |
35 | ok defined *$v, "*$_ appears to be defined at the outset"; | |
36 | } | |
5e9f035f FC |
37 | } |
38 | } | |
39 | ||
40 | # This must be in a separate BEGIN block, as the mere mention of ${^TAINT} | |
41 | # will invalidate the test for it. | |
42 | BEGIN { | |
0409250f | 43 | $ENV{PATH} = '/bin' if ${^TAINT}; |
774d564b | 44 | $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; |
90ce63d5 | 45 | } |
8d063cd8 | 46 | |
9f1b1f2d | 47 | use warnings; |
04fee9b5 | 48 | use Config; |
9f1b1f2d | 49 | |
0bee926d | 50 | |
43651d81 NC |
51 | $Is_MSWin32 = $^O eq 'MSWin32'; |
52 | $Is_NetWare = $^O eq 'NetWare'; | |
53 | $Is_VMS = $^O eq 'VMS'; | |
54 | $Is_Dos = $^O eq 'dos'; | |
55 | $Is_os2 = $^O eq 'os2'; | |
56 | $Is_Cygwin = $^O eq 'cygwin'; | |
43651d81 | 57 | $Is_MPE = $^O eq 'mpeix'; |
dbc1d986 | 58 | $Is_BeOS = $^O eq 'beos'; |
be708cc0 | 59 | |
c8d62b71 RGS |
60 | $PERL = $ENV{PERL} |
61 | || ($Is_NetWare ? 'perl' : | |
7b903762 | 62 | $Is_VMS ? $^X : |
c8d62b71 RGS |
63 | $Is_MSWin32 ? '.\perl' : |
64 | './perl'); | |
68dc0745 | 65 | |
8df0e0ed JM |
66 | END { |
67 | # On VMS, environment variable changes are peristent after perl exits | |
68 | delete $ENV{'FOO'} if $Is_VMS; | |
69 | } | |
70 | ||
39e571d4 | 71 | eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval |
26f6e342 NK |
72 | # cmd.exe will echo 'variable=value' but 4nt will echo just the value |
73 | # -- Nikola Knezevic | |
b2978f4e | 74 | if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/; } |
b2978f4e NC |
75 | elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } |
76 | else { is `echo \$FOO`, "hi there\n"; } | |
8d063cd8 | 77 | |
ba2406eb | 78 | unlink_all 'ajslkdfpqjsjfk'; |
8d063cd8 | 79 | $! = 0; |
90ce63d5 | 80 | open(FOO,'ajslkdfpqjsjfk'); |
b2978f4e | 81 | isnt($!, 0); |
90ce63d5 | 82 | close FOO; # just mention it, squelch used-only-once |
8d063cd8 | 83 | |
b2978f4e NC |
84 | SKIP: { |
85 | skip('SIGINT not safe on this platform', 5) | |
7b903762 | 86 | if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE; |
c363d00c CB |
87 | # the next tests are done in a subprocess because sh spits out a |
88 | # newline onto stderr when a child process kills itself with SIGINT. | |
04fee9b5 | 89 | # We use a pipe rather than system() because the VMS command buffer |
c363d00c CB |
90 | # would overflow with a command that long. |
91 | ||
5e9f035f FC |
92 | # For easy interpolation of test numbers: |
93 | $next_test = curr_test() - 1; | |
94 | sub TIEARRAY {bless[]} | |
95 | sub FETCH { $next_test + pop } | |
96 | tie my @tn, __PACKAGE__; | |
97 | ||
c363d00c CB |
98 | open( CMDPIPE, "| $PERL"); |
99 | ||
5e9f035f | 100 | print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END'; |
378cc40b | 101 | |
79072805 | 102 | $| = 1; # command buffering |
378cc40b | 103 | |
5e9f035f FC |
104 | $SIG{"INT"} = "ok1"; kill "INT",$$; sleep 1; |
105 | $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok $t2\n"; | |
106 | $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print" not ok $t2\n"; | |
79072805 | 107 | |
5e9f035f | 108 | sub ok1 { |
79072805 | 109 | if (($x = pop(@_)) eq "INT") { |
5e9f035f | 110 | print "ok $t1\n"; |
79072805 LW |
111 | } |
112 | else { | |
5e9f035f | 113 | print "not ok $t1 ($x @_)\n"; |
79072805 LW |
114 | } |
115 | } | |
116 | ||
117 | END | |
c363d00c CB |
118 | |
119 | close CMDPIPE; | |
120 | ||
2d4fcd5e | 121 | open( CMDPIPE, "| $PERL"); |
5e9f035f | 122 | print CMDPIPE "\$t3 = $tn[3];\n", <<'END'; |
2d4fcd5e AJ |
123 | |
124 | { package X; | |
125 | sub DESTROY { | |
126 | kill "INT",$$; | |
127 | } | |
128 | } | |
129 | sub x { | |
130 | my $x=bless [], 'X'; | |
131 | return sub { $x }; | |
132 | } | |
133 | $| = 1; # command buffering | |
5e9f035f | 134 | $SIG{"INT"} = "ok3"; |
2d4fcd5e AJ |
135 | { |
136 | local $SIG{"INT"}=x(); | |
137 | print ""; # Needed to expose failure in 5.8.0 (why?) | |
138 | } | |
139 | sleep 1; | |
140 | delete $SIG{"INT"}; | |
141 | kill "INT",$$; sleep 1; | |
5e9f035f FC |
142 | sub ok3 { |
143 | print "ok $t3\n"; | |
2d4fcd5e AJ |
144 | } |
145 | END | |
146 | close CMDPIPE; | |
bb4e15c8 | 147 | $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte |
639cf43b | 148 | my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); |
5e9f035f | 149 | print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n"; |
2d4fcd5e | 150 | |
6e592b3a BM |
151 | open(CMDPIPE, "| $PERL"); |
152 | print CMDPIPE <<'END'; | |
153 | ||
154 | sub PVBM () { 'foo' } | |
155 | index 'foo', PVBM; | |
156 | my $pvbm = PVBM; | |
157 | ||
158 | sub foo { exit 0 } | |
159 | ||
160 | $SIG{"INT"} = $pvbm; | |
161 | kill "INT", $$; sleep 1; | |
162 | END | |
163 | close CMDPIPE; | |
164 | $? >>= 8 if $^O eq 'VMS'; | |
5e9f035f | 165 | print $? ? "not ok $tn[5]\n" : "ok $tn[5]\n"; |
6e592b3a | 166 | |
b2978f4e | 167 | curr_test(curr_test() + 5); |
68dc0745 | 168 | } |
a687059c | 169 | |
68dc0745 | 170 | # can we slice ENV? |
171 | @val1 = @ENV{keys(%ENV)}; | |
a687059c | 172 | @val2 = values(%ENV); |
b2978f4e NC |
173 | is join(':',@val1), join(':',@val2); |
174 | cmp_ok @val1, '>', 1; | |
90ce63d5 RS |
175 | |
176 | # regex vars | |
177 | 'foobarbaz' =~ /b(a)r/; | |
b2978f4e NC |
178 | is $`, 'foo'; |
179 | is $&, 'bar'; | |
180 | is $', 'baz'; | |
181 | is $+, 'a'; | |
90ce63d5 | 182 | |
a289ef89 FC |
183 | # [perl #24237] |
184 | for (qw < ` & ' >) { | |
185 | fresh_perl_is | |
186 | qq < \@$_; q "fff" =~ /(?!^)./; print "[\$$_]\\n" >, | |
187 | "[f]\n", {}, | |
188 | "referencing \@$_ before \$$_ etc. still saws off ampersands"; | |
189 | } | |
190 | ||
90ce63d5 RS |
191 | # $" |
192 | @a = qw(foo bar baz); | |
b2978f4e | 193 | is "@a", "foo bar baz"; |
90ce63d5 RS |
194 | { |
195 | local $" = ','; | |
b2978f4e | 196 | is "@a", "foo,bar,baz"; |
90ce63d5 | 197 | } |
a687059c | 198 | |
90ce63d5 RS |
199 | # $; |
200 | %h = (); | |
201 | $h{'foo', 'bar'} = 1; | |
b2978f4e | 202 | is((keys %h)[0], "foo\034bar"); |
90ce63d5 RS |
203 | { |
204 | local $; = 'x'; | |
205 | %h = (); | |
206 | $h{'foo', 'bar'} = 1; | |
b2978f4e | 207 | is((keys %h)[0], 'fooxbar'); |
90ce63d5 | 208 | } |
ed6116ce | 209 | |
90ce63d5 | 210 | # $?, $@, $$ |
7b903762 RGS |
211 | system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"]; |
212 | is $?, 0; | |
213 | system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"]; | |
214 | isnt $?, 0; | |
90ce63d5 RS |
215 | |
216 | eval { die "foo\n" }; | |
b2978f4e | 217 | is $@, "foo\n"; |
90ce63d5 | 218 | |
b2978f4e | 219 | cmp_ok($$, '>', 0); |
41e07bbc | 220 | my $pid = $$; |
9cdac2a2 FC |
221 | eval { $$ = 42 }; |
222 | is $$, 42, '$$ can be modified'; | |
223 | SKIP: { | |
224 | skip "no fork", 1 unless $Config{d_fork}; | |
225 | (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1; | |
226 | if($kidpid) { # parent | |
227 | my $kiddollars = <$fh>; | |
228 | close $fh or die "cannot close pipe from kid proc: $!"; | |
229 | is $kiddollars, $kidpid, '$$ is reset on fork'; | |
230 | } | |
231 | else { # child | |
232 | print $$; | |
233 | $::NO_ENDING = 1; # silence "Looks like you only ran..." | |
234 | exit; | |
235 | } | |
236 | } | |
41e07bbc | 237 | $$ = $pid; # Tests below use $$ |
90ce63d5 RS |
238 | |
239 | # $^X and $0 | |
ed37317b | 240 | { |
ae60cb46 NC |
241 | my $is_abs = $Config{d_procselfexe} || $Config{usekernprocpathname} |
242 | || $Config{usensgetexecutablepath}; | |
3e3baf6d | 243 | if ($^O eq 'qnx') { |
7fbf1995 | 244 | chomp($wd = `/usr/bin/fullpath -t`); |
68dc0745 | 245 | } |
2982a345 | 246 | elsif($Is_Cygwin || $is_abs) { |
1cab015a EF |
247 | # Cygwin turns the symlink into the real file |
248 | chomp($wd = `pwd`); | |
249 | $wd =~ s#/t$##; | |
0409250f | 250 | $wd =~ /(.*)/; $wd = $1; # untaint |
6178c52a JH |
251 | if ($Is_Cygwin) { |
252 | $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1)); | |
253 | } | |
1cab015a | 254 | } |
ed344e4f IZ |
255 | elsif($Is_os2) { |
256 | $wd = Cwd::sys_cwd(); | |
257 | } | |
68dc0745 | 258 | else { |
259 | $wd = '.'; | |
260 | } | |
2982a345 | 261 | my $perl = $Is_VMS || $is_abs ? $^X : "$wd/perl"; |
ed37317b | 262 | my $headmaybe = ''; |
6178c52a | 263 | my $middlemaybe = ''; |
ed37317b | 264 | my $tailmaybe = ''; |
68dc0745 | 265 | $script = "$wd/show-shebang"; |
ed37317b TB |
266 | if ($Is_MSWin32) { |
267 | chomp($wd = `cd`); | |
8ac9c18d GS |
268 | $wd =~ s|\\|/|g; |
269 | $perl = "$wd/perl.exe"; | |
270 | $script = "$wd/show-shebang.bat"; | |
ed37317b TB |
271 | $headmaybe = <<EOH ; |
272 | \@rem =' | |
273 | \@echo off | |
274 | $perl -x \%0 | |
275 | goto endofperl | |
276 | \@rem '; | |
277 | EOH | |
278 | $tailmaybe = <<EOT ; | |
279 | ||
280 | __END__ | |
281 | :endofperl | |
282 | EOT | |
283 | } | |
ed344e4f IZ |
284 | elsif ($Is_os2) { |
285 | $script = "./show-shebang"; | |
286 | } | |
c363d00c CB |
287 | elsif ($Is_VMS) { |
288 | $script = "[]show-shebang"; | |
be708cc0 | 289 | } |
6178c52a JH |
290 | elsif ($Is_Cygwin) { |
291 | $middlemaybe = <<'EOX' | |
292 | $^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1)); | |
293 | $0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1)); | |
294 | EOX | |
295 | } | |
a1a0e61e | 296 | if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang |
9d116dd7 JH |
297 | $headmaybe = <<EOH ; |
298 | eval 'exec ./perl -S \$0 \${1+"\$\@"}' | |
299 | if 0; | |
300 | EOH | |
301 | } | |
2eecd615 | 302 | $s1 = "\$^X is $perl, \$0 is $script\n"; |
0409250f | 303 | ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!"; |
b2978f4e | 304 | ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!; |
0f77baf6 | 305 | #!$perl |
774d564b | 306 | EOB |
90ce63d5 RS |
307 | print "\$^X is $^X, \$0 is $0\n"; |
308 | EOF | |
b2978f4e NC |
309 | ok close(SCRIPT) or diag $!; |
310 | ok chmod(0755, $script) or diag $!; | |
7b903762 | 311 | $_ = $Is_VMS ? `$perl $script` : `$script`; |
ed344e4f | 312 | s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; |
dbc1d986 | 313 | s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect |
ed37317b | 314 | s{is perl}{is $perl}; # for systems where $^X is only a basename |
a6c40364 | 315 | s{\\}{/}g; |
b2978f4e NC |
316 | if ($Is_MSWin32 || $Is_os2) { |
317 | is uc $_, uc $s1; | |
318 | } else { | |
319 | is $_, $s1; | |
320 | } | |
ed37317b | 321 | $_ = `$perl $script`; |
4bbb7126 | 322 | s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin; |
dbc1d986 | 323 | s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect |
a6c40364 | 324 | s{\\}{/}g; |
b2978f4e NC |
325 | if ($Is_MSWin32 || $Is_os2) { |
326 | is uc $_, uc $s1; | |
327 | } else { | |
328 | is $_, $s1; | |
329 | } | |
330 | ok unlink($script) or diag $!; | |
ba2406eb BG |
331 | # CHECK |
332 | # Could this be replaced with: | |
333 | # unlink_all($script); | |
68dc0745 | 334 | } |
ed6116ce | 335 | |
90ce63d5 | 336 | # $], $^O, $^T |
b2978f4e | 337 | cmp_ok $], '>=', 5.00319; |
0bee926d | 338 | ok $^O; |
b2978f4e | 339 | cmp_ok $^T, '>', 850000000; |
66b1d557 | 340 | |
881ddac4 SH |
341 | # Test change 25062 is working |
342 | my $orig_osname = $^O; | |
343 | { | |
344 | local $^I = '.bak'; | |
b2978f4e | 345 | is $^O, $orig_osname, 'Assigning $^I does not clobber $^O'; |
881ddac4 SH |
346 | } |
347 | $^O = $orig_osname; | |
348 | ||
065144c6 TC |
349 | { |
350 | #RT #72422 | |
351 | foreach my $p (0, 1) { | |
352 | fresh_perl_is(<<"EOP", '2 4 8', undef, "test \$^P = $p"); | |
353 | \$DB::single = 2; | |
354 | \$DB::trace = 4; | |
355 | \$DB::signal = 8; | |
356 | \$^P = $p; | |
357 | print "\$DB::single \$DB::trace \$DB::signal"; | |
358 | EOP | |
359 | } | |
360 | } | |
361 | ||
7636ea95 AB |
362 | # Check that assigning to $0 on Linux sets the process name with both |
363 | # argv[0] assignment and by calling prctl() | |
364 | { | |
365 | SKIP: { | |
366 | skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name}; | |
367 | ||
368 | # We don't really need these tests. prctl() is tested in the | |
369 | # Kernel, but test it anyway for our sanity. If something doesn't | |
370 | # work (like if the system doesn't have a ps(1) for whatever | |
371 | # reason) just bail out gracefully. | |
372 | my $maybe_ps = sub { | |
373 | my ($cmd) = @_; | |
374 | local ($?, $!); | |
375 | ||
376 | no warnings; | |
377 | my $res = `$cmd`; | |
3a46d15c | 378 | skip "Couldn't shell out to '$cmd', returned code $?", 2 if $?; |
7636ea95 AB |
379 | return $res; |
380 | }; | |
381 | ||
382 | my $name = "Good Morning, Dave"; | |
383 | $0 = $name; | |
384 | ||
385 | chomp(my $argv0 = $maybe_ps->("ps h $$")); | |
386 | chomp(my $prctl = $maybe_ps->("ps hc $$")); | |
387 | ||
388 | like($argv0, $name, "Set process name through argv[0] ($argv0)"); | |
389 | like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)"); | |
390 | } | |
391 | } | |
392 | ||
c7213721 | 393 | { |
a45269de MS |
394 | my $ok = 1; |
395 | my $warn = ''; | |
ae8ade65 | 396 | local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; }; |
78987ded | 397 | $! = undef; |
b2978f4e NC |
398 | local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : ''; |
399 | ok($ok, $warn); | |
78987ded HS |
400 | } |
401 | ||
b2978f4e | 402 | SKIP: { |
d3d1232e | 403 | skip_if_miniperl("miniperl can't rely on loading %Errno", 2); |
126c71c8 YST |
404 | no warnings 'void'; |
405 | ||
d2c93421 RH |
406 | # Make sure Errno hasn't been prematurely autoloaded |
407 | ||
b79f7545 | 408 | ok !keys %Errno::; |
d2c93421 RH |
409 | |
410 | # Test auto-loading of Errno when %! is used | |
411 | ||
126c71c8 YST |
412 | ok scalar eval q{ |
413 | %!; | |
902fde96 | 414 | scalar %Errno::; |
126c71c8 YST |
415 | }, $@; |
416 | } | |
d2c93421 | 417 | |
b2978f4e | 418 | SKIP: { |
ffdb8bcd | 419 | skip_if_miniperl("miniperl can't rely on loading %Errno", 2); |
43651d81 | 420 | # Make sure that Errno loading doesn't clobber $! |
d2c93421 | 421 | |
43651d81 NC |
422 | undef %Errno::; |
423 | delete $INC{"Errno.pm"}; | |
d2c93421 | 424 | |
43651d81 NC |
425 | open(FOO, "nonesuch"); # Generate ENOENT |
426 | my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time | |
427 | ok ${"!"}{ENOENT}; | |
ffdb8bcd FC |
428 | |
429 | # Make sure defined(*{"!"}) before %! does not stop %! from working | |
430 | is | |
431 | runperl( | |
432 | prog => 'BEGIN { defined *{q-!-} } print qq-ok\n- if tied %!', | |
433 | ), | |
434 | "ok\n", | |
435 | 'defined *{"!"} does not stop %! from working'; | |
43651d81 | 436 | } |
a4268c0a | 437 | |
ccdda9cb | 438 | # Check that we don't auto-load packages |
976bd1ee DM |
439 | SKIP: { |
440 | skip "staticly linked; may be preloaded", 4 unless $Config{usedl}; | |
441 | foreach (['powie::!', 'Errno'], | |
442 | ['powie::+', 'Tie::Hash::NamedCapture']) { | |
443 | my ($symbol, $package) = @$_; | |
444 | foreach my $scalar_first ('', '$$symbol;') { | |
445 | my $desc = qq{Referencing %{"$symbol"}}; | |
446 | $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first; | |
447 | $desc .= " doesn't load $package"; | |
448 | ||
449 | fresh_perl_is(<<"EOP", 0, {}, $desc); | |
ccdda9cb NC |
450 | use strict qw(vars subs); |
451 | my \$symbol = '$symbol'; | |
452 | $scalar_first; | |
453 | 1 if %{\$symbol}; | |
454 | print scalar %${package}::; | |
455 | EOP | |
976bd1ee | 456 | } |
ccdda9cb NC |
457 | } |
458 | } | |
459 | ||
b2978f4e NC |
460 | is $^S, 0; |
461 | eval { is $^S,1 }; | |
b0e6f864 | 462 | eval " BEGIN { ok ! defined \$^S } "; |
b2978f4e | 463 | is $^S, 0; |
7c36658b | 464 | |
0409250f RGS |
465 | my $taint = ${^TAINT}; |
466 | is ${^TAINT}, $taint; | |
7c36658b | 467 | eval { ${^TAINT} = 1 }; |
0409250f | 468 | is ${^TAINT}, $taint; |
9aa702ec MJD |
469 | |
470 | # 5.6.1 had a bug: @+ and @- were not properly interpolated | |
471 | # into double-quoted strings | |
472 | # 20020414 mjd-perl-patch+@plover.com | |
b64ebf53 | 473 | "I like pie" =~ /(I) (like) (pie)/; |
b2978f4e NC |
474 | is "@-", "0 0 2 7"; |
475 | is "@+", "10 1 6 10"; | |
9aa702ec | 476 | |
f28098ff RGS |
477 | # Tests for the magic get of $\ |
478 | { | |
479 | my $ok = 0; | |
480 | # [perl #19330] | |
481 | { | |
482 | local $\ = undef; | |
483 | $\++; $\++; | |
484 | $ok = $\ eq 2; | |
485 | } | |
486 | ok $ok; | |
487 | $ok = 0; | |
488 | { | |
489 | local $\ = "a\0b"; | |
490 | $ok = "a$\b" eq "aa\0bb"; | |
491 | } | |
492 | ok $ok; | |
493 | } | |
547d1dd8 | 494 | |
4c9140ed | 495 | # Test for bug [perl #36434] |
b2978f4e NC |
496 | # Can not do this test on VMS, EPOC, and SYMBIAN according to comments |
497 | # in mg.c/Perl_magic_clear_all_env() | |
498 | SKIP: { | |
499 | skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; | |
500 | ||
4c9140ed RGS |
501 | local @ISA; |
502 | local %ENV; | |
e1a479c5 BB |
503 | # This used to be __PACKAGE__, but that causes recursive |
504 | # inheritance, which is detected earlier now and broke | |
505 | # this test | |
506 | eval { push @ISA, __FILE__ }; | |
b2978f4e | 507 | is $@, '', 'Push a constant on a magic array'; |
4c9140ed RGS |
508 | $@ and print "# $@"; |
509 | eval { %ENV = (PATH => __PACKAGE__) }; | |
b2978f4e | 510 | is $@, '', 'Assign a constant to a magic hash'; |
d8084ca5 DM |
511 | $@ and print "# $@"; |
512 | eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; | |
b2978f4e | 513 | is $@, '', 'Assign a shared key to a magic hash'; |
4c9140ed RGS |
514 | $@ and print "# $@"; |
515 | } | |
179c85a2 NC |
516 | |
517 | # Tests for Perl_magic_clearsig | |
518 | foreach my $sig (qw(__WARN__ INT)) { | |
519 | $SIG{$sig} = lc $sig; | |
520 | is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; | |
521 | is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; | |
522 | is $SIG{$sig}, undef, "$sig is now gone"; | |
523 | is delete $SIG{$sig}, undef, "$sig remains gone"; | |
524 | } | |
525 | ||
526 | # And now one which doesn't exist; | |
527 | { | |
528 | no warnings 'signal'; | |
529 | $SIG{HUNGRY} = 'mmm, pie'; | |
530 | } | |
531 | is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; | |
532 | is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; | |
533 | is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; | |
534 | is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; | |
535 | ||
536 | # Test deleting signals that we never set | |
c8be058c | 537 | foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { |
179c85a2 NC |
538 | is $SIG{$sig}, undef, "$sig is not present"; |
539 | is delete $SIG{$sig}, undef, "delete of $sig returns undef"; | |
540 | } | |
be1cf43c NC |
541 | |
542 | { | |
543 | $! = 9999; | |
544 | is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; | |
545 | ||
546 | } | |
4c0f30d6 | 547 | |
213084e4 FC |
548 | # %+ %- |
549 | SKIP: { | |
afb8fe69 | 550 | skip_if_miniperl("No XS in miniperl", 2); |
213084e4 FC |
551 | # Make sure defined(*{"+"}) before %+ does not stop %+ from working |
552 | is | |
553 | runperl( | |
554 | prog => 'BEGIN { defined *{q-+-} } print qq-ok\n- if tied %+', | |
555 | ), | |
556 | "ok\n", | |
557 | 'defined *{"+"} does not stop %+ from working'; | |
558 | is | |
559 | runperl( | |
560 | prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-', | |
561 | ), | |
562 | "ok\n", | |
563 | 'defined *{"-"} does not stop %- from working'; | |
564 | } | |
565 | ||
0ea03996 FC |
566 | SKIP: { |
567 | skip_if_miniperl("No XS in miniperl", 3); | |
568 | ||
569 | for ( [qw( %- Tie::Hash::NamedCapture )], [qw( $[ arybase )], | |
570 | [qw( %! Errno )] ) { | |
571 | my ($var, $mod) = @$_; | |
572 | my $modfile = $mod =~ s|::|/|gr . ".pm"; | |
573 | fresh_perl_is | |
574 | qq 'sub UNIVERSAL::AUTOLOAD{} | |
575 | $mod\::foo() if 0; | |
576 | $var; | |
577 | print "ok\\n" if \$INC{"$modfile"}', | |
578 | "ok\n", | |
579 | { switches => [ '-X' ] }, | |
580 | "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist"; | |
581 | } | |
582 | } | |
583 | ||
61ec922c NC |
584 | # ^^^^^^^^^ New tests go here ^^^^^^^^^ |
585 | ||
586 | SKIP: { | |
587 | skip("%ENV manipulations fail or aren't safe on $^O", 4) | |
588 | if $Is_VMS || $Is_Dos; | |
589 | ||
590 | SKIP: { | |
591 | skip("clearing \%ENV is not safe when running under valgrind") | |
592 | if $ENV{PERL_VALGRIND}; | |
593 | ||
594 | $PATH = $ENV{PATH}; | |
595 | $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; | |
596 | $ENV{foo} = "bar"; | |
597 | %ENV = (); | |
598 | $ENV{PATH} = $PATH; | |
599 | $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; | |
600 | if ($Is_MSWin32) { | |
601 | is `set foo 2>NUL`, ""; | |
602 | } else { | |
603 | is `echo \$foo`, "\n"; | |
604 | } | |
605 | } | |
606 | ||
607 | $ENV{__NoNeSuCh} = "foo"; | |
608 | $0 = "bar"; | |
609 | # cmd.exe will echo 'variable=value' but 4nt will echo just the value | |
610 | # -- Nikola Knezevic | |
611 | if ($Is_MSWin32) { | |
612 | like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/; | |
613 | } else { | |
614 | is `echo \$__NoNeSuCh`, "foo\n"; | |
615 | } | |
616 | SKIP: { | |
617 | skip("\$0 check only on Linux and FreeBSD", 2) | |
618 | unless $^O =~ /^(linux|freebsd)$/ | |
619 | && open CMDLINE, "/proc/$$/cmdline"; | |
620 | ||
621 | chomp(my $line = scalar <CMDLINE>); | |
622 | my $me = (split /\0/, $line)[0]; | |
623 | is $me, $0, 'altering $0 is effective (testing with /proc/)'; | |
624 | close CMDLINE; | |
625 | # perlbug #22811 | |
626 | my $mydollarzero = sub { | |
627 | my($arg) = shift; | |
628 | $0 = $arg if defined $arg; | |
629 | # In FreeBSD the ps -o command= will cause | |
630 | # an empty header line, grab only the last line. | |
631 | my $ps = (`ps -o command= -p $$`)[-1]; | |
632 | return if $?; | |
633 | chomp $ps; | |
634 | printf "# 0[%s]ps[%s]\n", $0, $ps; | |
635 | $ps; | |
636 | }; | |
637 | my $ps = $mydollarzero->("x"); | |
638 | ok(!$ps # we allow that something goes wrong with the ps command | |
639 | # In Linux 2.4 we would get an exact match ($ps eq 'x') but | |
640 | # in Linux 2.2 there seems to be something funny going on: | |
641 | # it seems as if the original length of the argv[] would | |
642 | # be stored in the proc struct and then used by ps(1), | |
643 | # no matter what characters we use to pad the argv[]. | |
644 | # (And if we use \0:s, they are shown as spaces.) Sigh. | |
645 | || $ps =~ /^x\s*$/ | |
646 | # FreeBSD cannot get rid of both the leading "perl :" | |
647 | # and the trailing " (perl)": some FreeBSD versions | |
648 | # can get rid of the first one. | |
649 | || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/), | |
650 | 'altering $0 is effective (testing with `ps`)'); | |
651 | } | |
652 | } | |
653 | ||
654 | # test case-insignificance of %ENV (these tests must be enabled only | |
655 | # when perl is compiled with -DENV_IS_CASELESS) | |
656 | SKIP: { | |
657 | skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare; | |
658 | ||
659 | %ENV = (); | |
660 | $ENV{'Foo'} = 'bar'; | |
661 | $ENV{'fOo'} = 'baz'; | |
662 | is scalar(keys(%ENV)), 1; | |
663 | ok exists $ENV{'FOo'}; | |
664 | is delete $ENV{'foO'}, 'baz'; | |
665 | is scalar(keys(%ENV)), 0; | |
666 | } | |
667 | ||
668 | __END__ | |
669 | ||
670 | # Put new tests before the various ENV tests, as they blow %ENV away. |