Commit | Line | Data |
69026470 |
1 | # |
2 | # t/test.pl - most of Test::More functionality without the fuss |
3 | # |
4 | |
5 | my $test = 1; |
6 | my $planned; |
7 | |
7d932aad |
8 | $TODO = 0; |
b6345914 |
9 | $NO_ENDING = 0; |
7d932aad |
10 | |
69026470 |
11 | sub plan { |
12 | my $n; |
13 | if (@_ == 1) { |
14 | $n = shift; |
15 | } else { |
16 | my %plan = @_; |
17 | $n = $plan{tests}; |
18 | } |
ad20d923 |
19 | print STDOUT "1..$n\n"; |
69026470 |
20 | $planned = $n; |
21 | } |
22 | |
23 | END { |
24 | my $ran = $test - 1; |
b6345914 |
25 | if (!$NO_ENDING && defined $planned && $planned != $ran) { |
26 | print STDOUT "# Looks like you planned $planned tests but ran $ran.\n"; |
69026470 |
27 | } |
28 | } |
29 | |
30 | sub skip_all { |
31 | if (@_) { |
ad20d923 |
32 | print STDOUT "1..0 - @_\n"; |
69026470 |
33 | } else { |
ad20d923 |
34 | print STDOUT "1..0\n"; |
69026470 |
35 | } |
36 | exit(0); |
37 | } |
38 | |
39 | sub _ok { |
7d932aad |
40 | my ($pass, $where, $name, @mess) = @_; |
69026470 |
41 | # Do not try to microoptimize by factoring out the "not ". |
42 | # VMS will avenge. |
7d932aad |
43 | my $out; |
44 | if ($name) { |
b734d6c9 |
45 | # escape out '#' or it will interfere with '# skip' and such |
46 | $name =~ s/#/\\#/g; |
7d932aad |
47 | $out = $pass ? "ok $test - $name" : "not ok $test - $name"; |
69026470 |
48 | } else { |
7d932aad |
49 | $out = $pass ? "ok $test" : "not ok $test"; |
69026470 |
50 | } |
7d932aad |
51 | |
52 | $out .= " # TODO $TODO" if $TODO; |
ad20d923 |
53 | print STDOUT "$out\n"; |
7d932aad |
54 | |
69026470 |
55 | unless ($pass) { |
ad20d923 |
56 | print STDOUT "# Failed $where\n"; |
69026470 |
57 | } |
7d932aad |
58 | |
59 | # Ensure that the message is properly escaped. |
ad20d923 |
60 | print STDOUT map { /^#/ ? "$_\n" : "# $_\n" } |
61 | map { split /\n/ } @mess if @mess; |
7d932aad |
62 | |
69026470 |
63 | $test++; |
1577bb16 |
64 | |
65 | return $pass; |
69026470 |
66 | } |
67 | |
68 | sub _where { |
69 | my @caller = caller(1); |
70 | return "at $caller[1] line $caller[2]"; |
71 | } |
72 | |
73 | sub ok { |
7d932aad |
74 | my ($pass, $name, @mess) = @_; |
75 | _ok($pass, _where(), $name, @mess); |
69026470 |
76 | } |
77 | |
b3c72391 |
78 | sub _q { |
79 | my $x = shift; |
80 | return 'undef' unless defined $x; |
81 | my $q = $x; |
677fb045 |
82 | $q =~ s/\\/\\\\/; |
b3c72391 |
83 | $q =~ s/'/\\'/; |
84 | return "'$q'"; |
85 | } |
86 | |
677fb045 |
87 | sub _qq { |
88 | my $x = shift; |
89 | return defined $x ? '"' . display ($x) . '"' : 'undef'; |
90 | }; |
91 | |
92 | # keys are the codes \n etc map to, values are 2 char strings such as \n |
93 | my %backslash_escape; |
94 | foreach my $x (split //, 'nrtfa\\\'"') { |
95 | $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; |
96 | } |
97 | # A way to display scalars containing control characters and Unicode. |
98 | # Trying to avoid setting $_, or relying on local $_ to work. |
99 | sub display { |
100 | my @result; |
101 | foreach my $x (@_) { |
102 | if (defined $x and not ref $x) { |
103 | my $y = ''; |
104 | foreach my $c (unpack("U*", $x)) { |
105 | if ($c > 255) { |
106 | $y .= sprintf "\\x{%x}", $c; |
107 | } elsif ($backslash_escape{$c}) { |
108 | $y .= $backslash_escape{$c}; |
109 | } else { |
110 | my $z = chr $c; # Maybe we can get away with a literal... |
111 | $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; |
112 | $y .= $z; |
113 | } |
114 | } |
115 | $x = $y; |
116 | } |
117 | return $x unless wantarray; |
118 | push @result, $x; |
119 | } |
120 | return @result; |
121 | } |
122 | |
69026470 |
123 | sub is { |
7d932aad |
124 | my ($got, $expected, $name, @mess) = @_; |
69026470 |
125 | my $pass = $got eq $expected; |
126 | unless ($pass) { |
b3c72391 |
127 | unshift(@mess, "# got "._q($got)."\n", |
128 | "# expected "._q($expected)."\n"); |
69026470 |
129 | } |
7d932aad |
130 | _ok($pass, _where(), $name, @mess); |
69026470 |
131 | } |
132 | |
3e90d5a3 |
133 | sub isnt { |
134 | my ($got, $isnt, $name, @mess) = @_; |
135 | my $pass = $got ne $isnt; |
136 | unless( $pass ) { |
b3c72391 |
137 | unshift(@mess, "# it should not be "._q($got)."\n", |
3e90d5a3 |
138 | "# but it is.\n"); |
139 | } |
140 | _ok($pass, _where(), $name, @mess); |
141 | } |
142 | |
69026470 |
143 | # Note: this isn't quite as fancy as Test::More::like(). |
144 | sub like { |
7d932aad |
145 | my ($got, $expected, $name, @mess) = @_; |
69026470 |
146 | my $pass; |
147 | if (ref $expected eq 'Regexp') { |
148 | $pass = $got =~ $expected; |
149 | unless ($pass) { |
435e7af6 |
150 | unshift(@mess, "# got '$got'\n", |
151 | "# expected /$expected/\n"); |
69026470 |
152 | } |
153 | } else { |
154 | $pass = $got =~ /$expected/; |
155 | unless ($pass) { |
7d932aad |
156 | unshift(@mess, "# got '$got'\n", |
157 | "# expected /$expected/\n"); |
69026470 |
158 | } |
159 | } |
7d932aad |
160 | _ok($pass, _where(), $name, @mess); |
69026470 |
161 | } |
162 | |
163 | sub pass { |
164 | _ok(1, '', @_); |
165 | } |
166 | |
167 | sub fail { |
168 | _ok(0, _where(), @_); |
169 | } |
170 | |
ad20d923 |
171 | sub curr_test { |
172 | return $test; |
173 | } |
174 | |
3e90d5a3 |
175 | sub next_test { |
176 | $test++ |
177 | } |
178 | |
69026470 |
179 | # Note: can't pass multipart messages since we try to |
180 | # be compatible with Test::More::skip(). |
181 | sub skip { |
7d932aad |
182 | my $why = shift; |
982b7cb7 |
183 | my $n = @_ ? shift : 1; |
69026470 |
184 | for (1..$n) { |
ad20d923 |
185 | print STDOUT "ok $test # skip: $why\n"; |
e6c299c8 |
186 | $test++; |
69026470 |
187 | } |
188 | local $^W = 0; |
189 | last SKIP; |
190 | } |
191 | |
192 | sub eq_array { |
193 | my ($ra, $rb) = @_; |
194 | return 0 unless $#$ra == $#$rb; |
195 | for my $i (0..$#$ra) { |
196 | return 0 unless $ra->[$i] eq $rb->[$i]; |
197 | } |
198 | return 1; |
199 | } |
200 | |
677fb045 |
201 | sub eq_hash { |
202 | my ($orig, $suspect) = @_; |
203 | my $fail; |
204 | while (my ($key, $value) = each %$suspect) { |
205 | # Force a hash recompute if this perl's internals can cache the hash key. |
206 | $key = "" . $key; |
207 | if (exists $orig->{$key}) { |
208 | if ($orig->{$key} ne $value) { |
209 | print "# key ", _qq($key), " was ", _qq($orig->{$key}), |
210 | " now ", _qq($value), "\n"; |
211 | $fail = 1; |
212 | } |
213 | } else { |
214 | print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; |
215 | $fail = 1; |
216 | } |
217 | } |
218 | foreach (keys %$orig) { |
219 | # Force a hash recompute if this perl's internals can cache the hash key. |
220 | $_ = "" . $_; |
221 | next if (exists $suspect->{$_}); |
222 | print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; |
223 | $fail = 1; |
224 | } |
225 | !$fail; |
226 | } |
227 | |
69026470 |
228 | sub require_ok { |
229 | my ($require) = @_; |
230 | eval <<REQUIRE_OK; |
231 | require $require; |
232 | REQUIRE_OK |
1577bb16 |
233 | _ok(!$@, _where(), "require $require"); |
69026470 |
234 | } |
235 | |
236 | sub use_ok { |
237 | my ($use) = @_; |
238 | eval <<USE_OK; |
239 | use $use; |
240 | USE_OK |
1577bb16 |
241 | _ok(!$@, _where(), "use $use"); |
69026470 |
242 | } |
243 | |
137352a2 |
244 | # runperl - Runs a separate perl interpreter. |
245 | # Arguments : |
246 | # switches => [ command-line switches ] |
247 | # nolib => 1 # don't use -I../lib (included by default) |
248 | # prog => one-liner (avoid quotes) |
249 | # progfile => perl script |
250 | # stdin => string to feed the stdin |
251 | # stderr => redirect stderr to stdout |
252 | # args => [ command-line arguments to the perl program ] |
cb9c5e20 |
253 | # verbose => print the command line |
137352a2 |
254 | |
255 | my $is_mswin = $^O eq 'MSWin32'; |
256 | my $is_netware = $^O eq 'NetWare'; |
257 | my $is_macos = $^O eq 'MacOS'; |
258 | my $is_vms = $^O eq 'VMS'; |
259 | |
cb9c5e20 |
260 | sub _quote_args { |
261 | my ($runperl, $args) = @_; |
262 | |
263 | foreach (@$args) { |
264 | # In VMS protect with doublequotes because otherwise |
265 | # DCL will lowercase -- unless already doublequoted. |
266 | $_ = q(").$_.q(") if $is_vms && !/^\"/; |
267 | $$runperl .= ' ' . $_; |
268 | } |
269 | } |
270 | |
137352a2 |
271 | sub runperl { |
272 | my %args = @_; |
273 | my $runperl = $^X; |
f93a5f07 |
274 | if ($args{switches}) { |
cb9c5e20 |
275 | _quote_args(\$runperl, $args{switches}); |
137352a2 |
276 | } |
f93a5f07 |
277 | unless ($args{nolib}) { |
278 | if ($is_macos) { |
cb9c5e20 |
279 | $runperl .= ' -I::lib'; |
f93a5f07 |
280 | # Use UNIX style error messages instead of MPW style. |
cb9c5e20 |
281 | $runperl .= ' -MMac::err=unix' if $args{stderr}; |
137352a2 |
282 | } |
283 | else { |
cb9c5e20 |
284 | $runperl .= ' "-I../lib"'; # doublequotes because of VMS |
137352a2 |
285 | } |
286 | } |
287 | if (defined $args{prog}) { |
288 | if ($is_mswin || $is_netware || $is_vms) { |
289 | $runperl .= qq( -e ") . $args{prog} . qq("); |
290 | } |
291 | else { |
292 | $runperl .= qq( -e ') . $args{prog} . qq('); |
293 | } |
294 | } elsif (defined $args{progfile}) { |
295 | $runperl .= qq( "$args{progfile}"); |
296 | } |
297 | if (defined $args{stdin}) { |
5ae09a77 |
298 | # so we don't try to put literal newlines and crs onto the |
299 | # command line. |
300 | $args{stdin} =~ s/\n/\\n/g; |
301 | $args{stdin} =~ s/\r/\\r/g; |
302 | |
137352a2 |
303 | if ($is_mswin || $is_netware || $is_vms) { |
f93a5f07 |
304 | $runperl = qq{$^X -e "print qq(} . |
137352a2 |
305 | $args{stdin} . q{)" | } . $runperl; |
306 | } |
307 | else { |
f93a5f07 |
308 | $runperl = qq{$^X -e 'print qq(} . |
137352a2 |
309 | $args{stdin} . q{)' | } . $runperl; |
310 | } |
311 | } |
312 | if (defined $args{args}) { |
cb9c5e20 |
313 | _quote_args(\$runperl, $args{args}); |
314 | } |
315 | $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; |
316 | $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; |
317 | if ($args{verbose}) { |
318 | my $runperldisplay = $runperl; |
319 | $runperldisplay =~ s/\n/\n\#/g; |
ad20d923 |
320 | print STDOUT "# $runperldisplay\n"; |
137352a2 |
321 | } |
137352a2 |
322 | my $result = `$runperl`; |
323 | $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these |
324 | return $result; |
325 | } |
326 | |
8799135f |
327 | |
c4fbe247 |
328 | sub DIE { |
329 | print STDOUT "# @_\n"; |
330 | exit 1; |
8799135f |
331 | } |
332 | |
b5fe401b |
333 | # A somewhat safer version of the sometimes wrong $^X. |
17a740d5 |
334 | my $Perl; |
335 | sub which_perl { |
336 | unless (defined $Perl) { |
337 | $Perl = $^X; |
338 | |
339 | my $exe; |
340 | eval "require Config; Config->import"; |
85363d30 |
341 | if ($@) { |
17a740d5 |
342 | warn "test.pl had problems loading Config: $@"; |
343 | $exe = ''; |
85363d30 |
344 | } else { |
17a740d5 |
345 | $exe = $Config{_exe}; |
85363d30 |
346 | } |
da405c16 |
347 | $exe = '' unless defined $exe; |
17a740d5 |
348 | |
349 | # This doesn't absolutize the path: beware of future chdirs(). |
350 | # We could do File::Spec->abs2rel() but that does getcwd()s, |
351 | # which is a bit heavyweight to do here. |
352 | |
353 | if ($Perl =~ /^perl\Q$exe\E$/i) { |
8db06b02 |
354 | my $perl = "perl$exe"; |
17a740d5 |
355 | eval "require File::Spec"; |
356 | if ($@) { |
357 | warn "test.pl had problems loading File::Spec: $@"; |
8db06b02 |
358 | $Perl = "./$perl"; |
17a740d5 |
359 | } else { |
8db06b02 |
360 | $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); |
17a740d5 |
361 | } |
362 | } |
363 | |
c880be78 |
364 | # Its like this. stat on Cygwin treats 'perl' to mean 'perl.exe' |
365 | # but open does not. This can get confusing, so to be safe we |
366 | # always put the .exe on the end on Cygwin. |
367 | $Perl .= $exe if $^O eq 'cygwin' && $Perl !~ /\Q$exe\E$/; |
368 | |
8db06b02 |
369 | warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; |
17a740d5 |
370 | |
371 | # For subcommands to use. |
372 | $ENV{PERLEXE} = $Perl; |
85363d30 |
373 | } |
17a740d5 |
374 | return $Perl; |
b5fe401b |
375 | } |
376 | |
435e7af6 |
377 | sub unlink_all { |
378 | foreach my $file (@_) { |
379 | 1 while unlink $file; |
380 | print "# Couldn't unlink '$file': $!\n" if -f $file; |
381 | } |
382 | } |
69026470 |
383 | 1; |