This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[perl5.git] / t / test.pl
1 #
2 # t/test.pl - most of Test::More functionality without the fuss
3 #
4
5 my $test = 1;
6 my $planned;
7
8 $TODO = 0;
9
10 sub plan {
11     my $n;
12     if (@_ == 1) {
13         $n = shift;
14     } else {
15         my %plan = @_;
16         $n = $plan{tests}; 
17     }
18     print STDOUT "1..$n\n";
19     $planned = $n;
20 }
21
22 END {
23     my $ran = $test - 1;
24     if (defined $planned && $planned != $ran) {
25         print STDOUT "# Looks like you planned $planned tests but ran $ran.\n";
26     }
27 }
28
29 sub skip_all {
30     if (@_) {
31         print STDOUT "1..0 - @_\n";
32     } else {
33         print STDOUT "1..0\n";
34     }
35     exit(0);
36 }
37
38 sub _ok {
39     my ($pass, $where, $name, @mess) = @_;
40     # Do not try to microoptimize by factoring out the "not ".
41     # VMS will avenge.
42     my $out;
43     if ($name) {
44         # escape out '#' or it will interfere with '# skip' and such
45         $name =~ s/#/\\#/g;
46         $out = $pass ? "ok $test - $name" : "not ok $test - $name";
47     } else {
48         $out = $pass ? "ok $test" : "not ok $test";
49     }
50
51     $out .= " # TODO $TODO" if $TODO;
52     print STDOUT "$out\n";
53
54     unless ($pass) {
55         print STDOUT "# Failed $where\n";
56     }
57
58     # Ensure that the message is properly escaped.
59     print STDOUT map { /^#/ ? "$_\n" : "# $_\n" } 
60                  map { split /\n/ } @mess if @mess;
61
62     $test++;
63
64     return $pass;
65 }
66
67 sub _where {
68     my @caller = caller(1);
69     return "at $caller[1] line $caller[2]";
70 }
71
72 sub ok {
73     my ($pass, $name, @mess) = @_;
74     _ok($pass, _where(), $name, @mess);
75 }
76
77 sub _q {
78     my $x = shift;
79     return 'undef' unless defined $x;
80     my $q = $x;
81     $q =~ s/'/\\'/;
82     return "'$q'";
83 }
84
85 sub is {
86     my ($got, $expected, $name, @mess) = @_;
87     my $pass = $got eq $expected;
88     unless ($pass) {
89         unshift(@mess, "#      got "._q($got)."\n",
90                        "# expected "._q($expected)."\n");
91     }
92     _ok($pass, _where(), $name, @mess);
93 }
94
95 sub isnt {
96     my ($got, $isnt, $name, @mess) = @_;
97     my $pass = $got ne $isnt;
98     unless( $pass ) {
99         unshift(@mess, "# it should not be "._q($got)."\n",
100                        "# but it is.\n");
101     }
102     _ok($pass, _where(), $name, @mess);
103 }
104
105 # Note: this isn't quite as fancy as Test::More::like().
106 sub like {
107     my ($got, $expected, $name, @mess) = @_;
108     my $pass;
109     if (ref $expected eq 'Regexp') {
110         $pass = $got =~ $expected;
111         unless ($pass) {
112             unshift(@mess, "#      got '$got'\n");
113         }
114     } else {
115         $pass = $got =~ /$expected/;
116         unless ($pass) {
117             unshift(@mess, "#      got '$got'\n",
118                            "# expected /$expected/\n");
119         }
120     }
121     _ok($pass, _where(), $name, @mess);
122 }
123
124 sub pass {
125     _ok(1, '', @_);
126 }
127
128 sub fail {
129     _ok(0, _where(), @_);
130 }
131
132 sub curr_test {
133     return $test;
134 }
135
136 sub next_test {
137     $test++
138 }
139
140 # Note: can't pass multipart messages since we try to
141 # be compatible with Test::More::skip().
142 sub skip {
143     my $why = shift;
144     my $n    = @_ ? shift : 1;
145     for (1..$n) {
146         print STDOUT "ok $test # skip: $why\n";
147         $test++;
148     }
149     local $^W = 0;
150     last SKIP;
151 }
152
153 sub eq_array {
154     my ($ra, $rb) = @_;
155     return 0 unless $#$ra == $#$rb;
156     for my $i (0..$#$ra) {
157         return 0 unless $ra->[$i] eq $rb->[$i];
158     }
159     return 1;
160 }
161
162 sub require_ok {
163     my ($require) = @_;
164     eval <<REQUIRE_OK;
165 require $require;
166 REQUIRE_OK
167     _ok(!$@, _where(), "require $require");
168 }
169
170 sub use_ok {
171     my ($use) = @_;
172     eval <<USE_OK;
173 use $use;
174 USE_OK
175     _ok(!$@, _where(), "use $use");
176 }
177
178 # runperl - Runs a separate perl interpreter.
179 # Arguments :
180 #   switches => [ command-line switches ]
181 #   nolib    => 1 # don't use -I../lib (included by default)
182 #   prog     => one-liner (avoid quotes)
183 #   progfile => perl script
184 #   stdin    => string to feed the stdin
185 #   stderr   => redirect stderr to stdout
186 #   args     => [ command-line arguments to the perl program ]
187 #   verbose  => print the command line
188
189 my $is_mswin    = $^O eq 'MSWin32';
190 my $is_netware  = $^O eq 'NetWare';
191 my $is_macos    = $^O eq 'MacOS';
192 my $is_vms      = $^O eq 'VMS';
193
194 sub _quote_args {
195     my ($runperl, $args) = @_;
196
197     foreach (@$args) {
198         # In VMS protect with doublequotes because otherwise
199         # DCL will lowercase -- unless already doublequoted.
200         $_ = q(").$_.q(") if $is_vms && !/^\"/;
201         $$runperl .= ' ' . $_;
202     }
203 }
204
205 sub runperl {
206     my %args = @_;
207     my $runperl = $^X;
208     if ($args{switches}) {
209         _quote_args(\$runperl, $args{switches});
210     }
211     unless ($args{nolib}) {
212         if ($is_macos) {
213             $runperl .= ' -I::lib';
214             # Use UNIX style error messages instead of MPW style.
215             $runperl .= ' -MMac::err=unix' if $args{stderr};
216         }
217         else {
218             $runperl .= ' "-I../lib"'; # doublequotes because of VMS
219         }
220     }
221     if (defined $args{prog}) {
222         if ($is_mswin || $is_netware || $is_vms) {
223             $runperl .= qq( -e ") . $args{prog} . qq(");
224         }
225         else {
226             $runperl .= qq( -e ') . $args{prog} . qq(');
227         }
228     } elsif (defined $args{progfile}) {
229         $runperl .= qq( "$args{progfile}");
230     }
231     if (defined $args{stdin}) {
232         # so we don't try to put literal newlines and crs onto the
233         # command line.
234         $args{stdin} =~ s/\n/\\n/g;
235         $args{stdin} =~ s/\r/\\r/g;
236
237         if ($is_mswin || $is_netware || $is_vms) {
238             $runperl = qq{$^X -e "print qq(} .
239                 $args{stdin} . q{)" | } . $runperl;
240         }
241         else {
242             $runperl = qq{$^X -e 'print qq(} .
243                 $args{stdin} . q{)' | } . $runperl;
244         }
245     }
246     if (defined $args{args}) {
247         _quote_args(\$runperl, $args{args});
248     }
249     $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
250     $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
251     if ($args{verbose}) {
252         my $runperldisplay = $runperl;
253         $runperldisplay =~ s/\n/\n\#/g;
254         print STDOUT "# $runperldisplay\n";
255     }
256     my $result = `$runperl`;
257     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
258     return $result;
259 }
260
261
262 sub BAILOUT {
263     print STDOUT "Bail out! @_\n";
264     exit;
265 }
266
267
268 # A way to display scalars containing control characters and Unicode.
269 sub display {
270     map { join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_;
271 }
272
273
274 # A somewhat safer version of the sometimes wrong $^X.
275 my $Perl;
276 sub which_perl {
277     unless (defined $Perl) {
278         $Perl = $^X;
279         
280         my $exe;
281         eval "require Config; Config->import";
282         if ($@) {
283             warn "test.pl had problems loading Config: $@";
284             $exe = '';
285         } else {
286             $exe = $Config{_exe};
287         }
288         
289         # This doesn't absolutize the path: beware of future chdirs().
290         # We could do File::Spec->abs2rel() but that does getcwd()s,
291         # which is a bit heavyweight to do here.
292         
293         if ($Perl =~ /^perl\Q$exe\E$/i) {
294             my $perl = "perl$exe";
295             eval "require File::Spec";
296             if ($@) {
297                 warn "test.pl had problems loading File::Spec: $@";
298                 $Perl = "./$perl";
299             } else {
300                 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
301             }
302         }
303         
304         warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
305         
306         # For subcommands to use.
307         $ENV{PERLEXE} = $Perl;
308     }
309     return $Perl;
310 }
311
312 1;