| 1 | #!./perl -w
|
|---|
| 2 |
|
|---|
| 3 | #
|
|---|
| 4 | # Tests derived from Japhs.
|
|---|
| 5 | #
|
|---|
| 6 | # These test use obscure features of Perl, or surprising combinations
|
|---|
| 7 | # of features. The tests were added because in the past, they have
|
|---|
| 8 | # exposed several bugs in Perl.
|
|---|
| 9 | #
|
|---|
| 10 | # Some of these tests may actually (mis)use bugs or use undefined behaviour.
|
|---|
| 11 | # These tests are still useful - behavioural changes or bugfixes will be
|
|---|
| 12 | # noted, and a remark can be put in the documentation. (Don't forget to
|
|---|
| 13 | # disable the test!)
|
|---|
| 14 | #
|
|---|
| 15 | # Getting everything to run well on the myriad of platforms Perl runs on
|
|---|
| 16 | # is unfortunately not a trivial task.
|
|---|
| 17 | #
|
|---|
| 18 | # WARNING: these tests are obfuscated. Do not get frustrated.
|
|---|
| 19 | # Ask Abigail <abigail@foad.org>, or use the Deparse or Concise
|
|---|
| 20 | # modules (the former parses Perl to Perl, the latter shows the
|
|---|
| 21 | # op syntax tree) like this:
|
|---|
| 22 | # ./perl -Ilib -MO=Deparse foo.pl
|
|---|
| 23 | # ./perl -Ilib -MO=Concise foo.pl
|
|---|
| 24 | #
|
|---|
| 25 |
|
|---|
| 26 | BEGIN {
|
|---|
| 27 | if (ord("A") == 193) {
|
|---|
| 28 | print "1..0 # Skip: EBCDIC\n"; # For now, until someone has time.
|
|---|
| 29 | exit(0);
|
|---|
| 30 | }
|
|---|
| 31 | chdir 't' if -d 't';
|
|---|
| 32 | @INC = '../lib';
|
|---|
| 33 | require "./test.pl";
|
|---|
| 34 | undef &skip;
|
|---|
| 35 | }
|
|---|
| 36 |
|
|---|
| 37 | skip_all "Unhappy on MacOS" if $^O eq 'MacOS';
|
|---|
| 38 |
|
|---|
| 39 | #
|
|---|
| 40 | # ./test.pl does real evilness by jumping to a label.
|
|---|
| 41 | # This function copies the skip from ./test, omitting the goto.
|
|---|
| 42 | #
|
|---|
| 43 | sub skip {
|
|---|
| 44 | my $why = shift;
|
|---|
| 45 | my $n = @_ ? shift : 1;
|
|---|
| 46 | for (1..$n) {
|
|---|
| 47 | my $test = curr_test;
|
|---|
| 48 | print STDOUT "ok $test # skip: $why\n";
|
|---|
| 49 | next_test;
|
|---|
| 50 | }
|
|---|
| 51 | }
|
|---|
| 52 |
|
|---|
| 53 |
|
|---|
| 54 | #
|
|---|
| 55 | # ./test.pl doesn't give use 'notok', so we make it here.
|
|---|
| 56 | #
|
|---|
| 57 | sub notok {
|
|---|
| 58 | my ($pass, $name, @mess) = @_;
|
|---|
| 59 | _ok(!$pass, _where(), $name, @mess);
|
|---|
| 60 | }
|
|---|
| 61 |
|
|---|
| 62 | my $JaPH = "Just another Perl Hacker";
|
|---|
| 63 | my $JaPh = "Just another Perl hacker";
|
|---|
| 64 | my $JaPH_n = "Just another Perl Hacker\n";
|
|---|
| 65 | my $JaPh_n = "Just another Perl hacker\n";
|
|---|
| 66 | my $JaPH_s = "Just another Perl Hacker ";
|
|---|
| 67 | my $JaPh_s = "Just another Perl hacker ";
|
|---|
| 68 | my $JaPH_c = "Just another Perl Hacker,";
|
|---|
| 69 | my $JaPh_c = "Just another Perl hacker,";
|
|---|
| 70 |
|
|---|
| 71 | plan tests => 130;
|
|---|
| 72 |
|
|---|
| 73 | {
|
|---|
| 74 | my $out = sprintf "Just another Perl Hacker";
|
|---|
| 75 | is ($out, $JaPH);
|
|---|
| 76 | }
|
|---|
| 77 |
|
|---|
| 78 |
|
|---|
| 79 | {
|
|---|
| 80 | my @primes = (2, 3, 7, 13, 53, 101, 557, 1429);
|
|---|
| 81 | my @composites = (4, 10, 25, 32, 75, 143, 1333, 1728);
|
|---|
| 82 |
|
|---|
| 83 | my %primeness = ((map {$_ => 1} @primes),
|
|---|
| 84 | (map {$_ => 0} @composites));
|
|---|
| 85 |
|
|---|
| 86 | while (my ($num, $is_prime) = each %primeness) {
|
|---|
| 87 | my $comment = "$num is " . ($is_prime ? "prime." : "composite.");
|
|---|
| 88 |
|
|---|
| 89 | my $sub = $is_prime ? "ok" : "notok";
|
|---|
| 90 |
|
|---|
| 91 | &$sub (( 1 x $num) !~ /^1?$|^(11+?)\1+$/, $comment);
|
|---|
| 92 | &$sub (( 0 x $num) !~ m 0^\0?$|^(\0\0+?)\1+$0, $comment);
|
|---|
| 93 | &$sub (("m" x $num) !~ m m^\m?$|^(\m\m+?)\1+$mm, $comment);
|
|---|
| 94 | }
|
|---|
| 95 | }
|
|---|
| 96 |
|
|---|
| 97 |
|
|---|
| 98 | { # Some platforms use different quoting techniques.
|
|---|
| 99 | # I do not have access to those platforms to test
|
|---|
| 100 | # things out. So, we'll skip things....
|
|---|
| 101 | if ($^O eq 'MSWin32' ||
|
|---|
| 102 | $^O eq 'NetWare' ||
|
|---|
| 103 | $^O eq 'VMS') {
|
|---|
| 104 | skip "Your platform quotes differently.", 3;
|
|---|
| 105 | last;
|
|---|
| 106 | }
|
|---|
| 107 |
|
|---|
| 108 | my $expected = $JaPH;
|
|---|
| 109 | $expected =~ s/ /\n/g;
|
|---|
| 110 | $expected .= "\n";
|
|---|
| 111 | is (runperl (switches => [qw /'-weprint<<EOT;' -eJust -eanother
|
|---|
| 112 | -ePerl -eHacker -eEOT/],
|
|---|
| 113 | verbose => 0),
|
|---|
| 114 | $expected, "Multiple -e switches");
|
|---|
| 115 |
|
|---|
| 116 | is (runperl (switches => [q !'-wle$_=<<EOT;y/\n/ /;print;'!,
|
|---|
| 117 | qw ! -eJust -eanother -ePerl -eHacker -eEOT!],
|
|---|
| 118 | verbose => 0),
|
|---|
| 119 | $JaPH . " \n", "Multiple -e switches");
|
|---|
| 120 |
|
|---|
| 121 | is (runperl (switches => [qw !-wl!],
|
|---|
| 122 | progs => [qw !print qq-@{[ qw+ Just
|
|---|
| 123 | another Perl Hacker +]}-!],
|
|---|
| 124 | verbose => 0),
|
|---|
| 125 | $JaPH_n, "Multiple -e switches");
|
|---|
| 126 | }
|
|---|
| 127 |
|
|---|
| 128 | {
|
|---|
| 129 | if ($^O eq 'MSWin32' ||
|
|---|
| 130 | $^O eq 'NetWare' ||
|
|---|
| 131 | $^O eq 'VMS') {
|
|---|
| 132 | skip "Your platform quotes differently.", 1;
|
|---|
| 133 | last;
|
|---|
| 134 | }
|
|---|
| 135 | is (runperl (switches => [qw /-sweprint --/,
|
|---|
| 136 | "-_='Just another Perl Hacker'"],
|
|---|
| 137 | nolib => 1,
|
|---|
| 138 | verbose => 0),
|
|---|
| 139 | $JaPH, 'setting $_ via -s');
|
|---|
| 140 | }
|
|---|
| 141 |
|
|---|
| 142 | {
|
|---|
| 143 | my $datafile = "datatmp000";
|
|---|
| 144 | 1 while -f ++ $datafile;
|
|---|
| 145 | END {unlink_all $datafile if $datafile}
|
|---|
| 146 |
|
|---|
| 147 | open MY_DATA, "> $datafile" or die "Failed to open $datafile: $!";
|
|---|
| 148 | print MY_DATA << " --";
|
|---|
| 149 | One
|
|---|
| 150 | Two
|
|---|
| 151 | Three
|
|---|
| 152 | Four
|
|---|
| 153 | Five
|
|---|
| 154 | Six
|
|---|
| 155 | --
|
|---|
| 156 | close MY_DATA or die "Failed to close $datafile: $!\n";
|
|---|
| 157 |
|
|---|
| 158 | my @progs;
|
|---|
| 159 | my $key;
|
|---|
| 160 | while (<DATA>) {
|
|---|
| 161 | last if /^__END__$/;
|
|---|
| 162 |
|
|---|
| 163 | if (/^#{7}(?:\s+(.*))?/) {
|
|---|
| 164 | push @progs => {COMMENT => $1 || '',
|
|---|
| 165 | CODE => '',
|
|---|
| 166 | SKIP_OS => [],
|
|---|
| 167 | ARGS => [],
|
|---|
| 168 | SWITCHES => [],};
|
|---|
| 169 | $key = 'CODE';
|
|---|
| 170 | next;
|
|---|
| 171 | }
|
|---|
| 172 | elsif (/^(COMMENT|CODE|ARGS|SWITCHES|EXPECT|SKIP|SKIP_OS)
|
|---|
| 173 | (?::\s+(.*))?$/sx) {
|
|---|
| 174 | $key = $1;
|
|---|
| 175 | $progs [-1] {$key} = '' unless exists $progs [-1] {$key};
|
|---|
| 176 | next unless defined $2;
|
|---|
| 177 | $_ = $2;
|
|---|
| 178 | }
|
|---|
| 179 | elsif (/^$/) {
|
|---|
| 180 | next;
|
|---|
| 181 | }
|
|---|
| 182 |
|
|---|
| 183 | if (ref ($progs [-1] {$key})) {
|
|---|
| 184 | push @{$progs [-1] {$key}} => $_;
|
|---|
| 185 | }
|
|---|
| 186 | else {
|
|---|
| 187 | $progs [-1] {$key} .= $_;
|
|---|
| 188 | }
|
|---|
| 189 | }
|
|---|
| 190 |
|
|---|
| 191 | foreach my $program (@progs) {
|
|---|
| 192 | if (exists $program -> {SKIP}) {
|
|---|
| 193 | chomp $program -> {SKIP};
|
|---|
| 194 | skip $program -> {SKIP}, 1;
|
|---|
| 195 | next;
|
|---|
| 196 | }
|
|---|
| 197 |
|
|---|
| 198 | chomp @{$program -> {SKIP_OS}};
|
|---|
| 199 | if (@{$program -> {SKIP_OS}}) {
|
|---|
| 200 | if (grep {$^O eq $_} @{$program -> {SKIP_OS}}) {
|
|---|
| 201 | skip "Your OS uses different quoting.", 1;
|
|---|
| 202 | next;
|
|---|
| 203 | }
|
|---|
| 204 | }
|
|---|
| 205 |
|
|---|
| 206 | map {s/\$datafile/$datafile/} @{$program -> {ARGS}};
|
|---|
| 207 | $program -> {EXPECT} = $JaPH unless exists $program -> {EXPECT};
|
|---|
| 208 | $program -> {EXPECT} =~ s/\$JaPH_s\b/$JaPH_s/g;
|
|---|
| 209 | $program -> {EXPECT} =~ s/\$JaPh_c\b/$JaPh_c/g;
|
|---|
| 210 | $program -> {EXPECT} =~ s/\$JaPh\b/$JaPh/g;
|
|---|
| 211 | chomp ($program -> {EXPECT}, @{$program -> {SWITCHES}},
|
|---|
| 212 | @{$program -> {ARGS}});
|
|---|
| 213 | fresh_perl_is ($program -> {CODE},
|
|---|
| 214 | $program -> {EXPECT},
|
|---|
| 215 | {switches => $program -> {SWITCHES},
|
|---|
| 216 | args => $program -> {ARGS},
|
|---|
| 217 | verbose => 0},
|
|---|
| 218 | $program -> {COMMENT});
|
|---|
| 219 | }
|
|---|
| 220 | }
|
|---|
| 221 |
|
|---|
| 222 | {
|
|---|
| 223 | my $progfile = "progtmp000";
|
|---|
| 224 | 1 while -f ++ $progfile;
|
|---|
| 225 | END {unlink_all $progfile if $progfile}
|
|---|
| 226 |
|
|---|
| 227 | my @programs = (<< ' --', << ' --');
|
|---|
| 228 | #!./perl
|
|---|
| 229 | BEGIN{$|=$SIG{__WARN__}=sub{$_=$_[0];y-_- -;print/(.)"$/;seek _,-open(_
|
|---|
| 230 | ,"+<$0"),2;truncate _,tell _;close _;exec$0}}//rekcaH_lreP_rehtona_tsuJ
|
|---|
| 231 | --
|
|---|
| 232 | #!./perl
|
|---|
| 233 | BEGIN{$SIG{__WARN__}=sub{$_=pop;y-_- -;print/".*(.)"/;
|
|---|
| 234 | truncate$0,-1+-s$0;exec$0;}}//rekcaH_lreP_rehtona_tsuJ
|
|---|
| 235 | --
|
|---|
| 236 | chomp @programs;
|
|---|
| 237 |
|
|---|
| 238 | if ($^O eq 'VMS' or $^O eq 'MSWin32') {
|
|---|
| 239 | # VMS needs extensions for files to be executable,
|
|---|
| 240 | # but the Japhs above rely on $0 being exactly the
|
|---|
| 241 | # filename of the program.
|
|---|
| 242 | skip $^O, 2 * @programs;
|
|---|
| 243 | last
|
|---|
| 244 | }
|
|---|
| 245 |
|
|---|
| 246 | use Config;
|
|---|
| 247 | unless (defined $Config {useperlio}) {
|
|---|
| 248 | skip "Uuseperlio", 2 * @programs;
|
|---|
| 249 | last
|
|---|
| 250 | }
|
|---|
| 251 |
|
|---|
| 252 | my $i = 1;
|
|---|
| 253 | foreach my $program (@programs) {
|
|---|
| 254 | open my $fh => "> $progfile" or die "Failed to open $progfile: $!\n";
|
|---|
| 255 | print $fh $program;
|
|---|
| 256 | close $fh or die "Failed to close $progfile: $!\n";
|
|---|
| 257 |
|
|---|
| 258 | chmod 0755 => $progfile or die "Failed to chmod $progfile: $!\n";
|
|---|
| 259 | my $command = "./$progfile";
|
|---|
| 260 | $command .= ' 2>&1' unless $^O eq 'MacOS';
|
|---|
| 261 | if ( $^O eq 'qnx' ) {
|
|---|
| 262 | skip "#!./perl not supported in QNX4";
|
|---|
| 263 | skip "#!./perl not supported in QNX4";
|
|---|
| 264 | } else {
|
|---|
| 265 | my $output = `$command`;
|
|---|
| 266 |
|
|---|
| 267 | is ($output, $JaPH, "Self correcting code $i");
|
|---|
| 268 |
|
|---|
| 269 | $output = `$command`;
|
|---|
| 270 | is ($output, "", "Self corrected code $i");
|
|---|
| 271 | }
|
|---|
| 272 | $i ++;
|
|---|
| 273 | }
|
|---|
| 274 | }
|
|---|
| 275 |
|
|---|
| 276 | __END__
|
|---|
| 277 | ####### Funky loop 1.
|
|---|
| 278 | $_ = q ;4a75737420616e6f74686572205065726c204861636b65720as;;
|
|---|
| 279 | for (s;s;s;s;s;s;s;s;s;s;s;s)
|
|---|
| 280 | {s;(..)s?;qq qprint chr 0x$1 and \161 ssq;excess;}
|
|---|
| 281 |
|
|---|
| 282 | ####### Funky loop 2.
|
|---|
| 283 | $_ = q *4a75737420616e6f74686572205065726c204861636b65720a*;
|
|---|
| 284 | for ($*=******;$**=******;$**=******) {$**=*******s*..*qq}
|
|---|
| 285 | print chr 0x$& and q
|
|---|
| 286 | qq}*excess********}
|
|---|
| 287 | SKIP_OS: qnx
|
|---|
| 288 |
|
|---|
| 289 | ####### Funky loop 3.
|
|---|
| 290 | $_ = q *4a75737420616e6f74686572205065726c204861636b65720a*;
|
|---|
| 291 | for ($*=******;$**=******;$**=******) {$**=*******s*..*qq}
|
|---|
| 292 | print chr 0x$& and q
|
|---|
| 293 | qq}*excess********}
|
|---|
| 294 | SKIP_OS: qnx
|
|---|
| 295 |
|
|---|
| 296 | ####### Funky loop 4.
|
|---|
| 297 | $_ = q ?4a75737420616e6f74686572205065726c204861636b65720as?;??;
|
|---|
| 298 | for (??;(??)x??;??)
|
|---|
| 299 | {??;s;(..)s?;qq ?print chr 0x$1 and \161 ss?;excess;??}
|
|---|
| 300 | SKIP: Abuses a fixed bug.
|
|---|
| 301 |
|
|---|
| 302 | ####### Funky loop 5.
|
|---|
| 303 | for (s??4a75737420616e6f74686572205065726c204861636b65720as?;??;??)
|
|---|
| 304 | {s?(..)s\??qq \?print chr 0x$1 and q ss\??excess}
|
|---|
| 305 | SKIP: Abuses a fixed bug.
|
|---|
| 306 |
|
|---|
| 307 | ####### Funky loop 6.
|
|---|
| 308 | $a = q 94a75737420616e6f74686572205065726c204861636b65720a9 and
|
|---|
| 309 | ${qq$\x5F$} = q 97265646f9 and s g..g;
|
|---|
| 310 | qq e\x63\x68\x72\x20\x30\x78$&eggee;
|
|---|
| 311 | {eval if $a =~ s e..eqq qprint chr 0x$& and \x71\x20\x71\x71qeexcess}
|
|---|
| 312 |
|
|---|
| 313 | ####### Roman Dates.
|
|---|
| 314 | @r=reverse(M=>(0)x99=>CM=>(0)x399=>D=>(0)x99=>CD=>(
|
|---|
| 315 | 0)x299=>C=>(0)x9=>XC=>(0)x39=>L=>(0)x9=>XL=>(0)x29=>X=>IX=>0=>0=>0=>V=>IV=>0=>0
|
|---|
| 316 | =>I=>$==-2449231+gm_julian_day+time);do{until($=<$#r){$_.=$r[$#r];$=-=$#r}for(;
|
|---|
| 317 | !$r[--$#r];){}}while$=;$,="\x20";print+$_=>September=>MCMXCIII=>=>=>=>=>=>=>=>
|
|---|
| 318 | SWITCHES
|
|---|
| 319 | -MTimes::JulianDay
|
|---|
| 320 | -l
|
|---|
| 321 | SKIP: Times::JulianDay not part of the main distribution.
|
|---|
| 322 |
|
|---|
| 323 | ####### Autoload 1.
|
|---|
| 324 | sub _'_{$_'_=~s/$a/$_/}map{$$_=$Z++}Y,a..z,A..X;*{($_::_=sprintf+q=%X==>"$A$Y".
|
|---|
| 325 | "$b$r$T$u")=~s~0~O~g;map+_::_,U=>T=>L=>$Z;$_::_}=*_;sub _{print+/.*::(.*)/s};;;
|
|---|
| 326 | *{chr($b*$e)}=*_'_;*__=*{chr(1<<$e)}; # Perl 5.6.0 broke this...
|
|---|
| 327 | _::_(r(e(k(c(a(H(__(l(r(e(P(__(r(e(h(t(o(n(a(__(t(us(J())))))))))))))))))))))))
|
|---|
| 328 | EXPECT: Just__another__Perl__Hacker
|
|---|
| 329 |
|
|---|
| 330 | ####### Autoload 2.
|
|---|
| 331 | $"=$,;*{;qq{@{[(A..Z)[qq[0020191411140003]=~m[..]g]]}}}=*_=sub{print/::(.*)/};
|
|---|
| 332 | $\=$/;q<Just another Perl Hacker>->();
|
|---|
| 333 |
|
|---|
| 334 | ####### Autoload 3.
|
|---|
| 335 | $"=$,;*{;qq{@{[(A..Z)[qq[0020191411140003]=~m[..]g]]}}}=*_;
|
|---|
| 336 | sub _ {push @_ => /::(.*)/s and goto &{ shift}}
|
|---|
| 337 | sub shift {print shift; @_ and goto &{+shift}}
|
|---|
| 338 | Hack ("Just", "Perl ", " ano", "er\n", "ther "); # YYYYMMDD
|
|---|
| 339 |
|
|---|
| 340 | ####### Autoload 4.
|
|---|
| 341 | $, = " "; sub AUTOLOAD {($AUTOLOAD =~ /::(.*)/) [0];}
|
|---|
| 342 | print+Just (), another (), Perl (), Hacker ();
|
|---|
| 343 |
|
|---|
| 344 | ####### Look ma! No letters!
|
|---|
| 345 | $@="\145\143\150\157\040\042\112\165\163\164\040\141\156\157\164".
|
|---|
| 346 | "\150\145\162\040\120\145\162\154\040\110\141\143\153\145\162".
|
|---|
| 347 | "\042\040\076\040\057\144\145\166\057\164\164\171";`$@`
|
|---|
| 348 | SKIP: Unix specific
|
|---|
| 349 |
|
|---|
| 350 | ####### sprintf fun 1.
|
|---|
| 351 | sub f{sprintf$_[0],$_[1],$_[2]}print f('%c%s',74,f('%c%s',117,f('%c%s',115,f(
|
|---|
| 352 | '%c%s',116,f('%c%s',32,f('%c%s',97,f('%c%s',0x6e,f('%c%s',111,f('%c%s',116,f(
|
|---|
| 353 | '%c%s',104,f('%c%s',0x65,f('%c%s',114,f('%c%s',32,f('%c%s',80,f('%c%s',101,f(
|
|---|
| 354 | '%c%s',114,f('%c%s',0x6c,f('%c%s',32,f('%c%s',0x48,f('%c%s',97,f('%c%s',99,f(
|
|---|
| 355 | '%c%s',107,f('%c%s',101,f('%c%s',114,f('%c%s',10,)))))))))))))))))))))))))
|
|---|
| 356 |
|
|---|
| 357 | ####### sprintf fun 2.
|
|---|
| 358 | sub f{sprintf'%c%s',$_[0],$_[1]}print f(74,f(117,f(115,f(116,f(32,f(97,
|
|---|
| 359 | f(110,f(111,f(116,f(104,f(0x65,f(114,f(32,f(80,f(101,f(114,f(0x6c,f(32,
|
|---|
| 360 | f(0x48,f(97,f(99,f(107,f(101,f(114,f(10,q ff)))))))))))))))))))))))))
|
|---|
| 361 |
|
|---|
| 362 | ####### Hanoi.
|
|---|
| 363 | %0=map{local$_=$_;reverse+chop,$_}ABC,ACB,BAC,BCA,CAB,CBA;$_=3 .AC;1while+
|
|---|
| 364 | s/(\d+)((.)(.))/($0=$1-1)?"$0$3$0{$2}1$2$0$0{$2}$4":"$3 => $4\n"/xeg;print
|
|---|
| 365 | EXPECT
|
|---|
| 366 | A => C
|
|---|
| 367 | A => B
|
|---|
| 368 | C => B
|
|---|
| 369 | A => C
|
|---|
| 370 | B => A
|
|---|
| 371 | B => C
|
|---|
| 372 | A => C
|
|---|
| 373 |
|
|---|
| 374 | ####### Funky -p 1
|
|---|
| 375 | }{$_=$.
|
|---|
| 376 | SWITCHES: -wlp
|
|---|
| 377 | ARGS: $datafile
|
|---|
| 378 | EXPECT: 6
|
|---|
| 379 |
|
|---|
| 380 | ####### Funky -p 2
|
|---|
| 381 | }$_=$.;{
|
|---|
| 382 | SWITCHES: -wlp
|
|---|
| 383 | ARGS: $datafile
|
|---|
| 384 | EXPECT: 6
|
|---|
| 385 |
|
|---|
| 386 | ####### Funky -p 3
|
|---|
| 387 | }{$_=$.}{
|
|---|
| 388 | SWITCHES: -wlp
|
|---|
| 389 | ARGS: $datafile
|
|---|
| 390 | EXPECT: 6
|
|---|
| 391 |
|
|---|
| 392 | ####### Funky -p 4
|
|---|
| 393 | }{*_=*.}{
|
|---|
| 394 | SWITCHES: -wlp
|
|---|
| 395 | ARGS: $datafile
|
|---|
| 396 | EXPECT: 6
|
|---|
| 397 |
|
|---|
| 398 | ####### Funky -p 5
|
|---|
| 399 | }for($.){print
|
|---|
| 400 | SWITCHES: -wln
|
|---|
| 401 | ARGS: $datafile
|
|---|
| 402 | EXPECT: 6
|
|---|
| 403 |
|
|---|
| 404 | ####### Funky -p 6
|
|---|
| 405 | }{print$.
|
|---|
| 406 | SWITCHES: -wln
|
|---|
| 407 | ARGS: $datafile
|
|---|
| 408 | EXPECT: 6
|
|---|
| 409 |
|
|---|
| 410 | ####### Funky -p 7
|
|---|
| 411 | }print$.;{
|
|---|
| 412 | SWITCHES: -wln
|
|---|
| 413 | ARGS: $datafile
|
|---|
| 414 | EXPECT: 6
|
|---|
| 415 |
|
|---|
| 416 | ####### Abusing -M
|
|---|
| 417 | 1
|
|---|
| 418 | SWITCHES
|
|---|
| 419 | -Mstrict='}); print "Just another Perl Hacker"; ({'
|
|---|
| 420 | -l
|
|---|
| 421 | SKIP: No longer works in 5.8.2 and beyond.
|
|---|
| 422 | MSWin32
|
|---|
| 423 | NetWare
|
|---|
| 424 |
|
|---|
| 425 | ####### rand
|
|---|
| 426 | srand 123456;$-=rand$_--=>@[[$-,$_]=@[[$_,$-]for(reverse+1..(@[=split
|
|---|
| 427 | //=>"IGrACVGQ\x02GJCWVhP\x02PL\x02jNMP"));print+(map{$_^q^"^}@[),"\n"
|
|---|
| 428 | SKIP: Solaris specific.
|
|---|
| 429 |
|
|---|
| 430 | ####### print and __PACKAGE__
|
|---|
| 431 | package Just_another_Perl_Hacker; sub print {($_=$_[0])=~ s/_/ /g;
|
|---|
| 432 | print } sub __PACKAGE__ { &
|
|---|
| 433 | print ( __PACKAGE__)} &
|
|---|
| 434 | __PACKAGE__
|
|---|
| 435 | ( )
|
|---|
| 436 |
|
|---|
| 437 | ####### Decorations.
|
|---|
| 438 | * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|---|
| 439 | / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / /
|
|---|
| 440 | % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %;
|
|---|
| 441 | BEGIN {% % = ($ _ = " " => print "Just another Perl Hacker\n")}
|
|---|
| 442 |
|
|---|
| 443 | ####### Tie 1
|
|---|
| 444 | sub J::FETCH{Just }$_.='print+"@{[map';sub J::TIESCALAR{bless\my$J,J}
|
|---|
| 445 | sub A::FETCH{another}$_.='{tie my($x),$';sub A::TIESCALAR{bless\my$A,A}
|
|---|
| 446 | sub P::FETCH{Perl }$_.='_;$x}qw/J A P';sub P::TIESCALAR{bless\my$P,P}
|
|---|
| 447 | sub H::FETCH{Hacker }$_.=' H/]}\n"';eval;sub H::TIESCALAR{bless\my$H,H}
|
|---|
| 448 |
|
|---|
| 449 | ####### Tie 2
|
|---|
| 450 | package Z;use overload'""'=>sub{$b++?Hacker:another};
|
|---|
| 451 | sub TIESCALAR{bless\my$y=>Z}sub FETCH{$a++?Perl:Just}
|
|---|
| 452 | $,=$";my$x=tie+my$y=>Z;print$y,$x,$y,$x,"\n";#Abigail
|
|---|
| 453 | EXPECT: $JaPH_s
|
|---|
| 454 |
|
|---|
| 455 | ####### Tie 3
|
|---|
| 456 | sub A::TIESCALAR{bless\my$x=>A};package B;@q[0..3]=qw/Hacker Perl
|
|---|
| 457 | another Just/;use overload'""'=>sub{pop @q};sub A::FETCH{bless\my
|
|---|
| 458 | $y=>B}; tie my $shoe => qq 'A';print "$shoe $shoe $shoe $shoe\n";
|
|---|
| 459 |
|
|---|
| 460 | ####### Tie 4
|
|---|
| 461 | sub A::TIESCALAR{bless\my$x=>'A'};package B;@q=qw/Hacker Perl
|
|---|
| 462 | another Just/;use overload'""',sub{pop @q};sub A::FETCH{bless
|
|---|
| 463 | \my $y=>B};tie my$shoe=>'A';print"$shoe $shoe $shoe $shoe\n";
|
|---|
| 464 |
|
|---|
| 465 | ####### Tie 5
|
|---|
| 466 | tie $" => A; $, = " "; $\ = "\n"; @a = ("") x 2; print map {"@a"} 1 .. 4;
|
|---|
| 467 | sub A::TIESCALAR {bless \my $A => A} # Yet Another silly JAPH by Abigail
|
|---|
| 468 | sub A::FETCH {@q = qw /Just Another Perl Hacker/ unless @q; shift @q}
|
|---|
| 469 | SKIP: Pending a bug fix.
|
|---|
| 470 |
|
|---|
| 471 | ####### Prototype fun 1
|
|---|
| 472 | sub camel (^#87=i@J&&&#]u'^^s]#'#={123{#}7890t[0.9]9@+*`"'***}A&&&}n2o}00}t324i;
|
|---|
| 473 | h[{e **###{r{+P={**{e^^^#'#i@{r'^=^{l+{#}H***i[0.9]&@a5`"':&^;&^,*&^$43##@@####;
|
|---|
| 474 | c}^^^&&&k}&&&}#=e*****[]}'r####'`=437*{#};::'1[0.9]2@43`"'*#==[[.{{],,,1278@#@);
|
|---|
| 475 | print+((($llama=prototype'camel')=~y|+{#}$=^*&[0-9]i@:;`"',.| |d)&&$llama."\n");
|
|---|
| 476 | SKIP: Abuses a fixed bug.
|
|---|
| 477 |
|
|---|
| 478 | ####### Prototype fun 2
|
|---|
| 479 | print prototype sub "Just another Perl Hacker" {};
|
|---|
| 480 | SKIP: Abuses a fixed bug.
|
|---|
| 481 |
|
|---|
| 482 | ####### Prototype fun 3
|
|---|
| 483 | sub _ "Just another Perl Hacker"; print prototype \&_
|
|---|
| 484 | SKIP: Abuses a fixed bug.
|
|---|
| 485 |
|
|---|
| 486 | ####### Split 1
|
|---|
| 487 | split // => '"';
|
|---|
| 488 | ${"@_"} = "/"; split // => eval join "+" => 1 .. 7;
|
|---|
| 489 | *{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
|
|---|
| 490 | %{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}};
|
|---|
| 491 | SKIP: Hashes are now randomized.
|
|---|
| 492 | EXPECT: $JaPH_s
|
|---|
| 493 |
|
|---|
| 494 | ####### Split 2
|
|---|
| 495 | $" = "/"; split // => eval join "+" => 1 .. 7;
|
|---|
| 496 | *{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
|
|---|
| 497 | %_ = (Just => another => Perl => Hacker); &{%_};
|
|---|
| 498 | SKIP: Hashes are now randomized.
|
|---|
| 499 | EXPECT: $JaPH_s
|
|---|
| 500 |
|
|---|
| 501 | ####### Split 3
|
|---|
| 502 | $" = "/"; split $, => eval join "+" => 1 .. 7;
|
|---|
| 503 | *{"@_"} = sub {foreach (sort keys %_) {print "$_ $_{$_} "}};
|
|---|
| 504 | %{"@_"} = %_ = (Just => another => Perl => Hacker); &{%{%_}};
|
|---|
| 505 | SKIP: Hashes are now randomized.
|
|---|
| 506 | EXPECT: $JaPH_s
|
|---|
| 507 |
|
|---|
| 508 | ####### Here documents 1
|
|---|
| 509 | $_ = "\x3C\x3C\x45\x4F\x54"; s/<<EOT/<<EOT/e; print;
|
|---|
| 510 | Just another Perl Hacker
|
|---|
| 511 | EOT
|
|---|
| 512 |
|
|---|
| 513 | ####### Here documents 2
|
|---|
| 514 | $_ = "\x3C\x3C\x45\x4F\x54";
|
|---|
| 515 | print if s/<<EOT/<<EOT/e;
|
|---|
| 516 | Just another Perl Hacker
|
|---|
| 517 | EOT
|
|---|
| 518 |
|
|---|
| 519 | ####### Here documents 3
|
|---|
| 520 | $_ = "\x3C\x3C\x45\x4F\x54" and s/<<EOT/<<EOT/e and print;
|
|---|
| 521 | Just another Perl Hacker
|
|---|
| 522 | EOT
|
|---|
| 523 |
|
|---|
| 524 | ####### Here documents 4
|
|---|
| 525 | $_ = "\x3C\x3C\x45\x4F\x54\n" and s/<<EOT/<<EOT/ee and print;
|
|---|
| 526 | "Just another Perl Hacker"
|
|---|
| 527 | EOT
|
|---|
| 528 |
|
|---|
| 529 | ####### Self modifying code 1
|
|---|
| 530 | $_ = "goto F.print chop;\n=rekcaH lreP rehtona tsuJ";F1:eval
|
|---|
| 531 | SWITCHES: -w
|
|---|
| 532 |
|
|---|
| 533 | ####### Overloaded constants 1
|
|---|
| 534 | BEGIN {$^H {q} = sub {pop and pop and print pop}; $^H = 2**4.2**12}
|
|---|
| 535 | "Just "; "another "; "Perl "; "Hacker";
|
|---|
| 536 | SKIP_OS: qnx
|
|---|
| 537 |
|
|---|
| 538 | ####### Overloaded constants 2
|
|---|
| 539 | BEGIN {$^H {q} = sub {$_ [1] =~ y/S-ZA-IK-O/q-tc-fe-m/d; $_ [1]}; $^H = 0x28100}
|
|---|
| 540 | print "Just another PYTHON hacker\n";
|
|---|
| 541 | EXPECT: $JaPh
|
|---|
| 542 |
|
|---|
| 543 | ####### Overloaded constants 3
|
|---|
| 544 | BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub
|
|---|
| 545 | {["", "Just ", "another ", "Perl ", "Hacker\n"] -> [shift]};
|
|---|
| 546 | $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4}
|
|---|
| 547 | print 1, 2, 3, 4;
|
|---|
| 548 |
|
|---|
| 549 | ####### Overloaded constants 4
|
|---|
| 550 | BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub
|
|---|
| 551 | {["", "Just ", "another ", "Perl ", "Hacker"] -> [shift]};
|
|---|
| 552 | $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4}
|
|---|
| 553 | print 1, 2, 3, 4, "\n";
|
|---|
| 554 |
|
|---|
| 555 | ####### Overloaded constants 5
|
|---|
| 556 | BEGIN {my $x = "Knuth heals rare project\n";
|
|---|
| 557 | $^H {integer} = sub {my $y = shift; $_ = substr $x => $y & 0x1F, 1;
|
|---|
| 558 | $y > 32 ? uc : lc}; $^H = hex join "" => 2, 1, 1, 0, 0}
|
|---|
| 559 | print 52,2,10,23,16,8,1,19,3,6,15,12,5,49,21,14,9,11,36,13,22,32,7,18,24;
|
|---|
| 560 |
|
|---|
| 561 | ####### v-strings 1
|
|---|
| 562 | print v74.117.115.116.32;
|
|---|
| 563 | print v97.110.111.116.104.101.114.32;
|
|---|
| 564 | print v80.101.114.108.32;
|
|---|
| 565 | print v72.97.99.107.101.114.10;
|
|---|
| 566 |
|
|---|
| 567 | ####### v-strings 2
|
|---|
| 568 | print 74.117.115.116.32;
|
|---|
| 569 | print 97.110.111.116.104.101.114.32;
|
|---|
| 570 | print 80.101.114.108.32;
|
|---|
| 571 | print 72.97.99.107.101.114.10;
|
|---|
| 572 |
|
|---|
| 573 | ####### v-strings 3
|
|---|
| 574 | print v74.117.115.116.32, v97.110.111.116.104.101.114.32,
|
|---|
| 575 | v80.101.114.108.32, v72.97.99.107.101.114.10;
|
|---|
| 576 |
|
|---|
| 577 | ####### v-strings 4
|
|---|
| 578 | print 74.117.115.116.32, 97.110.111.116.104.101.114.32,
|
|---|
| 579 | 80.101.114.108.32, 72.97.99.107.101.114.10;
|
|---|
| 580 |
|
|---|
| 581 | ####### v-strings 5
|
|---|
| 582 | print v74.117.115.116.32.97.110.111.116.104.101.114.
|
|---|
| 583 | v32.80.101.114.108.32.72.97.99.107.101.114.10;
|
|---|
| 584 |
|
|---|
| 585 | ####### v-strings 6
|
|---|
| 586 | print 74.117.115.116.32.97.110.111.116.104.101.114.
|
|---|
| 587 | 32.80.101.114.108.32.72.97.99.107.101.114.10;
|
|---|
| 588 |
|
|---|
| 589 | ####### Symbolic references.
|
|---|
| 590 | map{${+chr}=chr}map{$_=>$_^ord$"}$=+$]..3*$=/2;
|
|---|
| 591 | print "$J$u$s$t $a$n$o$t$h$e$r $P$e$r$l $H$a$c$k$e$r\n";
|
|---|
| 592 |
|
|---|
| 593 | ####### $; fun
|
|---|
| 594 | $; # A lone dollar?
|
|---|
| 595 | =$"; # Pod?
|
|---|
| 596 | $; # The return of the lone dollar?
|
|---|
| 597 | {Just=>another=>Perl=>Hacker=>} # Bare block?
|
|---|
| 598 | =$/; # More pod?
|
|---|
| 599 | print%; # No right operand for %?
|
|---|
| 600 |
|
|---|
| 601 | ####### @; fun
|
|---|
| 602 | @;=split//=>"Joel, Preach sartre knuth\n";$;=chr 65;%;=map{$;++=>$_}
|
|---|
| 603 | 0,22,13,16,5,14,21,1,23,11,2,7,12,6,8,15,3,19,24,14,10,20,18,17,4,25
|
|---|
| 604 | ;print@;[@;{A..Z}];
|
|---|
| 605 | EXPECT: $JaPh_c
|
|---|
| 606 |
|
|---|
| 607 | ####### %; fun
|
|---|
| 608 | $;=$";$;{Just=>another=>Perl=>Hacker=>}=$/;print%;
|
|---|
| 609 |
|
|---|
| 610 | ####### &func;
|
|---|
| 611 | $_ = "\112\165\163\1648\141\156\157\164\150\145\1628\120\145"
|
|---|
| 612 | . "\162\1548\110\141\143\153\145\162\0128\177" and &japh;
|
|---|
| 613 | sub japh {print "@_" and return if pop; split /\d/ and &japh}
|
|---|
| 614 |
|
|---|
| 615 | ####### magic goto.
|
|---|
| 616 | sub _ {$_ = shift and y/b-yB-Y/a-yB-Y/ xor !@ _?
|
|---|
| 617 | exit print :
|
|---|
| 618 | print and push @_ => shift and goto &{(caller (0)) [3]}}
|
|---|
| 619 | split // => "KsvQtbuf fbsodpmu\ni flsI " xor & _
|
|---|
| 620 |
|
|---|
| 621 | ####### $: fun 1
|
|---|
| 622 | :$:=~s:$":Just$&another$&:;$:=~s:
|
|---|
| 623 | :Perl$"Hacker$&:;chop$:;print$:#:
|
|---|
| 624 |
|
|---|
| 625 | ####### $: fun 2
|
|---|
| 626 | :;$:=~s:
|
|---|
| 627 | -:;another Perl Hacker
|
|---|
| 628 | :;chop
|
|---|
| 629 | $:;$:=~y
|
|---|
| 630 | :;::d;print+Just.
|
|---|
| 631 | $:;
|
|---|
| 632 |
|
|---|
| 633 | ####### $: fun 3
|
|---|
| 634 | :;$:=~s:
|
|---|
| 635 | -:;another Perl Hacker
|
|---|
| 636 | :;chop
|
|---|
| 637 | $:;$:=~y:;::d;print+Just.$:
|
|---|
| 638 |
|
|---|
| 639 | ####### $!
|
|---|
| 640 | s[$,][join$,,(split$,,($!=85))[(q[0006143730380126152532042307].
|
|---|
| 641 | q[41342211132019313505])=~m[..]g]]e and y[yIbp][HJkP] and print;
|
|---|
| 642 | SKIP: Platform dependent.
|
|---|
| 643 |
|
|---|
| 644 | ####### die 1
|
|---|
| 645 | eval {die ["Just another Perl Hacker"]}; print ${$@}[$#{@${@}}]
|
|---|
| 646 |
|
|---|
| 647 | ####### die 2
|
|---|
| 648 | eval {die ["Just another Perl Hacker\n"]}; print ${$@}[$#{@${@}}]
|
|---|
| 649 |
|
|---|
| 650 | ####### die 3
|
|---|
| 651 | eval {die ["Just another Perl Hacker"]}; print ${${@}}[$#{@{${@}}}]
|
|---|
| 652 |
|
|---|
| 653 | ####### die 4
|
|---|
| 654 | eval {die ["Just another Perl Hacker\n"]}; print ${${@}}[$#{@{${@}}}]
|
|---|
| 655 |
|
|---|
| 656 | ####### die 5
|
|---|
| 657 | eval {die [[qq [Just another Perl Hacker]]]};; print
|
|---|
| 658 | ${${${@}}[$#{@{${@}}}]}[$#{${@{${@}}}[$#{@{${@}}}]}]
|
|---|
| 659 |
|
|---|
| 660 | ####### Closure returning itself.
|
|---|
| 661 | $_ = "\nrekcaH lreP rehtona tsuJ"; my $chop; $chop = sub {print chop; $chop};
|
|---|
| 662 | $chop -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> ()
|
|---|
| 663 | -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> () -> ()
|
|---|
| 664 |
|
|---|
| 665 | ####### Special blocks 1
|
|---|
| 666 | BEGIN {print "Just " }
|
|---|
| 667 | CHECK {print "another "}
|
|---|
| 668 | INIT {print "Perl " }
|
|---|
| 669 | END {print "Hacker\n"}
|
|---|
| 670 |
|
|---|
| 671 | ####### Special blocks 2
|
|---|
| 672 | END {print "Hacker\n"}
|
|---|
| 673 | INIT {print "Perl " }
|
|---|
| 674 | CHECK {print "another "}
|
|---|
| 675 | BEGIN {print "Just " }
|
|---|
| 676 |
|
|---|
| 677 | ####### Recursive regex.
|
|---|
| 678 | my $qr = qr/^.+?(;).+?\1|;Just another Perl Hacker;|;.+$/;
|
|---|
| 679 | $qr =~ s/$qr//g;
|
|---|
| 680 | print $qr, "\n";
|
|---|
| 681 |
|
|---|
| 682 | ####### use lib 'coderef'
|
|---|
| 683 | use lib sub {($\) = split /\./ => pop; print $"};
|
|---|
| 684 | eval "use Just" || eval "use another" || eval "use Perl" || eval "use Hacker";
|
|---|
| 685 | EXPECT
|
|---|
| 686 | Just another Perl Hacker
|
|---|
