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
121
122
123
124
125
126
127
128
129
130
131
132
|
#!perl -T
use strict;
use warnings;
use Test::More tests => 6 + 5 + 4 + 1 + 9;
use Scope::Upper qw<uid validate_uid HERE UP>;
{
local $@;
my $here = uid;
eval {
validate_uid($here);
};
is $@, '', 'validate_uid(uid) does not croak';
}
{
local $@;
my $here = uid;
eval {
validate_uid('123');
};
my $line = __LINE__-2;
like $@, qr/^UID contains only one part at \Q$0\E line $line/,
'validate_uid("123") croaks';
}
for my $wrong ('1.23-4', 'abc-5') {
local $@;
my $here = uid;
eval {
validate_uid($wrong);
};
my $line = __LINE__-2;
like $@, qr/^First UID part is not an unsigned integer at \Q$0\E line $line/,
"validate_uid(\"$wrong\") croaks";
}
for my $wrong ('67-8.9', '001-def') {
local $@;
my $here = uid;
eval {
validate_uid($wrong);
};
my $line = __LINE__-2;
like $@, qr/^Second UID part is not an unsigned integer at \Q$0\E line $line/,
"validate_uid(\"$wrong\") croaks";
}
{
my $here = uid;
ok validate_uid($here), '$here is valid (same scope)';
{
ok validate_uid($here), '$here is valid (in block)';
}
sub {
ok validate_uid($here), '$here is valid (in sub)';
}->();
local $@;
eval {
ok validate_uid($here), '$here is valid (in eval block)';
};
eval q{
ok validate_uid($here), '$here is valid (in eval string)';
};
}
{
my $here;
{
{
$here = uid(UP);
ok validate_uid($here), '$here is valid (below)';
}
ok validate_uid($here), '$here is valid (exact)';
}
ok !validate_uid($here), '$here is invalid (above)';
{
ok !validate_uid($here), '$here is invalid (new block)';
}
}
{
my $first;
for (1, 2) {
if ($_ == 1) {
$first = uid();
} else {
ok !validate_uid($first), 'a new UID for each loop iteration';
}
}
}
{
my $top;
my $uid;
sub Scope::Upper::TestUIDDestructor::DESTROY {
ok !validate_uid($top),
'$top defined after the guard is not valid in destructor';
$uid = uid;
ok validate_uid($uid), '$uid is valid in destructor';
my $up;
{
$up = uid;
ok validate_uid($up), '$up is valid in destructor';
}
ok !validate_uid($up), '$up is no longer valid in destructor';
}
{
my $guard = bless [], 'Scope::Upper::TestUIDDestructor';
$top = uid;
ok validate_uid($top), '$top defined after the guard is valid in block';
}
ok !validate_uid($top), '$top is no longer valid outside of the block';
ok !validate_uid($uid), '$uid is no longer valid outside of the destructor';
sub Scope::Upper::TestUIDDestructor2::DESTROY {
ok validate_uid($top), '$top defined before the guard is valid in destructor';
}
SKIP: {
skip 'Destructors are always last before perl 5.8' => 2 if "$]" < 5.008;
$top = uid;
my $guard = bless [], 'Scope::Upper::TestUIDDestructor2';
ok validate_uid($top), '$top defined before the guard is valid in block';
}
}
|
