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