#
# Tests derived from Japhs.
#
+# These test use obscure features of Perl, or surprising combinations
+# of features. The tests were added because in the past, they have
+# exposed several bugs in Perl.
+#
+# Some of these tests may actually (mis)use bugs or use undefined behaviour.
+# These tests are still useful - behavioural changes or bugfixes will be
+# noted, and a remark can be put in the documentation. (Don't forget to
+# disable the test!)
+#
+# Getting everything to run well on the myriad of platforms Perl runs on
+# is unfortunately not a trivial task.
+#
+# WARNING: these tests are obfuscated. Do not get frustrated.
+# Ask Abigail <abigail@abigail.be>, or use the Deparse or Concise
+# modules (the former parses Perl to Perl, the latter shows the
+# op syntax tree) like this:
+# ./perl -Ilib -MO=Deparse foo.pl
+# ./perl -Ilib -MO=Concise foo.pl
+#
BEGIN {
- if (ord("A") == 193) {
- print "1..0 # Skip: EBCDIC\n"; # For now, until someone has time.
- exit(0);
- }
chdir 't' if -d 't';
@INC = '../lib';
require "./test.pl";
+ skip_all('EBCDIC') if $::IS_EBCDIC;
undef &skip;
}
#
sub skip {
my $why = shift;
- my $test = curr_test;
my $n = @_ ? shift : 1;
for (1..$n) {
+ my $test = curr_test;
print STDOUT "ok $test # skip: $why\n";
next_test;
}
if ($^O eq 'MSWin32' ||
$^O eq 'NetWare' ||
$^O eq 'VMS') {
- skip 3, "Your platform quotes differently.\n";
+ skip "Your platform quotes differently.", 3;
last;
}
if ($^O eq 'MSWin32' ||
$^O eq 'NetWare' ||
$^O eq 'VMS') {
- skip 1, "Your platform quotes differently.\n";
+ skip "Your platform quotes differently.", 1;
last;
}
is (runperl (switches => [qw /-sweprint --/,
{
my $datafile = "datatmp000";
1 while -f ++ $datafile;
- END {unlink_all $datafile}
+ END {unlink_all $datafile if $datafile}
open MY_DATA, "> $datafile" or die "Failed to open $datafile: $!";
print MY_DATA << " --";
foreach my $program (@progs) {
if (exists $program -> {SKIP}) {
chomp $program -> {SKIP};
- skip $program -> {SKIP};
+ skip $program -> {SKIP}, 1;
next;
}
- if (@{$program -> {SKIP_OS}} &&
- grep {$^O eq $_} @{$program -> {SKIP_OS}}) {
- skip "Your OS uses different quoting.";
- next;
+ chomp @{$program -> {SKIP_OS}};
+ if (@{$program -> {SKIP_OS}}) {
+ if (grep {$^O eq $_} @{$program -> {SKIP_OS}}) {
+ skip "Your OS uses different quoting.", 1;
+ next;
+ }
}
map {s/\$datafile/$datafile/} @{$program -> {ARGS}};
{
my $progfile = "progtmp000";
1 while -f ++ $progfile;
- END {unlink_all $progfile}
+ END {unlink_all $progfile if $progfile}
my @programs = (<< ' --', << ' --');
-#!./perl -- # No trailing newline after the last line!
+#!./perl
BEGIN{$|=$SIG{__WARN__}=sub{$_=$_[0];y-_- -;print/(.)"$/;seek _,-open(_
,"+<$0"),2;truncate _,tell _;close _;exec$0}}//rekcaH_lreP_rehtona_tsuJ
--
-#!./perl -- # Remove trailing newline!
+#!./perl
BEGIN{$SIG{__WARN__}=sub{$_=pop;y-_- -;print/".*(.)"/;
truncate$0,-1+-s$0;exec$0;}}//rekcaH_lreP_rehtona_tsuJ
--
chomp @programs;
+ if ($^O eq 'VMS' or $^O eq 'MSWin32') {
+ # VMS needs extensions for files to be executable,
+ # but the Japhs above rely on $0 being exactly the
+ # filename of the program.
+ skip $^O, 2 * @programs;
+ last
+ }
+
+ use Config;
+ unless (defined $Config {useperlio}) {
+ skip "Uuseperlio", 2 * @programs;
+ last
+ }
+
my $i = 1;
foreach my $program (@programs) {
open my $fh => "> $progfile" or die "Failed to open $progfile: $!\n";
close $fh or die "Failed to close $progfile: $!\n";
chmod 0755 => $progfile or die "Failed to chmod $progfile: $!\n";
- my $command = "./$progfile";
- $command .= ' 2>&1' unless $^O eq 'MacOS';
- my $output = `$command`;
+ my $command = "./$progfile 2>&1";
+ if ( $^O eq 'qnx' ) {
+ skip "#!./perl not supported in QNX4";
+ skip "#!./perl not supported in QNX4";
+ } else {
+ my $output = `$command`;
- $i ++;
- is ($output, $JaPH, "Self correcting code $i");
+ is ($output, $JaPH, "Self correcting code $i");
- $output = `$command`;
- is ($output, "", "Self corrected code $i");
+ $output = `$command`;
+ is ($output, "", "Self corrected code $i");
+ }
+ $i ++;
}
}
for ($*=******;$**=******;$**=******) {$**=*******s*..*qq}
print chr 0x$& and q
qq}*excess********}
+SKIP: $* was removed.
####### Funky loop 3.
$_ = q *4a75737420616e6f74686572205065726c204861636b65720a*;
for ($*=******;$**=******;$**=******) {$**=*******s*..*qq}
print chr 0x$& and q
qq}*excess********}
+SKIP: $* was removed.
####### Funky loop 4.
$_ = q ?4a75737420616e6f74686572205065726c204861636b65720as?;??;
SWITCHES
-Mstrict='}); print "Just another Perl Hacker"; ({'
-l
-SKIP_OS: VMS
-MSWin32
-NetWare
+SKIP: No longer works in 5.8.2 and beyond.
+SKIP_OS: MSWin32
+SKIP_OS: NetWare
####### rand
srand 123456;$-=rand$_--=>@[[$-,$_]=@[[$_,$-]for(reverse+1..(@[=split
####### Prototype fun 2
print prototype sub "Just another Perl Hacker" {};
+SKIP: Abuses a fixed bug.
####### Prototype fun 3
sub _ "Just another Perl Hacker"; print prototype \&_
+SKIP: Abuses a fixed bug.
####### Split 1
split // => '"';
${"@_"} = "/"; split // => eval join "+" => 1 .. 7;
*{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
%{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}};
+SKIP: Hashes are now randomized.
EXPECT: $JaPH_s
####### Split 2
$" = "/"; split // => eval join "+" => 1 .. 7;
*{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
%_ = (Just => another => Perl => Hacker); &{%_};
+SKIP: Hashes are now randomized.
EXPECT: $JaPH_s
####### Split 3
$" = "/"; split $, => eval join "+" => 1 .. 7;
*{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
%{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}};
+SKIP: Hashes are now randomized.
EXPECT: $JaPH_s
####### Here documents 1
####### Overloaded constants 1
BEGIN {$^H {q} = sub {pop and pop and print pop}; $^H = 2**4.2**12}
"Just "; "another "; "Perl "; "Hacker";
+SKIP_OS: qnx
####### Overloaded constants 2
BEGIN {$^H {q} = sub {$_ [1] =~ y/S-ZA-IK-O/q-tc-fe-m/d; $_ [1]}; $^H = 0x28100}
$_ = "\112\165\163\1648\141\156\157\164\150\145\1628\120\145"
. "\162\1548\110\141\143\153\145\162\0128\177" and &japh;
sub japh {print "@_" and return if pop; split /\d/ and &japh}
+SKIP: As of 5.12.0, split() in void context no longer populates @_.
####### magic goto.
sub _ {$_ = shift and y/b-yB-Y/a-yB-Y/ xor !@ _?
exit print :
print and push @_ => shift and goto &{(caller (0)) [3]}}
split // => "KsvQtbuf fbsodpmu\ni flsI " xor & _
+SKIP: As of 5.12.0, split() in void context no longer populates @_.
####### $: fun 1
:$:=~s:$":Just$&another$&:;$:=~s:
####### die 5
eval {die [[qq [Just another Perl Hacker]]]};; print
${${${@}}[$#{@{${@}}}]}[$#{${@{${@}}}[$#{@{${@}}}]}]
+SKIP: Abuses a fixed bug; what is in $#{...} must be an arrayref, not an array
####### Closure returning itself.
$_ = "\nrekcaH lreP rehtona tsuJ"; my $chop; $chop = sub {print chop; $chop};
https://perl5.git.perl.org / perl5.git / blobdiff