1#!./perl 
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    $ENV{PERL5LIB} = '../lib';
7}
8
9$| = 1;
10undef $/;
11my @prgs = split "\n########\n", <DATA>;
12print "1..", scalar @prgs, "\n";
13
14my $Is_VMS = $^O eq 'VMS';
15my $Is_MSWin32 = $^O eq 'MSWin32';
16my $Is_NetWare = $^O eq 'NetWare';
17my $Is_MacOS = $^O eq 'MacOS';
18my $tmpfile = "tmp0000";
19my $i = 0 ;
201 while -e ++$tmpfile;
21END {  if ($tmpfile) { 1 while unlink $tmpfile} }
22
23for (@prgs){
24    my $switch = "";
25    my @temps = () ;
26    if (s/^\s*-\w+//){
27        $switch = $&;
28    }
29    my($prog,$expected) = split(/\nEXPECT\n/, $_);
30    if ( $prog =~ /--FILE--/) {
31        my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
32	shift @files ;
33	die "Internal error test $i didn't split into pairs, got " . 
34		scalar(@files) . "[" . join("%%%%", @files) ."]\n"
35	    if @files % 2 ;
36	while (@files > 2) {
37	    my $filename = shift @files ;
38	    my $code = shift @files ;
39    	    push @temps, $filename ;
40	    open F, ">$filename" or die "Cannot open $filename: $!\n" ;
41	    print F $code ;
42	    close F ;
43	}
44	shift @files ;
45	$prog = shift @files ;
46    }
47    open TEST, ">$tmpfile";
48    print TEST $prog,"\n";
49    close TEST;
50    my $results = $Is_VMS ?
51	              `./perl $switch $tmpfile 2>&1` :
52		  $Is_MSWin32 ?
53		      `.\\perl -I../lib $switch $tmpfile 2>&1` :
54		  $Is_NetWare ?
55		      `perl -I../lib $switch $tmpfile 2>&1` :
56		  $Is_MacOS ?
57		      `$^X -I::lib -MMac::err=unix $switch $tmpfile` :
58                  `./perl $switch $tmpfile 2>&1`;
59    my $status = $?;
60    $results =~ s/\n+$//;
61    # allow expected output to be written as if $prog is on STDIN
62    $results =~ s/tmp\d+/-/g;
63    $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
64# bison says 'parse error' instead of 'syntax error',
65# various yaccs may or may not capitalize 'syntax'.
66    $results =~ s/^(syntax|parse) error/syntax error/mig;
67    $expected =~ s/\n+$//;
68    my $prefix = ($results =~ s/^PREFIX\n//) ;
69    if ( $results =~ s/^SKIPPED\n//) {
70	print "$results\n" ;
71    }
72    elsif (($prefix and $results !~ /^\Q$expected/) or
73	   (!$prefix and $results ne $expected)){
74        print STDERR "PROG: $switch\n$prog\n";
75        print STDERR "EXPECTED:\n$expected\n";
76        print STDERR "GOT:\n$results\n";
77        print "not ";
78    }
79    print "ok ", ++$i, "\n";
80    foreach (@temps) 
81	{ unlink $_ if $_ } 
82}
83
84__END__
85
86# Error - not predeclaring a sub
87Fred 1,2 ;
88sub Fred {}
89EXPECT
90Number found where operator expected at - line 3, near "Fred 1"
91	(Do you need to predeclare Fred?)
92syntax error at - line 3, near "Fred 1"
93Execution of - aborted due to compilation errors.
94########
95
96# Error - not predeclaring a sub in time
97Fred 1,2 ;
98use subs qw( Fred ) ;
99sub Fred {}
100EXPECT
101Number found where operator expected at - line 3, near "Fred 1"
102	(Do you need to predeclare Fred?)
103syntax error at - line 3, near "Fred 1"
104BEGIN not safe after errors--compilation aborted at - line 4.
105########
106
107# AOK
108use subs qw( Fred) ;
109Fred 1,2 ;
110sub Fred { print $_[0] + $_[1], "\n" }
111EXPECT
1123
113########
114
115# override a built-in function
116use subs qw( open ) ;
117open 1,2 ;
118sub open { print $_[0] + $_[1], "\n" }
119EXPECT
1203
121########
122
123# override a built-in function, call after definition
124use subs qw( open ) ;
125sub open { print $_[0] + $_[1], "\n" }
126open 1,2 ;
127EXPECT
1283
129########
130
131# override a built-in function, call with ()
132use subs qw( open ) ;
133open (1,2) ;
134sub open { print $_[0] + $_[1], "\n" }
135EXPECT
1363
137########
138
139# override a built-in function, call with () after definition
140use subs qw( open ) ;
141sub open { print $_[0] + $_[1], "\n" }
142open (1,2) ;
143EXPECT
1443
145########
146
147--FILE-- abc
148Fred 1,2 ;
1491;
150--FILE--
151use subs qw( Fred ) ;
152require "./abc" ;
153sub Fred { print $_[0] + $_[1], "\n" }
154EXPECT
1553
156########
157
158# check that it isn't affected by block scope
159{
160    use subs qw( Fred ) ;
161}
162Fred 1, 2;
163sub Fred { print $_[0] + $_[1], "\n" }
164EXPECT
1653
166