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