1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
require Config; import Config;
}
$| = 1;
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
my $Is_NetWare = $^O eq 'NetWare';
my $tmpfile = "tmp0000";
my $i = 0 ;
1 while -f ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
my @w_files = () ;
if (@ARGV)
{ print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./lib/warnings/#; $_ } @ARGV }
else
{ @w_files = sort glob("lib/warnings/*") }
my $files = 0;
foreach my $file (@w_files) {
next if $file =~ /(~|\.orig|,v)$/;
open F, "<$file" or die "Cannot open $file: $!\n" ;
my $line = 0;
while (<F>) {
$line++;
last if /^__END__/ ;
}
{
local $/ = undef;
$files++;
@prgs = (@prgs, $file, split "\n########\n", <F>) ;
}
close F ;
}
undef $/;
print "1..", scalar(@prgs)-$files, "\n";
for (@prgs){
unless (/\n/)
{
print "# From $_\n";
next;
}
my $switch = "";
my @temps = () ;
if (s/^\s*-\w+//){
$switch = $&;
$switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
if ( $prog =~ /--FILE--/) {
my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
shift @files ;
die "Internal error test $i didn't split into pairs, got " .
scalar(@files) . "[" . join("%%%%", @files) ."]\n"
if @files % 2 ;
while (@files > 2) {
my $filename = shift @files ;
my $code = shift @files ;
push @temps, $filename ;
open F, ">$filename" or die "Cannot open $filename: $!\n" ;
print F $code ;
close F or die "Cannot close $filename: $!\n";
}
shift @files ;
$prog = shift @files ;
}
open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
print TEST q{
BEGIN {
open(STDERR, ">&STDOUT")
or die "Can't dup STDOUT->STDERR: $!;";
}
};
print TEST "\n#line 1\n"; # So the line numbers don't get messed up.
print TEST $prog,"\n";
close TEST or die "Cannot close $tmpfile: $!";
my $results = $Is_VMS ?
`./perl "-I../lib" $switch $tmpfile` :
$Is_MSWin32 ?
`.\\perl -I../lib $switch $tmpfile` :
$Is_NetWare ?
`perl -I../lib $switch $tmpfile` :
$Is_MacOS ?
`$^X -I::lib $switch -MMac::err=unix $tmpfile` :
`./perl -I../lib $switch $tmpfile`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
$results =~ s/tmp\d+/-/g;
if ($^O eq 'VMS') {
# some tests will trigger VMS messages that won't be expected
$results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
# pipes double these sometimes
$results =~ s/\n\n/\n/g;
}
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
$results =~ s/^(syntax|parse) error/syntax error/mig;
# allow all tests to run when there are leaks
$results =~ s/Scalars leaked: \d+\n//g;
$expected =~ s/\n+$//;
my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
# any special options? (OPTIONS foo bar zap)
my $option_regex = 0;
if ($expected =~ s/^OPTIONS? (.+)\n//) {
foreach my $option (split(' ', $1)) {
if ($option eq 'regex') { # allow regular expressions
$option_regex = 1;
} else {
die "$0: Unknown OPTION '$option'\n";
}
}
}
if ( $results =~ s/^SKIPPED\n//) {
print "$results\n" ;
}
elsif (($prefix && (( $option_regex && $results !~ /^$expected/) ||
(!$option_regex && $results !~ /^\Q$expected/))) or
(!$prefix && (( $option_regex && $results !~ /^$expected/) ||
(!$option_regex && $results ne $expected)))) {
print STDERR "PROG: $switch\n$prog\n";
print STDERR "EXPECTED:\n$expected\n";
print STDERR "GOT:\n$results\n";
print "not ";
}
print "ok ", ++$i, "\n";
foreach (@temps)
{ unlink $_ if $_ }
}
|
