This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In ReTest.pl, provide is(), isnt(), like() and unlike(), equivalent to test.pl
[perl5.git] / t / re / ReTest.pl
1 #!./perl
2 #
3 # This is the test subs used for regex testing. 
4 # This used to be part of re/pat.t
5 use warnings;
6 use strict;
7 use 5.010;
8 use base qw/Exporter/;
9 use Carp;
10 use vars qw(
11     $EXPECTED_TESTS 
12     $TODO
13     $Message
14     $BugId
15     $running_as_thread
16     $IS_ASCII
17     $IS_EBCDIC
18     $ordA
19 );
20
21 $| = 1;
22
23 $Message ||= "Noname test";
24
25 our $ordA = ord ('A');  # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
26 # This defined the platform.
27 our $IS_ASCII  = $ordA ==  65;
28 our $IS_EBCDIC = $ordA == 193;
29
30 use vars '%Config';
31 eval 'use Config';          #  Defaults assumed if this fails
32
33 my $test = 0;
34 my $done_plan;
35 sub plan {
36     my (undef,$tests)= @_;
37     if (defined $tests) {
38         die "Number of tests already defined! ($EXPECTED_TESTS)"
39             if $EXPECTED_TESTS;
40         $EXPECTED_TESTS= $tests;
41     }
42     if ($EXPECTED_TESTS) {
43         print "1..$EXPECTED_TESTS\n" if !$done_plan++;
44     } else {
45         print "Number of tests not declared!";
46     }
47 }
48
49 sub pretty {
50     my ($mess) = @_;
51     $mess =~ s/\n/\\n/g;
52     $mess =~ s/\r/\\r/g;
53     $mess =~ s/\t/\\t/g;
54     $mess =~ s/([\00-\37\177])/sprintf '\%03o', ord $1/eg;
55     $mess =~ s/#/\\#/g;
56     $mess;
57 }
58
59 sub safe_globals {
60     defined($_) and s/#/\\#/g for $BugId, $TODO;
61 }
62
63 sub _ok {
64     my ($ok, $mess, $error) = @_;
65     plan();
66     safe_globals();
67     $mess    = pretty ($mess // $Message);
68     $mess   .= "; Bug $BugId"     if defined $BugId;
69     $mess   .= " # TODO $TODO"     if defined $TODO;
70
71     my $line_nr = (caller(1)) [2];
72
73     printf "%sok %d - %s\n",
74               ($ok ? "" : "not "),
75               ++ $test,
76               "$mess\tLine $line_nr";
77
78     unless ($ok) {
79         print "# Failed test at line $line_nr\n" unless defined $TODO;
80         if ($error) {
81             no warnings 'utf8';
82             chomp $error;
83             $error = join "\n#", map {pretty $_} split /\n\h*#/ => $error;
84             $error = "# $error" unless $error =~ /^\h*#/;
85             print $error, "\n";
86         }
87     }
88
89     return $ok;
90 }
91
92 # Force scalar context on the pattern match
93 sub  ok ($;$$) {_ok  $_ [0], $_ [1], $_ [2]}
94 sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]}
95
96
97 sub skip {
98     my $why = shift;
99     safe_globals();
100     $why =~ s/\n.*//s;
101     $why .= "; Bug $BugId" if defined $BugId;
102     my $ok;
103     if (defined $TODO) {
104         $why = "TODO & SKIP $why $TODO";
105         $ok = "not ok";
106     } else {
107         $why = "SKIP $why";
108         $ok = "ok";
109     }
110
111     my $n = shift // 1;
112     my $line_nr = (caller(0)) [2];
113     for (1 .. $n) {
114         ++ $test;
115         print "$ok $test # $why\tLine $line_nr\n";
116     }
117     no warnings "exiting";
118     last SKIP;
119 }
120
121 sub iseq ($$;$) { 
122     my ($got, $expected, $name) = @_;
123
124     my $pass;
125     if(!defined $got || !defined $expected) {
126         # undef only matches undef
127         $pass = !defined $got && !defined $expected;
128     }
129     else {
130         $pass = $got eq $expected;
131     }
132
133     $_ = defined ($_) ? "'$_'" : "undef" for $got, $expected;
134
135     my $error = "# expected: $expected\n" .
136                 "#   result: $got";
137
138     _ok $pass, $name, $error;
139 }   
140
141 sub isneq ($$;$) { 
142     my ($got, $isnt, $name) = @_;
143
144     my $pass;
145     if(!defined $got || !defined $isnt) {
146         # undef only matches undef
147         $pass = defined $got || defined $isnt;
148     }
149     else {
150         $pass = $got ne $isnt;
151     }
152
153     $got = defined $got ? "'$got'" : "undef";
154     my $error = "# results are equal ($got)";
155
156     _ok $pass, $name, $error;
157 }   
158
159 *is = \&iseq;
160 *isnt = \&isneq;
161
162 sub like ($$$) {
163     my (undef, $expected, $name) = @_;
164     my ($pass, $error);
165     $pass = $_[0] =~ /$expected/;
166     unless ($pass) {
167         $error = "#      got '$_[0]'\n# expected /$expected/";
168     }
169     _ok($pass, $name, $error);
170 }
171
172 sub unlike ($$$) {
173     my (undef, $expected, $name) = @_;
174     my ($pass, $error);
175     $pass = $_[0] !~ /$expected/;
176     unless ($pass) {
177         $error = "#      got '$_[0]'\n# expected !~ /$expected/";
178     }
179     _ok($pass, $name, $error);
180 }
181
182 sub eval_ok ($;$) {
183     my ($code, $name) = @_;
184     local $@;
185     if (ref $code) {
186         _ok eval {&$code} && !$@, $name;
187     }
188     else {
189         _ok eval  ($code) && !$@, $name;
190     }
191 }
192
193 sub must_die {
194     my ($code, $pattern, $name) = @_;
195     Carp::confess("Bad pattern") unless $pattern;
196     undef $@;
197     ref $code ? &$code : eval $code;
198     my  $r = $@ && $@ =~ /$pattern/;
199     _ok $r, $name // "\$\@ =~ /$pattern/";
200 }
201
202 sub must_warn {
203     my ($code, $pattern, $name) = @_;
204     Carp::confess("Bad pattern") unless $pattern;
205     my $w;
206     local $SIG {__WARN__} = sub {$w .= join "" => @_};
207     use warnings 'all';
208     ref $code ? &$code : eval $code;
209     my $r = $w && $w =~ /$pattern/;
210     $w //= "UNDEF";
211     _ok $r, $name // "Got warning /$pattern/",
212             "# expected: /$pattern/\n" .
213             "#   result: $w";
214 }
215
216 sub may_not_warn {
217     my ($code, $name) = @_;
218     my $w;
219     local $SIG {__WARN__} = sub {$w .= join "" => @_};
220     use warnings 'all';
221     ref $code ? &$code : eval $code;
222     _ok !$w, $name, "Got warning '$w'";
223 }
224
225 1;