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
CommitLineData
9d45b377
YO
1#!./perl
2#
3# This is the test subs used for regex testing.
4# This used to be part of re/pat.t
5use warnings;
6use strict;
7use 5.010;
8use base qw/Exporter/;
9use Carp;
10use vars qw(
11 $EXPECTED_TESTS
12 $TODO
13 $Message
9d45b377 14 $BugId
9d45b377
YO
15 $running_as_thread
16 $IS_ASCII
17 $IS_EBCDIC
18 $ordA
19);
20
21$| = 1;
22
23$Message ||= "Noname test";
24
25our $ordA = ord ('A'); # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
26# This defined the platform.
27our $IS_ASCII = $ordA == 65;
28our $IS_EBCDIC = $ordA == 193;
29
30use vars '%Config';
31eval 'use Config'; # Defaults assumed if this fails
32
33my $test = 0;
34my $done_plan;
35sub 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
49sub 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
59sub safe_globals {
1c6f1211 60 defined($_) and s/#/\\#/g for $BugId, $TODO;
9d45b377
YO
61}
62
63sub _ok {
64 my ($ok, $mess, $error) = @_;
65 plan();
66 safe_globals();
67 $mess = pretty ($mess // $Message);
68 $mess .= "; Bug $BugId" if defined $BugId;
9d45b377
YO
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;
c0dc474d 80 if ($error) {
9d45b377
YO
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
93sub ok ($;$$) {_ok $_ [0], $_ [1], $_ [2]}
94sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]}
95
96
97sub skip {
98 my $why = shift;
99 safe_globals();
100 $why =~ s/\n.*//s;
101 $why .= "; Bug $BugId" if defined $BugId;
76220d5e
NC
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
9d45b377
YO
111 my $n = shift // 1;
112 my $line_nr = (caller(0)) [2];
113 for (1 .. $n) {
114 ++ $test;
76220d5e 115 print "$ok $test # $why\tLine $line_nr\n";
9d45b377
YO
116 }
117 no warnings "exiting";
118 last SKIP;
119}
120
121sub iseq ($$;$) {
d4fa8be5
NC
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" .
9d45b377
YO
136 "# result: $got";
137
d4fa8be5 138 _ok $pass, $name, $error;
9d45b377
YO
139}
140
141sub isneq ($$;$) {
d4fa8be5
NC
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";
9d45b377
YO
154 my $error = "# results are equal ($got)";
155
d4fa8be5 156 _ok $pass, $name, $error;
9d45b377
YO
157}
158
e3515e67
NC
159*is = \&iseq;
160*isnt = \&isneq;
161
162sub 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
172sub 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}
9d45b377
YO
181
182sub 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
193sub must_die {
194 my ($code, $pattern, $name) = @_;
88743d87 195 Carp::confess("Bad pattern") unless $pattern;
9d45b377
YO
196 undef $@;
197 ref $code ? &$code : eval $code;
198 my $r = $@ && $@ =~ /$pattern/;
88743d87 199 _ok $r, $name // "\$\@ =~ /$pattern/";
9d45b377
YO
200}
201
202sub must_warn {
203 my ($code, $pattern, $name) = @_;
45bd432f 204 Carp::confess("Bad pattern") unless $pattern;
9d45b377
YO
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";
29fdfc93 211 _ok $r, $name // "Got warning /$pattern/",
9d45b377
YO
212 "# expected: /$pattern/\n" .
213 "# result: $w";
214}
215
216sub 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;
d728c370 222 _ok !$w, $name, "Got warning '$w'";
9d45b377
YO
223}
224
2251;