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