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