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     $running_as_thread
  19     $IS_ASCII
  20     $IS_EBCDIC
  21     $ordA
  22 );
  23
  24 $| = 1;
  25
  26 $Message ||= "Noname test";
  27
  28 our $ordA = ord ('A');  # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
  29 # This defined the platform.
  30 our $IS_ASCII  = $ordA ==  65;
  31 our $IS_EBCDIC = $ordA == 193;
  32
  33 use vars '%Config';
  34 eval 'use Config';          #  Defaults assumed if this fails
  35
  36 my $test = 0;
  37 my $done_plan;
  38 sub 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
  52 sub 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
  62 sub safe_globals {
  63     defined($_) and s/#/\\#/g for $BugId, $TODO;
  64 }
  65
  66 sub _ok {
  67     my ($ok, $mess, $error) = @_;
  68     plan();
  69     safe_globals();
  70     $mess    = pretty ($mess // $Message);
  71     $mess   .= "; Bug $BugId"     if defined $BugId;
  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
  96 sub  ok ($;$$) {_ok  $_ [0], $_ [1], $_ [2]}
  97 sub nok ($;$$) {_ok !$_ [0], "Failed: " . ($_ [1] // $Message), $_ [2]}
  98
  99
 100 sub skip {
 101     my $why = shift;
 102     safe_globals();
 103     $why =~ s/\n.*//s;
 104     $why .= "; Bug $BugId" if defined $BugId;
 105     # seems like the new harness code doesn't like todo and skip to be mixed.
 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
 120 sub 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
 132 sub 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
 145 sub 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
 156 sub 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
 166 sub 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
 180 sub 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
 191 1;