Commit | Line | Data |
9d45b377 |
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 | $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 | |
29 | our $ordA = ord ('A'); # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC |
30 | # This defined the platform. |
31 | our $IS_ASCII = $ordA == 65; |
32 | our $IS_EBCDIC = $ordA == 193; |
33 | |
34 | use vars '%Config'; |
35 | eval 'use Config'; # Defaults assumed if this fails |
36 | |
37 | my $test = 0; |
38 | my $done_plan; |
39 | sub 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 | |
53 | sub 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 | |
63 | sub safe_globals { |
64 | defined($_) and s/#/\\#/g for $BugId, $PatchId, $TODO; |
65 | } |
66 | |
67 | sub _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 |
98 | sub ok ($;$$) {_ok $_ [0], $_ [1], $_ [2]} |
99 | sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]} |
100 | |
101 | |
102 | sub 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 | |
122 | sub 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 | |
134 | sub 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 | |
147 | sub 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 | |
158 | sub 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 | |
168 | sub 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 | |
182 | sub 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 | |
193 | 1; |