This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Declaring mostly TODO
[perl5.git] / t / test.pl
CommitLineData
69026470
JH
1#
2# t/test.pl - most of Test::More functionality without the fuss
3#
4
5my $test = 1;
6my $planned;
7
7d932aad
MS
8$TODO = 0;
9
69026470
JH
10sub plan {
11 my $n;
12 if (@_ == 1) {
13 $n = shift;
14 } else {
15 my %plan = @_;
16 $n = $plan{tests};
17 }
ad20d923 18 print STDOUT "1..$n\n";
69026470
JH
19 $planned = $n;
20}
21
22END {
23 my $ran = $test - 1;
24 if (defined $planned && $planned != $ran) {
ad20d923 25 print STDOUT "# Looks like you planned $planned tests but ran $ran.\n";
69026470
JH
26 }
27}
28
29sub skip_all {
30 if (@_) {
ad20d923 31 print STDOUT "1..0 - @_\n";
69026470 32 } else {
ad20d923 33 print STDOUT "1..0\n";
69026470
JH
34 }
35 exit(0);
36}
37
38sub _ok {
7d932aad 39 my ($pass, $where, $name, @mess) = @_;
69026470
JH
40 # Do not try to microoptimize by factoring out the "not ".
41 # VMS will avenge.
7d932aad
MS
42 my $out;
43 if ($name) {
b734d6c9
MS
44 # escape out '#' or it will interfere with '# skip' and such
45 $name =~ s/#/\\#/g;
7d932aad 46 $out = $pass ? "ok $test - $name" : "not ok $test - $name";
69026470 47 } else {
7d932aad 48 $out = $pass ? "ok $test" : "not ok $test";
69026470 49 }
7d932aad
MS
50
51 $out .= " # TODO $TODO" if $TODO;
ad20d923 52 print STDOUT "$out\n";
7d932aad 53
69026470 54 unless ($pass) {
ad20d923 55 print STDOUT "# Failed $where\n";
69026470 56 }
7d932aad
MS
57
58 # Ensure that the message is properly escaped.
ad20d923
MS
59 print STDOUT map { /^#/ ? "$_\n" : "# $_\n" }
60 map { split /\n/ } @mess if @mess;
7d932aad 61
69026470 62 $test++;
1577bb16
MS
63
64 return $pass;
69026470
JH
65}
66
67sub _where {
68 my @caller = caller(1);
69 return "at $caller[1] line $caller[2]";
70}
71
72sub ok {
7d932aad
MS
73 my ($pass, $name, @mess) = @_;
74 _ok($pass, _where(), $name, @mess);
69026470
JH
75}
76
b3c72391
JH
77sub _q {
78 my $x = shift;
79 return 'undef' unless defined $x;
80 my $q = $x;
81 $q =~ s/'/\\'/;
82 return "'$q'";
83}
84
69026470 85sub is {
7d932aad 86 my ($got, $expected, $name, @mess) = @_;
69026470
JH
87 my $pass = $got eq $expected;
88 unless ($pass) {
b3c72391
JH
89 unshift(@mess, "# got "._q($got)."\n",
90 "# expected "._q($expected)."\n");
69026470 91 }
7d932aad 92 _ok($pass, _where(), $name, @mess);
69026470
JH
93}
94
3e90d5a3
MS
95sub isnt {
96 my ($got, $isnt, $name, @mess) = @_;
97 my $pass = $got ne $isnt;
98 unless( $pass ) {
b3c72391 99 unshift(@mess, "# it should not be "._q($got)."\n",
3e90d5a3
MS
100 "# but it is.\n");
101 }
102 _ok($pass, _where(), $name, @mess);
103}
104
69026470
JH
105# Note: this isn't quite as fancy as Test::More::like().
106sub like {
7d932aad 107 my ($got, $expected, $name, @mess) = @_;
69026470
JH
108 my $pass;
109 if (ref $expected eq 'Regexp') {
110 $pass = $got =~ $expected;
111 unless ($pass) {
7d932aad 112 unshift(@mess, "# got '$got'\n");
69026470
JH
113 }
114 } else {
115 $pass = $got =~ /$expected/;
116 unless ($pass) {
7d932aad
MS
117 unshift(@mess, "# got '$got'\n",
118 "# expected /$expected/\n");
69026470
JH
119 }
120 }
7d932aad 121 _ok($pass, _where(), $name, @mess);
69026470
JH
122}
123
124sub pass {
125 _ok(1, '', @_);
126}
127
128sub fail {
129 _ok(0, _where(), @_);
130}
131
ad20d923
MS
132sub curr_test {
133 return $test;
134}
135
3e90d5a3
MS
136sub next_test {
137 $test++
138}
139
69026470
JH
140# Note: can't pass multipart messages since we try to
141# be compatible with Test::More::skip().
142sub skip {
7d932aad 143 my $why = shift;
982b7cb7 144 my $n = @_ ? shift : 1;
69026470 145 for (1..$n) {
ad20d923 146 print STDOUT "ok $test # skip: $why\n";
e6c299c8 147 $test++;
69026470
JH
148 }
149 local $^W = 0;
150 last SKIP;
151}
152
153sub 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
162sub require_ok {
163 my ($require) = @_;
164 eval <<REQUIRE_OK;
165require $require;
166REQUIRE_OK
1577bb16 167 _ok(!$@, _where(), "require $require");
69026470
JH
168}
169
170sub use_ok {
171 my ($use) = @_;
172 eval <<USE_OK;
173use $use;
174USE_OK
1577bb16 175 _ok(!$@, _where(), "use $use");
69026470
JH
176}
177
137352a2
RGS
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 ]
cb9c5e20 187# verbose => print the command line
137352a2
RGS
188
189my $is_mswin = $^O eq 'MSWin32';
190my $is_netware = $^O eq 'NetWare';
191my $is_macos = $^O eq 'MacOS';
192my $is_vms = $^O eq 'VMS';
193
cb9c5e20
JH
194sub _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
137352a2
RGS
205sub runperl {
206 my %args = @_;
207 my $runperl = $^X;
f93a5f07 208 if ($args{switches}) {
cb9c5e20 209 _quote_args(\$runperl, $args{switches});
137352a2 210 }
f93a5f07
JH
211 unless ($args{nolib}) {
212 if ($is_macos) {
cb9c5e20 213 $runperl .= ' -I::lib';
f93a5f07 214 # Use UNIX style error messages instead of MPW style.
cb9c5e20 215 $runperl .= ' -MMac::err=unix' if $args{stderr};
137352a2
RGS
216 }
217 else {
cb9c5e20 218 $runperl .= ' "-I../lib"'; # doublequotes because of VMS
137352a2
RGS
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}) {
5ae09a77
MS
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
137352a2 237 if ($is_mswin || $is_netware || $is_vms) {
f93a5f07 238 $runperl = qq{$^X -e "print qq(} .
137352a2
RGS
239 $args{stdin} . q{)" | } . $runperl;
240 }
241 else {
f93a5f07 242 $runperl = qq{$^X -e 'print qq(} .
137352a2
RGS
243 $args{stdin} . q{)' | } . $runperl;
244 }
245 }
246 if (defined $args{args}) {
cb9c5e20
JH
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;
ad20d923 254 print STDOUT "# $runperldisplay\n";
137352a2 255 }
137352a2
RGS
256 my $result = `$runperl`;
257 $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
258 return $result;
259}
260
8799135f
MS
261
262sub BAILOUT {
ad20d923 263 print STDOUT "Bail out! @_\n";
8799135f
MS
264 exit;
265}
266
267
6cb8f8aa
JH
268# A way to display scalars containing control characters and Unicode.
269sub display {
c3ded147 270 map { join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_;
6cb8f8aa
JH
271}
272
273
b5fe401b 274# A somewhat safer version of the sometimes wrong $^X.
17a740d5
JH
275my $Perl;
276sub which_perl {
277 unless (defined $Perl) {
278 $Perl = $^X;
279
280 my $exe;
281 eval "require Config; Config->import";
85363d30 282 if ($@) {
17a740d5
JH
283 warn "test.pl had problems loading Config: $@";
284 $exe = '';
85363d30 285 } else {
17a740d5 286 $exe = $Config{_exe};
85363d30 287 }
17a740d5
JH
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) {
8db06b02 294 my $perl = "perl$exe";
17a740d5
JH
295 eval "require File::Spec";
296 if ($@) {
297 warn "test.pl had problems loading File::Spec: $@";
8db06b02 298 $Perl = "./$perl";
17a740d5 299 } else {
8db06b02 300 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
17a740d5
JH
301 }
302 }
303
8db06b02 304 warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
17a740d5
JH
305
306 # For subcommands to use.
307 $ENV{PERLEXE} = $Perl;
85363d30 308 }
17a740d5 309 return $Perl;
b5fe401b
MS
310}
311
69026470 3121;