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