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 $* = 1;
  59 ok($x =~ /^def/);
  60 $* = 0;
  61
  62 $_ = '123';
  63 study;
  64 ok(/^([0-9][0-9]*)/);
  65
  66 nok($x =~ /^xxx/);
  67 nok($x !~ /^abc/);
  68
  69 ok($x =~ /def/);
  70 nok($x !~ /def/);
  71
  72 study($x);
  73 ok($x !~ /.def/);
  74 nok($x =~ /.def/);
  75
  76 ok($x =~ /\ndef/);
  77 nok($x !~ /\ndef/);
  78
  79 $_ = 'aaabbbccc';
  80 study;
  81 ok(/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc');
  82 ok(/(a+b+c+)/ && $1 eq 'aaabbbccc');
  83
  84 nok(/a+b?c+/);
  85
  86 $_ = 'aaabccc';
  87 study;
  88 ok(/a+b?c+/);
  89 ok(/a*b+c*/);
  90
  91 $_ = 'aaaccc';
  92 study;
  93 ok(/a*b?c*/);
  94 nok(/a*b+c*/);
  95
  96 $_ = 'abcdef';
  97 study;
  98 ok(/bcd|xyz/);
  99 ok(/xyz|bcd/);
 100
 101 ok(m|bc/*d|);
 102
 103 ok(/^$_$/);
 104
 105 $* = 1;     # test 3 only tested the optimized version--this one is for real
 106 ok("ab\ncd\n" =~ /^cd/);
 107
 108 if ($^O eq 'os390' or $^O eq 'posix-bc') {
 109     # Even with the alarm() OS/390 and BS2000 can't manage these tests
 110     # (Perl just goes into a busy loop, luckily an interruptable one)
 111     for (25..26) { print "not ok $_ # TODO compiler bug?\n" }
 112     $test += 2;
 113 } else {
 114     # [ID 20010618.006] tests 25..26 may loop
 115
 116     $_ = 'FGF';
 117     study;
 118     alarm_ok { /G.F$/ };
 119     alarm_ok { /[F]F$/ };
 120 }
 121