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