This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactor the SKIP parser to also handle TODOs. TODO 3 tests that were wrongly
[perl5.git] / t / lib / common.pl
CommitLineData
25ae1130
RGS
1# This code is used by lib/warnings.t and lib/feature.t
2
3BEGIN {
25ae1130
RGS
4 require './test.pl';
5}
6
afb1190b 7use Config;
25ae1130
RGS
8use File::Path;
9use File::Spec::Functions;
10
11use strict;
742dc32d 12use warnings;
25ae1130
RGS
13our $pragma_name;
14
15$| = 1;
16
afb1190b 17my $Is_MacOS = $^O eq 'MacOS';
25ae1130 18my $tmpfile = "tmp0000";
ee03edd3
NC
191 while -e ++$tmpfile;
20END { 1 while unlink $tmpfile }
25ae1130
RGS
21
22my @prgs = () ;
23my @w_files = () ;
24
25if (@ARGV)
26 { print "ARGV = [@ARGV]\n" ;
f4ae0982 27 if ($Is_MacOS) {
25ae1130
RGS
28 @w_files = map { s#^#:lib:$pragma_name:#; $_ } @ARGV
29 } else {
30 @w_files = map { s#^#./lib/$pragma_name/#; $_ } @ARGV
31 }
32 }
33else
34 { @w_files = sort glob(catfile(curdir(), "lib", $pragma_name, "*")) }
35
36my $files = 0;
37foreach 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
58undef $/;
59
60plan tests => (scalar(@prgs)-$files);
61
25ae1130
RGS
62for (@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);
a983b08d 75
25ae1130 76 my ($todo, $todo_reason);
8e5f6690
NC
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
742dc32d 80 if ($todo_reason && $todo_reason =~ s/^\?//) {
8e5f6690
NC
81 my $temp = eval $todo_reason;
82 if ($@) {
83 die "# In TODO code reason:\n# $todo_reason\n$@";
84 }
85 $todo_reason = $temp;
86 }
25ae1130
RGS
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
f4ae0982 110 if ($Is_MacOS) {
25ae1130
RGS
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
f4ae0982 144 if ($Is_MacOS) {
25ae1130
RGS
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;
7702f076
RGS
169 my $ok = 0;
170 if ($results =~ s/^SKIPPED\n//) {
25ae1130 171 print "$results\n" ;
7702f076 172 $ok = 1;
25ae1130 173 }
afb1190b 174 elsif ($option_random) {
25ae1130
RGS
175 $ok = randomMatch($results, $expected);
176 }
7702f076
RGS
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;
25ae1130 185 }
7702f076
RGS
186
187 print_err_line( $switch, $prog, $expected, $results, $todo ) unless $ok;
25ae1130
RGS
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
198sub 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
afb1190b
RGS
210sub 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
25ae1130 2261;