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