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