1#!./perl
2
3##
4## Many of these tests are originally from Michael Schroeder
5## <Michael.Schroeder@informatik.uni-erlangen.de>
6## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com>
7##
8
9chdir 't' if -d 't';
10@INC = '../lib';
11$Is_VMS = $^O eq 'VMS';
12$Is_MSWin32 = $^O eq 'MSWin32';
13$Is_NetWare = $^O eq 'NetWare';
14$Is_MacOS = $^O eq 'MacOS';
15$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
16
17$|=1;
18
19undef $/;
20@prgs = split "\n########\n", <DATA>;
21print "1..", scalar @prgs, "\n";
22
23$tmpfile = "runltmp000";
241 while -f ++$tmpfile;
25END { if ($tmpfile) { 1 while unlink $tmpfile; } }
26
27for (@prgs){
28    my $switch = "";
29    if (s/^\s*(-\w+)//){
30       $switch = $1;
31    }
32    my($prog,$expected) = split(/\nEXPECT\n/, $_);
33    open TEST, ">$tmpfile";
34    print TEST "$prog\n";
35    close TEST or die "Could not close: $!";
36    my $results = $Is_VMS ?
37                      `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
38		  $Is_MSWin32 ?  
39		      `.\\perl -I../lib $switch $tmpfile 2>&1` :
40		  $Is_NetWare ?  
41		      `perl -I../lib $switch $tmpfile 2>&1` :
42		  $Is_MacOS ?
43		      `$^X -I::lib -MMac::err=unix $switch $tmpfile` :
44		  `./perl $switch $tmpfile 2>&1`;
45    my $status = $?;
46    $results =~ s/\n+$//;
47    # allow expected output to be written as if $prog is on STDIN
48    $results =~ s/runltmp\d+/-/g;
49    $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
50    $expected =~ s/\n+$//;
51    if ($results ne $expected) {
52       print STDERR "PROG: $switch\n$prog\n";
53       print STDERR "EXPECTED:\n$expected\n";
54       print STDERR "GOT:\n$results\n";
55       print "not ";
56    }
57    print "ok ", ++$i, "\n";
58}
59
60__END__
61@a = (1, 2, 3);
62{
63  @a = sort { last ; } @a;
64}
65EXPECT
66Can't "last" outside a loop block at - line 3.
67########
68package TEST;
69 
70sub TIESCALAR {
71  my $foo;
72  return bless \$foo;
73}
74sub FETCH {
75  eval 'die("test")';
76  print "still in fetch\n";
77  return ">$@<";
78}
79package main;
80 
81tie $bar, TEST;
82print "- $bar\n";
83EXPECT
84still in fetch
85- >test at (eval 1) line 1.
86<
87########
88package TEST;
89 
90sub TIESCALAR {
91  my $foo;
92  eval('die("foo\n")');
93  print "after eval\n";
94  return bless \$foo;
95}
96sub FETCH {
97  return "ZZZ";
98}
99 
100package main;
101 
102tie $bar, TEST;
103print "- $bar\n";
104print "OK\n";
105EXPECT
106after eval
107- ZZZ
108OK
109########
110package TEST;
111 
112sub TIEHANDLE {
113  my $foo;
114  return bless \$foo;
115}
116sub PRINT {
117print STDERR "PRINT CALLED\n";
118(split(/./, 'x'x10000))[0];
119eval('die("test\n")');
120}
121 
122package main;
123 
124open FH, ">&STDOUT";
125tie *FH, TEST;
126print FH "OK\n";
127print STDERR "DONE\n";
128EXPECT
129PRINT CALLED
130DONE
131########
132sub warnhook {
133  print "WARNHOOK\n";
134  eval('die("foooo\n")');
135}
136$SIG{'__WARN__'} = 'warnhook';
137warn("dfsds\n");
138print "END\n";
139EXPECT
140WARNHOOK
141END
142########
143package TEST;
144 
145use overload
146     "\"\""   =>  \&str
147;
148 
149sub str {
150  eval('die("test\n")');
151  return "STR";
152}
153 
154package main;
155 
156$bar = bless {}, TEST;
157print "$bar\n";
158print "OK\n";
159EXPECT
160STR
161OK
162########
163sub foo {
164  $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
165}
166@a = (3, 2, 0, 1);
167@a = sort foo @a;
168print join(', ', @a)."\n";
169EXPECT
1700, 1, 2, 3
171########
172sub foo {
173  goto bar if $a == 0 || $b == 0;
174  $a <=> $b;
175}
176@a = (3, 2, 0, 1);
177@a = sort foo @a;
178print join(', ', @a)."\n";
179exit;
180bar:
181print "bar reached\n";
182EXPECT
183Can't "goto" out of a pseudo block at - line 2.
184########
185%seen = ();
186sub sortfn {
187  (split(/./, 'x'x10000))[0];
188  my (@y) = ( 4, 6, 5);
189  @y = sort { $a <=> $b } @y;
190  my $t = "sortfn ".join(', ', @y)."\n";
191  print $t if ($seen{$t}++ == 0);
192  return $_[0] <=> $_[1];
193}
194@x = ( 3, 2, 1 );
195@x = sort { &sortfn($a, $b) } @x;
196print "---- ".join(', ', @x)."\n";
197EXPECT
198sortfn 4, 5, 6
199---- 1, 2, 3
200########
201@a = (3, 2, 1);
202@a = sort { eval('die("no way")') ,  $a <=> $b} @a;
203print join(", ", @a)."\n";
204EXPECT
2051, 2, 3
206########
207@a = (1, 2, 3);
208foo:
209{
210  @a = sort { last foo; } @a;
211}
212EXPECT
213Label not found for "last foo" at - line 2.
214########
215package TEST;
216 
217sub TIESCALAR {
218  my $foo;
219  return bless \$foo;
220}
221sub FETCH {
222  next;
223  return "ZZZ";
224}
225sub STORE {
226}
227 
228package main;
229 
230tie $bar, TEST;
231{
232  print "- $bar\n";
233}
234print "OK\n";
235EXPECT
236Can't "next" outside a loop block at - line 8.
237########
238package TEST;
239 
240sub TIESCALAR {
241  my $foo;
242  return bless \$foo;
243}
244sub FETCH {
245  goto bbb;
246  return "ZZZ";
247}
248 
249package main;
250 
251tie $bar, TEST;
252print "- $bar\n";
253exit;
254bbb:
255print "bbb\n";
256EXPECT
257Can't find label bbb at - line 8.
258########
259sub foo {
260  $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
261}
262@a = (3, 2, 0, 1);
263@a = sort foo @a;
264print join(', ', @a)."\n";
265EXPECT
2660, 1, 2, 3
267########
268package TEST;
269sub TIESCALAR {
270  my $foo;
271  return bless \$foo;
272}
273sub FETCH {
274  return "fetch";
275}
276sub STORE {
277(split(/./, 'x'x10000))[0];
278}
279package main;
280tie $bar, TEST;
281$bar = "x";
282########
283package TEST;
284sub TIESCALAR {
285  my $foo;
286  next;
287  return bless \$foo;
288}
289package main;
290{
291tie $bar, TEST;
292}
293EXPECT
294Can't "next" outside a loop block at - line 4.
295########
296@a = (1, 2, 3);
297foo:
298{
299  @a = sort { exit(0) } @a;
300}
301END { print "foobar\n" }
302EXPECT
303foobar
304########
305$SIG{__DIE__} = sub {
306    print "In DIE\n";
307    $i = 0;
308    while (($p,$f,$l,$s) = caller(++$i)) {
309        print "$p|$f|$l|$s\n";
310    }
311};
312eval { die };
313&{sub { eval 'die' }}();
314sub foo { eval { die } } foo();
315{package rmb; sub{ eval{die} } ->() };	# check __ANON__ knows package	
316EXPECT
317In DIE
318main|-|8|(eval)
319In DIE
320main|-|9|(eval)
321main|-|9|main::__ANON__
322In DIE
323main|-|10|(eval)
324main|-|10|main::foo
325In DIE
326rmb|-|11|(eval)
327rmb|-|11|rmb::__ANON__
328########
329package TEST;
330 
331sub TIEARRAY {
332  return bless [qw(foo fee fie foe)], $_[0];
333}
334sub FETCH {
335  my ($s,$i) = @_;
336  if ($i) {
337    goto bbb;
338  }
339bbb:
340  return $s->[$i];
341}
342 
343package main;
344tie my @bar, 'TEST';
345print join('|', @bar[0..3]), "\n"; 
346EXPECT
347foo|fee|fie|foe
348########
349package TH;
350sub TIEHASH { bless {}, TH }
351sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
352tie %h, TH;
353eval { $h{A} = 1; print "never\n"; };
354print $@;
355eval { $h{B} = 2; };
356print $@;
357EXPECT
358A 1
359bar
360B 2
361bar
362########
363sub n { 0 }
364sub f { my $x = shift; d(); }
365f(n());
366f();
367
368sub d {
369    my $i = 0; my @a;
370    while (do { { package DB; @a = caller($i++) } } ) {
371        @a = @DB::args;
372        for (@a) { print "$_\n"; $_ = '' }
373    }
374}
375EXPECT
3760
377########
378sub TIEHANDLE { bless {} }
379sub PRINT { next }
380
381tie *STDERR, '';
382{ map ++$_, 1 }
383
384EXPECT
385Can't "next" outside a loop block at - line 2.
386########
387sub TIEHANDLE { bless {} }
388sub PRINT { print "[TIE] $_[1]" }
389
390tie *STDERR, '';
391die "DIE\n";
392
393EXPECT
394[TIE] DIE
395########
396sub TIEHANDLE { bless {} }
397sub PRINT { 
398    (split(/./, 'x'x10000))[0];
399    eval('die("test\n")');
400    warn "[TIE] $_[1]";
401}
402open OLDERR, '>&STDERR';
403tie *STDERR, '';
404
405use warnings FATAL => qw(uninitialized);
406print undef;
407
408EXPECT
409[TIE] Use of uninitialized value in print at - line 11.
410