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