This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e5c9af4928cd32578c753257f80483cd38f74f14
[perl5.git] / t / lib / common.pl
1 # This code is used by lib/charnames.t, lib/feature.t, lib/subs.t,
2 # lib/strict.t and lib/warnings.t
3
4 BEGIN {
5     require './test.pl';
6 }
7
8 use Config;
9 use File::Path;
10 use File::Spec::Functions;
11
12 use strict;
13 use warnings;
14 my (undef, $file) = caller;
15 my ($pragma_name) = $file =~ /([A-Za-z_0-9]+)\.t$/
16     or die "Can't identify pragama to test from file name '$file'";
17
18 $| = 1;
19
20 my $tmpfile = tempfile();
21
22 my @prgs = () ;
23 my @w_files = () ;
24
25 if (@ARGV)
26   { print "ARGV = [@ARGV]\n" ;
27       @w_files = map { s#^#./lib/$pragma_name/#; $_ } @ARGV
28   }
29 else
30   { @w_files = sort glob(catfile(curdir(), "lib", $pragma_name, "*")) }
31
32 my $files = 0;
33 foreach my $file (@w_files) {
34
35     next if $file =~ /(~|\.orig|,v)$/;
36     next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
37     next if -d $file;
38
39     open F, "<$file" or die "Cannot open $file: $!\n" ;
40     my $line = 0;
41     while (<F>) {
42         $line++;
43         last if /^__END__/ ;
44     }
45
46     {
47         local $/ = undef;
48         $files++;
49         @prgs = (@prgs, $file, split "\n########\n", <F>) ;
50     }
51     close F ;
52 }
53
54 undef $/;
55
56 plan tests => (scalar(@prgs)-$files + ($::local_tests || 0));
57
58 for (@prgs){
59     unless (/\n/)
60      {
61       print "# From $_\n";
62       next;
63      }
64     my $switch = "";
65     my @temps = () ;
66     my @temp_path = () ;
67     if (s/^\s*-\w+//){
68         $switch = $&;
69     }
70     my($prog,$expected) = split(/\nEXPECT(?:\n|$)/, $_, 2);
71
72     my %reason;
73     foreach my $what (qw(skip todo)) {
74         $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
75         # If the SKIP reason starts ? then it's taken as a code snippet to
76         # evaluate. This provides the flexibility to have conditional SKIPs
77         if ($reason{$what} && $reason{$what} =~ s/^\?//) {
78             my $temp = eval $reason{$what};
79             if ($@) {
80                 die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
81             }
82             $reason{$what} = $temp;
83         }
84     }
85
86     if ( $prog =~ /--FILE--/) {
87         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
88         shift @files ;
89         die "Internal error: test $_ didn't split into pairs, got " .
90                 scalar(@files) . "[" . join("%%%%", @files) ."]\n"
91             if @files % 2 ;
92         while (@files > 2) {
93             my $filename = shift @files ;
94             my $code = shift @files ;
95             push @temps, $filename ;
96             if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) {
97                 mkpath($1);
98                 push(@temp_path, $1);
99             }
100             open F, ">$filename" or die "Cannot open $filename: $!\n" ;
101             print F $code ;
102             close F or die "Cannot close $filename: $!\n";
103         }
104         shift @files ;
105         $prog = shift @files ;
106     }
107
108     open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
109     print TEST q{
110         BEGIN {
111             open(STDERR, ">&STDOUT")
112               or die "Can't dup STDOUT->STDERR: $!;";
113         }
114     };
115     print TEST "\n#line 1\n";  # So the line numbers don't get messed up.
116     print TEST $prog,"\n";
117     close TEST or die "Cannot close $tmpfile: $!";
118     my $results = runperl( switches => [$switch], stderr => 1, progfile => $tmpfile );
119     my $status = $?;
120     $results =~ s/\n+$//;
121     # allow expected output to be written as if $prog is on STDIN
122     $results =~ s/$::tempfile_regexp/-/g;
123     if ($^O eq 'VMS') {
124         # some tests will trigger VMS messages that won't be expected
125         $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
126
127         # pipes double these sometimes
128         $results =~ s/\n\n/\n/g;
129     }
130 # bison says 'parse error' instead of 'syntax error',
131 # various yaccs may or may not capitalize 'syntax'.
132     $results =~ s/^(syntax|parse) error/syntax error/mig;
133     # allow all tests to run when there are leaks
134     $results =~ s/Scalars leaked: \d+\n//g;
135
136     $expected =~ s/\n+$//;
137     my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
138     # any special options? (OPTIONS foo bar zap)
139     my $option_regex = 0;
140     my $option_random = 0;
141     if ($expected =~ s/^OPTIONS? (.+)\n//) {
142         foreach my $option (split(' ', $1)) {
143             if ($option eq 'regex') { # allow regular expressions
144                 $option_regex = 1;
145             }
146             elsif ($option eq 'random') { # all lines match, but in any order
147                 $option_random = 1;
148             }
149             else {
150                 die "$0: Unknown OPTION '$option'\n";
151             }
152         }
153     }
154     die "$0: can't have OPTION regex and random\n"
155         if $option_regex + $option_random > 1;
156     my $ok = 0;
157     if ($results =~ s/^SKIPPED\n//) {
158         print "$results\n" ;
159         $ok = 1;
160     }
161     elsif ($option_random) {
162         $ok = randomMatch($results, $expected);
163     }
164     elsif ($option_regex) {
165         $ok = $results =~ /^$expected/;
166     }
167     elsif ($prefix) {
168         $ok = $results =~ /^\Q$expected/;
169     }
170     else {
171         $ok = $results eq $expected;
172     }
173  
174     local $::TODO = $reason{todo};
175     print_err_line( $switch, $prog, $expected, $results, $::TODO ) unless $ok;
176
177     ok($ok);
178
179     foreach (@temps)
180         { unlink $_ if $_ }
181     foreach (@temp_path)
182         { rmtree $_ if -d $_ }
183 }
184
185 sub randomMatch
186 {
187     my $got = shift ;
188     my $expected = shift;
189
190     my @got = sort split "\n", $got ;
191     my @expected = sort split "\n", $expected ;
192
193    return "@got" eq "@expected";
194
195 }
196
197 sub print_err_line {
198     my($switch, $prog, $expected, $results, $todo) = @_;
199     my $err_line = "PROG: $switch\n$prog\n" .
200                    "EXPECTED:\n$expected\n" .
201                    "GOT:\n$results\n";
202     if ($todo) {
203         $err_line =~ s/^/# /mg;
204         print $err_line;  # Harness can't filter it out from STDERR.
205     }
206     else {
207         print STDERR $err_line;
208     }
209
210     return 1;
211 }
212
213 1;