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;