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; |
9 | |
69026470 |
10 | sub 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 |
19 | $planned = $n; |
20 | } |
21 | |
22 | END { |
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 |
26 | } |
27 | } |
28 | |
29 | sub skip_all { |
30 | if (@_) { |
ad20d923 |
31 | print STDOUT "1..0 - @_\n"; |
69026470 |
32 | } else { |
ad20d923 |
33 | print STDOUT "1..0\n"; |
69026470 |
34 | } |
35 | exit(0); |
36 | } |
37 | |
38 | sub _ok { |
7d932aad |
39 | my ($pass, $where, $name, @mess) = @_; |
69026470 |
40 | # Do not try to microoptimize by factoring out the "not ". |
41 | # VMS will avenge. |
7d932aad |
42 | my $out; |
43 | if ($name) { |
b734d6c9 |
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 |
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 |
57 | |
58 | # Ensure that the message is properly escaped. |
ad20d923 |
59 | print STDOUT map { /^#/ ? "$_\n" : "# $_\n" } |
60 | map { split /\n/ } @mess if @mess; |
7d932aad |
61 | |
69026470 |
62 | $test++; |
1577bb16 |
63 | |
64 | return $pass; |
69026470 |
65 | } |
66 | |
67 | sub _where { |
68 | my @caller = caller(1); |
69 | return "at $caller[1] line $caller[2]"; |
70 | } |
71 | |
72 | sub ok { |
7d932aad |
73 | my ($pass, $name, @mess) = @_; |
74 | _ok($pass, _where(), $name, @mess); |
69026470 |
75 | } |
76 | |
b3c72391 |
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 | |
69026470 |
85 | sub is { |
7d932aad |
86 | my ($got, $expected, $name, @mess) = @_; |
69026470 |
87 | my $pass = $got eq $expected; |
88 | unless ($pass) { |
b3c72391 |
89 | unshift(@mess, "# got "._q($got)."\n", |
90 | "# expected "._q($expected)."\n"); |
69026470 |
91 | } |
7d932aad |
92 | _ok($pass, _where(), $name, @mess); |
69026470 |
93 | } |
94 | |
3e90d5a3 |
95 | sub 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 |
100 | "# but it is.\n"); |
101 | } |
102 | _ok($pass, _where(), $name, @mess); |
103 | } |
104 | |
69026470 |
105 | # Note: this isn't quite as fancy as Test::More::like(). |
106 | sub like { |
7d932aad |
107 | my ($got, $expected, $name, @mess) = @_; |
69026470 |
108 | my $pass; |
109 | if (ref $expected eq 'Regexp') { |
110 | $pass = $got =~ $expected; |
111 | unless ($pass) { |
7d932aad |
112 | unshift(@mess, "# got '$got'\n"); |
69026470 |
113 | } |
114 | } else { |
115 | $pass = $got =~ /$expected/; |
116 | unless ($pass) { |
7d932aad |
117 | unshift(@mess, "# got '$got'\n", |
118 | "# expected /$expected/\n"); |
69026470 |
119 | } |
120 | } |
7d932aad |
121 | _ok($pass, _where(), $name, @mess); |
69026470 |
122 | } |
123 | |
124 | sub pass { |
125 | _ok(1, '', @_); |
126 | } |
127 | |
128 | sub fail { |
129 | _ok(0, _where(), @_); |
130 | } |
131 | |
ad20d923 |
132 | sub curr_test { |
133 | return $test; |
134 | } |
135 | |
3e90d5a3 |
136 | sub next_test { |
137 | $test++ |
138 | } |
139 | |
69026470 |
140 | # Note: can't pass multipart messages since we try to |
141 | # be compatible with Test::More::skip(). |
142 | sub 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 |
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 |
1577bb16 |
167 | _ok(!$@, _where(), "require $require"); |
69026470 |
168 | } |
169 | |
170 | sub use_ok { |
171 | my ($use) = @_; |
172 | eval <<USE_OK; |
173 | use $use; |
174 | USE_OK |
1577bb16 |
175 | _ok(!$@, _where(), "use $use"); |
69026470 |
176 | } |
177 | |
137352a2 |
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 |
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 | |
cb9c5e20 |
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 | |
137352a2 |
205 | sub runperl { |
206 | my %args = @_; |
207 | my $runperl = $^X; |
f93a5f07 |
208 | if ($args{switches}) { |
cb9c5e20 |
209 | _quote_args(\$runperl, $args{switches}); |
137352a2 |
210 | } |
f93a5f07 |
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 |
216 | } |
217 | else { |
cb9c5e20 |
218 | $runperl .= ' "-I../lib"'; # doublequotes because of VMS |
137352a2 |
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 |
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 |
239 | $args{stdin} . q{)" | } . $runperl; |
240 | } |
241 | else { |
f93a5f07 |
242 | $runperl = qq{$^X -e 'print qq(} . |
137352a2 |
243 | $args{stdin} . q{)' | } . $runperl; |
244 | } |
245 | } |
246 | if (defined $args{args}) { |
cb9c5e20 |
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 |
256 | my $result = `$runperl`; |
257 | $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these |
258 | return $result; |
259 | } |
260 | |
8799135f |
261 | |
262 | sub BAILOUT { |
ad20d923 |
263 | print STDOUT "Bail out! @_\n"; |
8799135f |
264 | exit; |
265 | } |
266 | |
267 | |
6cb8f8aa |
268 | # A way to display scalars containing control characters and Unicode. |
269 | sub display { |
c3ded147 |
270 | map { join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_)) } @_; |
6cb8f8aa |
271 | } |
272 | |
273 | |
b5fe401b |
274 | # A somewhat safer version of the sometimes wrong $^X. |
17a740d5 |
275 | my $Perl; |
276 | sub which_perl { |
277 | unless (defined $Perl) { |
278 | $Perl = $^X; |
279 | |
280 | my $exe; |
281 | eval "require Config; Config->import"; |
85363d30 |
282 | if ($@) { |
17a740d5 |
283 | warn "test.pl had problems loading Config: $@"; |
284 | $exe = ''; |
85363d30 |
285 | } else { |
17a740d5 |
286 | $exe = $Config{_exe}; |
85363d30 |
287 | } |
17a740d5 |
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 |
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 |
301 | } |
302 | } |
303 | |
8db06b02 |
304 | warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; |
17a740d5 |
305 | |
306 | # For subcommands to use. |
307 | $ENV{PERLEXE} = $Perl; |
85363d30 |
308 | } |
17a740d5 |
309 | return $Perl; |
b5fe401b |
310 | } |
311 | |
69026470 |
312 | 1; |