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