Commit | Line | Data |
a0d0e21e |
1 | #!./perl |
2 | |
fb73857a |
3 | # NOTE: Please don't add tests to this file unless they *need* to be run in |
4 | # separate executable and can't simply use eval. |
5 | |
a0d0e21e |
6 | chdir 't' if -d 't'; |
93430cb4 |
7 | unshift @INC, "../lib"; |
a0d0e21e |
8 | $ENV{PERL5LIB} = "../lib"; |
9 | |
10 | $|=1; |
11 | |
12 | undef $/; |
13 | @prgs = split "\n########\n", <DATA>; |
14 | print "1..", scalar @prgs, "\n"; |
15 | |
16 | $tmpfile = "misctmp000"; |
17 | 1 while -f ++$tmpfile; |
18 | END { unlink $tmpfile if $tmpfile; } |
19 | |
68dc0745 |
20 | $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); |
21 | |
a0d0e21e |
22 | for (@prgs){ |
23 | my $switch; |
fb73857a |
24 | if (s/^\s*(-\w.*)//){ |
25 | $switch = $1; |
a0d0e21e |
26 | } |
27 | my($prog,$expected) = split(/\nEXPECT\n/, $_); |
648cac19 |
28 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
29 | print TEST $prog, "\n"; |
30 | close TEST or die "Cannot close $tmpfile: $!"; |
31 | |
68dc0745 |
32 | if ($^O eq 'MSWin32') { |
648cac19 |
33 | $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; |
68dc0745 |
34 | } |
35 | else { |
648cac19 |
36 | $results = `./perl $switch $tmpfile 2>&1`; |
68dc0745 |
37 | } |
a0d0e21e |
38 | $status = $?; |
a0d0e21e |
39 | $results =~ s/\n+$//; |
648cac19 |
40 | $results =~ s/at\s+misctmp\d+\s+line/at - line/g; |
41 | $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; |
f0ec1f9a |
42 | # bison says 'parse error' instead of 'syntax error', |
d91e2bdb |
43 | # various yaccs may or may not capitalize 'syntax'. |
2a8ee232 |
44 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
a0d0e21e |
45 | $expected =~ s/\n+$//; |
8feb4e9f |
46 | if ( $results ne $expected ) { |
a0d0e21e |
47 | print STDERR "PROG: $switch\n$prog\n"; |
48 | print STDERR "EXPECTED:\n$expected\n"; |
49 | print STDERR "GOT:\n$results\n"; |
50 | print "not "; |
51 | } |
52 | print "ok ", ++$i, "\n"; |
53 | } |
54 | |
55 | __END__ |
2ace3117 |
56 | ()=() |
57 | ######## |
44a8e56a |
58 | $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" |
59 | EXPECT |
60 | a := b := c |
61 | ######## |
ea12c2aa |
62 | eval { $q = pack "q", 0 }; |
63 | if ($@) { |
36477c24 |
64 | $cusp = ~0 ^ (~0 >> 1); |
65 | $, = " "; |
66 | print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; |
ea12c2aa |
67 | } else { |
68 | # We are on a 64-bit platform: fake it. |
69 | # (If we have long doubles we might not need to fake it.) |
70 | # Background: the $cusp will get converted from a UV into an NV because of |
71 | # the subtraction and addition. Taking away or adding 1 from such a large |
72 | # NV doesn't actually change the NV, so the modulo fails. |
73 | print "7 0 0 1 !\n"; |
74 | } |
36477c24 |
75 | EXPECT |
76 | 7 0 0 1 ! |
77 | ######## |
a0d0e21e |
78 | $foo=undef; $foo->go; |
79 | EXPECT |
72b5445b |
80 | Can't call method "go" on an undefined value at - line 1. |
a0d0e21e |
81 | ######## |
82 | BEGIN |
83 | { |
84 | "foo"; |
85 | } |
86 | ######## |
a0d0e21e |
87 | $array[128]=1 |
88 | ######## |
89 | $x=0x0eabcd; print $x->ref; |
90 | EXPECT |
91 | Can't call method "ref" without a package or object reference at - line 1. |
92 | ######## |
648cac19 |
93 | chop ($str .= <DATA>); |
a0d0e21e |
94 | ######## |
95 | close ($banana); |
96 | ######## |
97 | $x=2;$y=3;$x<$y ? $x : $y += 23;print $x; |
98 | EXPECT |
99 | 25 |
100 | ######## |
101 | eval {sub bar {print "In bar";}} |
102 | ######## |
68dc0745 |
103 | system './perl -ne "print if eof" /dev/null' |
a0d0e21e |
104 | ######## |
648cac19 |
105 | chop($file = <DATA>); |
a0d0e21e |
106 | ######## |
107 | package N; |
108 | sub new {my ($obj,$n)=@_; bless \$n} |
109 | $aa=new N 1; |
110 | $aa=12345; |
111 | print $aa; |
112 | EXPECT |
113 | 12345 |
114 | ######## |
115 | %@x=0; |
116 | EXPECT |
3fe9a6f1 |
117 | Can't modify hash deref in repeat at - line 1, near "0;" |
118 | Execution of - aborted due to compilation errors. |
a0d0e21e |
119 | ######## |
120 | $_="foo"; |
121 | printf(STDOUT "%s\n", $_); |
122 | EXPECT |
123 | foo |
124 | ######## |
125 | push(@a, 1, 2, 3,) |
126 | ######## |
127 | quotemeta "" |
128 | ######## |
129 | for ("ABCDE") { |
130 | ⊂ |
131 | s/./&sub($&)/eg; |
132 | print;} |
133 | sub sub {local($_) = @_; |
134 | $_ x 4;} |
135 | EXPECT |
136 | Modification of a read-only value attempted at - line 3. |
137 | ######## |
138 | package FOO;sub new {bless {FOO => BAR}}; |
139 | package main; |
140 | use strict vars; |
141 | my $self = new FOO; |
142 | print $$self{FOO}; |
143 | EXPECT |
144 | BAR |
145 | ######## |
146 | $_="foo"; |
147 | s/.{1}//s; |
148 | print; |
149 | EXPECT |
150 | oo |
151 | ######## |
152 | print scalar ("foo","bar") |
153 | EXPECT |
154 | bar |
155 | ######## |
156 | sub by_number { $a <=> $b; };# inline function for sort below |
157 | $as_ary{0}="a0"; |
158 | @ordered_array=sort by_number keys(%as_ary); |
159 | ######## |
160 | sub NewShell |
161 | { |
162 | local($Host) = @_; |
163 | my($m2) = $#Shells++; |
164 | $Shells[$m2]{HOST} = $Host; |
165 | return $m2; |
166 | } |
167 | |
168 | sub ShowShell |
169 | { |
170 | local($i) = @_; |
171 | } |
172 | |
173 | &ShowShell(&NewShell(beach,Work,"+0+0")); |
174 | &ShowShell(&NewShell(beach,Work,"+0+0")); |
175 | &ShowShell(&NewShell(beach,Work,"+0+0")); |
176 | ######## |
177 | { |
178 | package FAKEARRAY; |
179 | |
180 | sub TIEARRAY |
181 | { print "TIEARRAY @_\n"; |
182 | die "bomb out\n" unless $count ++ ; |
183 | bless ['foo'] |
184 | } |
185 | sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } |
186 | sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } |
187 | sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } |
188 | } |
189 | |
190 | eval 'tie @h, FAKEARRAY, fred' ; |
191 | tie @h, FAKEARRAY, fred ; |
192 | EXPECT |
193 | TIEARRAY FAKEARRAY fred |
194 | TIEARRAY FAKEARRAY fred |
195 | DESTROY |
196 | ######## |
197 | BEGIN { die "phooey\n" } |
198 | EXPECT |
199 | phooey |
200 | BEGIN failed--compilation aborted at - line 1. |
201 | ######## |
202 | BEGIN { 1/$zero } |
203 | EXPECT |
204 | Illegal division by zero at - line 1. |
205 | BEGIN failed--compilation aborted at - line 1. |
206 | ######## |
207 | BEGIN { undef = 0 } |
208 | EXPECT |
209 | Modification of a read-only value attempted at - line 1. |
210 | BEGIN failed--compilation aborted at - line 1. |
a7adf1f0 |
211 | ######## |
212 | { |
213 | package foo; |
214 | sub PRINT { |
215 | shift; |
216 | print join(' ', reverse @_)."\n"; |
217 | } |
46fc3d4c |
218 | sub PRINTF { |
219 | shift; |
220 | my $fmt = shift; |
221 | print sprintf($fmt, @_)."\n"; |
222 | } |
a7adf1f0 |
223 | sub TIEHANDLE { |
224 | bless {}, shift; |
225 | } |
58f51617 |
226 | sub READLINE { |
227 | "Out of inspiration"; |
228 | } |
a7adf1f0 |
229 | sub DESTROY { |
230 | print "and destroyed as well\n"; |
2ae324a7 |
231 | } |
232 | sub READ { |
233 | shift; |
234 | print STDOUT "foo->can(READ)(@_)\n"; |
235 | return 100; |
236 | } |
237 | sub GETC { |
238 | shift; |
239 | print STDOUT "Don't GETC, Get Perl\n"; |
240 | return "a"; |
241 | } |
a7adf1f0 |
242 | } |
243 | { |
244 | local(*FOO); |
245 | tie(*FOO,'foo'); |
246 | print FOO "sentence.", "reversed", "a", "is", "This"; |
58f51617 |
247 | print "-- ", <FOO>, " --\n"; |
2ae324a7 |
248 | my($buf,$len,$offset); |
249 | $buf = "string"; |
250 | $len = 10; $offset = 1; |
251 | read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; |
252 | getc(FOO) eq "a" or die "foo->GETC failed"; |
46fc3d4c |
253 | printf "%s is number %d\n", "Perl", 1; |
a7adf1f0 |
254 | } |
255 | EXPECT |
256 | This is a reversed sentence. |
58f51617 |
257 | -- Out of inspiration -- |
2ae324a7 |
258 | foo->can(READ)(string 10 1) |
259 | Don't GETC, Get Perl |
46fc3d4c |
260 | Perl is number 1 |
a7adf1f0 |
261 | and destroyed as well |
a6006777 |
262 | ######## |
263 | my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" |
264 | EXPECT |
265 | 2 2 2 |
266 | ######## |
267 | @a = ($a, $b, $c, $d) = (5, 6); |
268 | print "ok\n" |
269 | if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); |
270 | EXPECT |
271 | ok |
272 | ######## |
273 | print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); |
274 | EXPECT |
275 | ok |
276 | ######## |
8ebc5c01 |
277 | print "ok\n" if ("\0" lt "\xFF"); |
a6006777 |
278 | EXPECT |
279 | ok |
280 | ######## |
281 | open(H,'op/misc.t'); # must be in the 't' directory |
282 | stat(H); |
283 | print "ok\n" if (-e _ and -f _ and -r _); |
284 | EXPECT |
285 | ok |
286 | ######## |
287 | sub thing { 0 || return qw(now is the time) } |
288 | print thing(), "\n"; |
289 | EXPECT |
290 | nowisthetime |
291 | ######## |
292 | $ren = 'joy'; |
293 | $stimpy = 'happy'; |
294 | { local $main::{ren} = *stimpy; print $ren, ' ' } |
295 | print $ren, "\n"; |
296 | EXPECT |
297 | happy joy |
298 | ######## |
299 | $stimpy = 'happy'; |
300 | { local $main::{ren} = *stimpy; print ${'ren'}, ' ' } |
301 | print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; |
302 | EXPECT |
303 | happy joy |
304 | ######## |
305 | package p; |
306 | sub func { print 'really ' unless wantarray; 'p' } |
307 | sub groovy { 'groovy' } |
308 | package main; |
309 | print p::func()->groovy(), "\n" |
310 | EXPECT |
311 | really groovy |
312 | ######## |
d53f8f1c |
313 | @list = ([ 'one', 1 ], [ 'two', 2 ]); |
314 | sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } |
315 | print scalar(map &func($_), 1 .. 3), " ", |
316 | scalar(map scalar &func($_), 1 .. 3), "\n"; |
317 | EXPECT |
318 | 2 3 |
319 | ######## |
44a8e56a |
320 | ($k, $s) = qw(x 0); |
321 | @{$h{$k}} = qw(1 2 4); |
322 | for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } |
323 | print "bogus\n" unless $s == 7; |
324 | ######## |
325 | my $a = 'outer'; |
326 | eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; |
327 | eval { my $x = 'peace'; eval q[ print "$x\n" ] } |
328 | EXPECT |
329 | inner peace |
774d564b |
330 | ######## |
331 | -w |
332 | $| = 1; |
333 | sub foo { |
334 | print "In foo1\n"; |
335 | eval 'sub foo { print "In foo2\n" }'; |
336 | print "Exiting foo1\n"; |
337 | } |
338 | foo; |
339 | foo; |
340 | EXPECT |
341 | In foo1 |
342 | Subroutine foo redefined at (eval 1) line 1. |
343 | Exiting foo1 |
344 | In foo2 |
345 | ######## |
346 | $s = 0; |
347 | map {#this newline here tickles the bug |
348 | $s += $_} (1,2,4); |
349 | print "eat flaming death\n" unless ($s == 7); |
1ca7b98a |
350 | ######## |
351 | sub foo { local $_ = shift; split; @_ } |
352 | @x = foo(' x y z '); |
353 | print "you die joe!\n" unless "@x" eq 'x y z'; |
c277df42 |
354 | ######## |
355 | /(?{"{"})/ # Check it outside of eval too |
356 | EXPECT |
2cd61cdb |
357 | Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern |
358 | /(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1. |
c277df42 |
359 | ######## |
360 | /(?{"{"}})/ # Check it outside of eval too |
361 | EXPECT |
d98d5fff |
362 | Unmatched right curly bracket at (re_eval 1) line 1, at end of line |
c277df42 |
363 | syntax error at (re_eval 1) line 1, near ""{"}" |
2cd61cdb |
364 | Compilation failed in regexp at - line 1. |
0da4822f |
365 | ######## |
366 | BEGIN { @ARGV = qw(a b c) } |
367 | BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } |
368 | END { print "end <",shift,">\nargv <@ARGV>\n" } |
369 | INIT { print "init <",shift,">\n" } |
370 | EXPECT |
371 | argv <a b c> |
372 | begin <a> |
373 | init <b> |
374 | end <c> |
375 | argv <> |
4599a1de |
376 | ######## |
3500f679 |
377 | -l |
378 | # fdopen from a system descriptor to a system descriptor used to close |
379 | # the former. |
380 | open STDERR, '>&=STDOUT' or die $!; |
381 | select STDOUT; $| = 1; print fileno STDOUT; |
382 | select STDERR; $| = 1; print fileno STDERR; |
383 | EXPECT |
384 | 1 |
385 | 2 |
386 | ######## |
20408e3c |
387 | -w |
388 | sub testme { my $a = "test"; { local $a = "new test"; print $a }} |
389 | EXPECT |
390 | Can't localize lexical variable $a at - line 2. |
391 | ######## |
51ae5c03 |
392 | package X; |
393 | sub ascalar { my $r; bless \$r } |
394 | sub DESTROY { print "destroyed\n" }; |
395 | package main; |
396 | *s = ascalar X; |
397 | EXPECT |
398 | destroyed |
399 | ######## |
400 | package X; |
401 | sub anarray { bless [] } |
402 | sub DESTROY { print "destroyed\n" }; |
403 | package main; |
404 | *a = anarray X; |
405 | EXPECT |
406 | destroyed |
407 | ######## |
408 | package X; |
409 | sub ahash { bless {} } |
410 | sub DESTROY { print "destroyed\n" }; |
411 | package main; |
412 | *h = ahash X; |
413 | EXPECT |
414 | destroyed |
415 | ######## |
416 | package X; |
417 | sub aclosure { my $x; bless sub { ++$x } } |
418 | sub DESTROY { print "destroyed\n" }; |
419 | package main; |
420 | *c = aclosure X; |
421 | EXPECT |
422 | destroyed |
423 | ######## |
424 | package X; |
425 | sub any { bless {} } |
426 | my $f = "FH000"; # just to thwart any future optimisations |
ded8aa31 |
427 | sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } |
51ae5c03 |
428 | sub DESTROY { print "destroyed\n" } |
429 | package main; |
430 | $x = any X; # to bump sv_objcount. IO objs aren't counted?? |
431 | *f = afh X; |
432 | EXPECT |
433 | destroyed |
434 | destroyed |
435 | ######## |
ebf99b04 |
436 | BEGIN { |
437 | $| = 1; |
438 | $SIG{__WARN__} = sub { |
439 | eval { print $_[0] }; |
440 | die "bar\n"; |
441 | }; |
442 | warn "foo\n"; |
443 | } |
444 | EXPECT |
445 | foo |
446 | bar |
447 | BEGIN failed--compilation aborted at - line 8. |
8feb4e9f |
448 | ######## |
449 | package X; |
450 | @ISA='Y'; |
451 | sub new { |
452 | my $class = shift; |
453 | my $self = { }; |
454 | bless $self, $class; |
455 | my $init = shift; |
456 | $self->foo($init); |
457 | print "new", $init; |
458 | return $self; |
459 | } |
460 | sub DESTROY { |
461 | my $self = shift; |
462 | print "DESTROY", $self->foo; |
463 | } |
464 | package Y; |
465 | sub attribute { |
466 | my $self = shift; |
467 | my $var = shift; |
468 | if (@_ == 0) { |
469 | return $self->{$var}; |
470 | } elsif (@_ == 1) { |
471 | $self->{$var} = shift; |
472 | } |
473 | } |
474 | sub AUTOLOAD { |
475 | $AUTOLOAD =~ /::([^:]+)$/; |
476 | my $method = $1; |
477 | splice @_, 1, 0, $method; |
478 | goto &attribute; |
479 | } |
480 | package main; |
481 | my $x = X->new(1); |
482 | for (2..3) { |
483 | my $y = X->new($_); |
484 | print $y->foo; |
485 | } |
486 | print $x->foo; |
487 | EXPECT |
488 | new1new22DESTROY2new33DESTROY31DESTROY1 |
dfad63ad |
489 | ######## |
490 | re(); |
491 | sub re { |
492 | my $re = join '', eval 'qr/(?p{ $obj->method })/'; |
493 | $re; |
494 | } |
495 | EXPECT |
1aff0e91 |
496 | ######## |
497 | use strict; |
498 | my $foo = "ZZZ\n"; |
499 | END { print $foo } |
500 | EXPECT |
501 | ZZZ |
502 | ######## |
503 | eval ' |
504 | use strict; |
505 | my $foo = "ZZZ\n"; |
506 | END { print $foo } |
507 | '; |
508 | EXPECT |
509 | ZZZ |
7399586d |
510 | ######## |
511 | -w |
512 | if (@ARGV) { print "" } |
513 | else { |
514 | if ($x == 0) { print "" } else { print $x } |
515 | } |
516 | EXPECT |
517 | Use of uninitialized value at - line 4. |