This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2d77a1c8fbb49d011f717c2c6addc83eebf985f8
[perl5.git] / t / re / ReTest.pl
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     $running_as_thread
14     $IS_ASCII
15     $IS_EBCDIC
16     $ordA
17 );
18
19 $| = 1;
20
21 our $ordA = ord ('A');  # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
22 # This defined the platform.
23 our $IS_ASCII  = $ordA ==  65;
24 our $IS_EBCDIC = $ordA == 193;
25
26 use vars '%Config';
27 eval 'use Config';          #  Defaults assumed if this fails
28
29 my $test = 0;
30 my $done_plan;
31 sub 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
45 sub pretty {
46     my ($mess) = @_;
47     return unless defined $mess;
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
56 sub safe_globals {
57     defined($_) and s/#/\\#/g for $TODO;
58 }
59
60 sub _ok {
61     my ($ok, $mess, $error) = @_;
62     plan();
63     safe_globals();
64     $mess    = defined $mess ? pretty ($mess) : 'Noname test';
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,
72               $mess;
73
74     unless ($ok) {
75         print "# Failed test at line $line_nr\n" unless defined $TODO;
76         if ($error) {
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
89 sub  ok ($;$$) {_ok  $_ [0], $_ [1], $_ [2]}
90 sub nok ($;$$) {_ok !$_ [0], "Failed: " . $_ [1], $_ [2]}
91
92
93 sub skip {
94     my $why = shift;
95     safe_globals();
96     $why =~ s/\n.*//s;
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
106     my $n = shift // 1;
107     my $line_nr = (caller(0)) [2];
108     for (1 .. $n) {
109         ++ $test;
110         print "$ok $test # $why\tLine $line_nr\n";
111     }
112     no warnings "exiting";
113     last SKIP;
114 }
115
116 sub iseq ($$;$) { 
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" .
131                 "#   result: $got";
132
133     _ok $pass, $name, $error;
134 }   
135
136 sub isneq ($$;$) { 
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";
149     my $error = "# results are equal ($got)";
150
151     _ok $pass, $name, $error;
152 }   
153
154 *is = \&iseq;
155 *isnt = \&isneq;
156
157 sub diag {
158     print STDERR "# $_[0]\n";
159 }
160
161 sub like ($$$) {
162     my (undef, $expected, $name) = @_;
163     my ($pass, $error);
164     $pass = $_[0] =~ /$expected/;
165     unless ($pass) {
166         $error = "#      got '$_[0]'\n# expected /$expected/";
167     }
168     _ok($pass, $name, $error);
169 }
170
171 sub unlike ($$$) {
172     my (undef, $expected, $name) = @_;
173     my ($pass, $error);
174     $pass = $_[0] !~ /$expected/;
175     unless ($pass) {
176         $error = "#      got '$_[0]'\n# expected !~ /$expected/";
177     }
178     _ok($pass, $name, $error);
179 }
180
181 sub eval_ok ($;$) {
182     my ($code, $name) = @_;
183     local $@;
184     if (ref $code) {
185         _ok eval {&$code} && !$@, $name;
186     }
187     else {
188         _ok eval  ($code) && !$@, $name;
189     }
190 }
191
192 sub must_die {
193     my ($code, $pattern, $name) = @_;
194     Carp::confess("Bad pattern") unless $pattern;
195     undef $@;
196     ref $code ? &$code : eval $code;
197     my  $r = $@ && $@ =~ /$pattern/;
198     _ok $r, $name // "\$\@ =~ /$pattern/";
199 }
200
201 sub must_warn {
202     my ($code, $pattern, $name) = @_;
203     Carp::confess("Bad pattern") unless $pattern;
204     my $w;
205     local $SIG {__WARN__} = sub {$w .= join "" => @_};
206     use warnings 'all';
207     ref $code ? &$code : eval $code;
208     my $r = $w && $w =~ /$pattern/;
209     $w //= "UNDEF";
210     _ok $r, $name // "Got warning /$pattern/",
211             "# expected: /$pattern/\n" .
212             "#   result: $w";
213 }
214
215 sub may_not_warn {
216     my ($code, $name) = @_;
217     my $w;
218     local $SIG {__WARN__} = sub {$w .= join "" => @_};
219     use warnings 'all';
220     ref $code ? &$code : eval $code;
221     _ok !$w, $name, "Got warning '$w'";
222 }
223
224 1;