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) { |
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 |
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 |
55 | |
56 | # Ensure that the message is properly escaped. |
ad20d923 |
57 | print STDOUT map { /^#/ ? "$_\n" : "# $_\n" } |
58 | map { split /\n/ } @mess if @mess; |
7d932aad |
59 | |
69026470 |
60 | $test++; |
1577bb16 |
61 | |
62 | return $pass; |
69026470 |
63 | } |
64 | |
65 | sub _where { |
66 | my @caller = caller(1); |
67 | return "at $caller[1] line $caller[2]"; |
68 | } |
69 | |
70 | sub ok { |
7d932aad |
71 | my ($pass, $name, @mess) = @_; |
72 | _ok($pass, _where(), $name, @mess); |
69026470 |
73 | } |
74 | |
b3c72391 |
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 |
85 | my $pass = $got eq $expected; |
86 | unless ($pass) { |
b3c72391 |
87 | unshift(@mess, "# got "._q($got)."\n", |
88 | "# expected "._q($expected)."\n"); |
69026470 |
89 | } |
7d932aad |
90 | _ok($pass, _where(), $name, @mess); |
69026470 |
91 | } |
92 | |
3e90d5a3 |
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 |
98 | "# but it is.\n"); |
99 | } |
100 | _ok($pass, _where(), $name, @mess); |
101 | } |
102 | |
69026470 |
103 | # Note: this isn't quite as fancy as Test::More::like(). |
104 | sub like { |
7d932aad |
105 | my ($got, $expected, $name, @mess) = @_; |
69026470 |
106 | my $pass; |
107 | if (ref $expected eq 'Regexp') { |
108 | $pass = $got =~ $expected; |
109 | unless ($pass) { |
7d932aad |
110 | unshift(@mess, "# got '$got'\n"); |
69026470 |
111 | } |
112 | } else { |
113 | $pass = $got =~ /$expected/; |
114 | unless ($pass) { |
7d932aad |
115 | unshift(@mess, "# got '$got'\n", |
116 | "# expected /$expected/\n"); |
69026470 |
117 | } |
118 | } |
7d932aad |
119 | _ok($pass, _where(), $name, @mess); |
69026470 |
120 | } |
121 | |
122 | sub pass { |
123 | _ok(1, '', @_); |
124 | } |
125 | |
126 | sub fail { |
127 | _ok(0, _where(), @_); |
128 | } |
129 | |
ad20d923 |
130 | sub curr_test { |
131 | return $test; |
132 | } |
133 | |
3e90d5a3 |
134 | sub next_test { |
135 | $test++ |
136 | } |
137 | |
69026470 |
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 |
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 |
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 |
174 | } |
175 | |
137352a2 |
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 |
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 |
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 |
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 |
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 |
214 | } |
215 | else { |
cb9c5e20 |
216 | $runperl .= ' "-I../lib"'; # doublequotes because of VMS |
137352a2 |
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 |
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 |
237 | $args{stdin} . q{)" | } . $runperl; |
238 | } |
239 | else { |
f93a5f07 |
240 | $runperl = qq{$^X -e 'print qq(} . |
137352a2 |
241 | $args{stdin} . q{)' | } . $runperl; |
242 | } |
243 | } |
244 | if (defined $args{args}) { |
cb9c5e20 |
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 |
254 | my $result = `$runperl`; |
255 | $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these |
256 | return $result; |
257 | } |
258 | |
8799135f |
259 | |
260 | sub BAILOUT { |
ad20d923 |
261 | print STDOUT "Bail out! @_\n"; |
8799135f |
262 | exit; |
263 | } |
264 | |
265 | |
b5fe401b |
266 | # A somewhat safer version of the sometimes wrong $^X. |
267 | BEGIN: { |
268 | eval { |
269 | require File::Spec; |
270 | require Config; |
271 | Config->import; |
272 | }; |
273 | warn "test.pl had problems loading other modules: $@" if $@; |
274 | } |
275 | |
276 | # We do this at compile time before the test might have chdir'd around |
277 | # and make sure its absolute in case they do later. |
278 | my $Perl = $^X; |
279 | $Perl = File::Spec->rel2abs(File::Spec->catfile(File::Spec->curdir(), $Perl)) |
280 | if $^X eq "perl$Config{_exe}"; |
281 | warn "Can't generate which_perl from $^X" unless -f $Perl; |
282 | |
283 | # For subcommands to use. |
284 | $ENV{PERLEXE} = $Perl; |
285 | |
286 | sub which_perl { |
287 | return $Perl; |
288 | } |
289 | |
69026470 |
290 | 1; |