gmtime/localtime are busted around 2**48
[perl.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     $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;