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