This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tweak multi-arg open error messages
[perl5.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
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     join("", map { $_ > 255 ? sprintf("\\x{%x}", $_) : chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\%03o", $_) : chr($_) } unpack("U*", $_[0]));
269 }
270
271
272 # A somewhat safer version of the sometimes wrong $^X.
273 BEGIN: {
274     eval {
275         require File::Spec;
276         require Config;
277         Config->import;
278     };
279     warn "test.pl had problems loading other modules: $@" if $@;
280 }
281
282 # We do this at compile time before the test might have chdir'd around
283 # and make sure its absolute in case they do later.
284 my $Perl = $^X;
285 $Perl = File::Spec->rel2abs(File::Spec->catfile(File::Spec->curdir(), $Perl))
286                if $^X eq "perl$Config{_exe}";
287 warn "Can't generate which_perl from $^X" unless -f $Perl;
288
289 # For subcommands to use.
290 $ENV{PERLEXE} = $Perl;
291
292 sub which_perl {
293     return $Perl;
294 }
295
296 1;