t/op/study.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 $Ok_Level = 0;
   9 my $test = 1;
  10 sub ok ($;$) {
  11     my($ok, $name) = @_;
  12
  13     local $_;
  14
  15     # You have to do it this way or VMS will get confused.
  16     printf "%s $test%s\n", $ok   ? 'ok' : 'not ok',
  17                            $name ? " - $name" : '';
  18
  19     printf "# Failed test at line %d\n", (caller($Ok_Level))[2] unless $ok;
  20
  21     $test++;
  22     return $ok;
  23 }
  24
  25 sub nok ($;$) {
  26     my($nok, $name) = @_;
  27     local $Ok_Level = 1;
  28     ok( !$nok, $name );
  29 }
  30
  31 use Config;
  32 my $have_alarm = $Config{d_alarm};
  33 sub alarm_ok (&) {
  34     my $test = shift;
  35
  36     local $SIG{ALRM} = sub { die "timeout\n" };
  37
  38     my $match;
  39     eval {
  40         alarm(2) if $have_alarm;
  41         $match = $test->();
  42         alarm(0) if $have_alarm;
  43     };
  44
  45     local $Ok_Level = 1;
  46     ok( !$match && !$@, 'testing studys that used to hang' );
  47 }
  48
  49
  50 print "1..26\n";
  51
  52 $x = "abc\ndef\n";
  53 study($x);
  54
  55 ok($x =~ /^abc/);
  56 ok($x !~ /^def/);
  57
  58 # used to be a test for $*
  59 ok($x =~ /^def/m);
  60
  61 $_ = '123';
  62 study;
  63 ok(/^([0-9][0-9]*)/);
  64
  65 nok($x =~ /^xxx/);
  66 nok($x !~ /^abc/);
  67
  68 ok($x =~ /def/);
  69 nok($x !~ /def/);
  70
  71 study($x);
  72 ok($x !~ /.def/);
  73 nok($x =~ /.def/);
  74
  75 ok($x =~ /\ndef/);
  76 nok($x !~ /\ndef/);
  77
  78 $_ = 'aaabbbccc';
  79 study;
  80 ok(/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc');
  81 ok(/(a+b+c+)/ && $1 eq 'aaabbbccc');
  82
  83 nok(/a+b?c+/);
  84
  85 $_ = 'aaabccc';
  86 study;
  87 ok(/a+b?c+/);
  88 ok(/a*b+c*/);
  89
  90 $_ = 'aaaccc';
  91 study;
  92 ok(/a*b?c*/);
  93 nok(/a*b+c*/);
  94
  95 $_ = 'abcdef';
  96 study;
  97 ok(/bcd|xyz/);
  98 ok(/xyz|bcd/);
  99
 100 ok(m|bc/*d|);
 101
 102 ok(/^$_$/);
 103
 104 # used to be a test for $*
 105 ok("ab\ncd\n" =~ /^cd/m);
 106
 107 if ($^O eq 'os390' or $^O eq 'posix-bc') {
 108     # Even with the alarm() OS/390 and BS2000 can't manage these tests
 109     # (Perl just goes into a busy loop, luckily an interruptable one)
 110     for (25..26) { print "not ok $_ # TODO compiler bug?\n" }
 111     $test += 2;
 112 } else {
 113     # [ID 20010618.006] tests 25..26 may loop
 114
 115     $_ = 'FGF';
 116     study;
 117     alarm_ok { /G.F$/ };
 118     alarm_ok { /[F]F$/ };
 119 }
 120