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     $IS_ASCII
  12     $IS_EBCDIC
  13     $ordA
  14 );
  15
  16 $| = 1;
  17
  18 our $ordA = ord ('A');  # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
  19 # This defined the platform.
  20 our $IS_ASCII  = $ordA ==  65;
  21 our $IS_EBCDIC = $ordA == 193;
  22
  23 require './test.pl';
  24
  25 sub eval_ok ($;$) {
  26     my ($code, $name) = @_;
  27     local $@;
  28     if (ref $code) {
  29         ok(eval {&$code} && !$@, $name);
  30     }
  31     else {
  32         ok(eval  ($code) && !$@, $name);
  33     }
  34 }
  35
  36 sub must_die {
  37     my ($code, $pattern, $name) = @_;
  38     Carp::confess("Bad pattern") unless $pattern;
  39     undef $@;
  40     ref $code ? &$code : eval $code;
  41     like($@, $pattern, $name // "\$\@ =~ /$pattern/");
  42 }
  43
  44 sub must_warn {
  45     my ($code, $pattern, $name) = @_;
  46     Carp::confess("Bad pattern") unless $pattern;
  47     my $w;
  48     local $SIG {__WARN__} = sub {$w .= join "" => @_};
  49     use warnings 'all';
  50     ref $code ? &$code : eval $code;
  51     like($w, qr/$pattern/, "Got warning /$pattern/");
  52 }
  53
  54 sub may_not_warn {
  55     my ($code, $name) = @_;
  56     my $w;
  57     local $SIG {__WARN__} = sub {$w .= join "" => @_};
  58     use warnings 'all';
  59     ref $code ? &$code : eval $code;
  60     is($w, undef, $name) or diag("Got warning '$w'");
  61 }
  62
  63 1;