]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/74-uid-validate.t
t/59-unwind-threads.t should always run at least one test
[perl/modules/Scope-Upper.git] / t / 74-uid-validate.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 6 + 5 + 4 + 1 + 9;
7
8 use Scope::Upper qw<uid validate_uid HERE UP>;
9
10 {
11  local $@;
12  my $here = uid;
13  eval {
14   validate_uid($here);
15  };
16  is $@, '', 'validate_uid(uid) does not croak';
17 }
18
19 {
20  local $@;
21  my $here = uid;
22  eval {
23   validate_uid('123');
24  };
25  my $line = __LINE__-2;
26  like $@, qr/^UID contains only one part at \Q$0\E line $line/,
27                                                    'validate_uid("123") croaks';
28 }
29
30 for my $wrong ('1.23-4', 'abc-5') {
31  local $@;
32  my $here = uid;
33  eval {
34   validate_uid($wrong);
35  };
36  my $line = __LINE__-2;
37  like $@, qr/^First UID part is not an unsigned integer at \Q$0\E line $line/,
38                                               "validate_uid(\"$wrong\") croaks";
39 }
40
41 for my $wrong ('67-8.9', '001-def') {
42  local $@;
43  my $here = uid;
44  eval {
45   validate_uid($wrong);
46  };
47  my $line = __LINE__-2;
48  like $@, qr/^Second UID part is not an unsigned integer at \Q$0\E line $line/,
49                                               "validate_uid(\"$wrong\") croaks";
50 }
51
52 {
53  my $here = uid;
54  ok validate_uid($here), '$here is valid (same scope)';
55  {
56   ok validate_uid($here), '$here is valid (in block)';
57  }
58  sub {
59   ok validate_uid($here), '$here is valid (in sub)';
60  }->();
61  local $@;
62  eval {
63   ok validate_uid($here), '$here is valid (in eval block)';
64  };
65  eval q{
66   ok validate_uid($here), '$here is valid (in eval string)';
67  };
68 }
69
70 {
71  my $here;
72  {
73   {
74    $here = uid(UP);
75    ok validate_uid($here), '$here is valid (below)';
76   }
77   ok validate_uid($here), '$here is valid (exact)';
78  }
79  ok !validate_uid($here), '$here is invalid (above)';
80  {
81   ok !validate_uid($here), '$here is invalid (new block)';
82  }
83 }
84
85 {
86  my $first;
87  for (1, 2) {
88   if ($_ == 1) {
89    $first = uid();
90   } else {
91    ok !validate_uid($first), 'a new UID for each loop iteration';
92   }
93  }
94 }
95
96 {
97  my $top;
98  my $uid;
99
100  sub Scope::Upper::TestUIDDestructor::DESTROY {
101   ok !validate_uid($top),
102                       '$top defined after the guard is not valid in destructor';
103   $uid = uid;
104   ok validate_uid($uid), '$uid is valid in destructor';
105   my $up;
106   {
107    $up = uid;
108    ok validate_uid($up), '$up is valid in destructor';
109   }
110   ok !validate_uid($up), '$up is no longer valid in destructor';
111  }
112
113  {
114   my $guard = bless [], 'Scope::Upper::TestUIDDestructor';
115   $top = uid;
116   ok validate_uid($top), '$top defined after the guard is valid in block';
117  }
118  ok !validate_uid($top), '$top is no longer valid outside of the block';
119  ok !validate_uid($uid), '$uid is no longer valid outside of the destructor';
120
121  sub Scope::Upper::TestUIDDestructor2::DESTROY {
122   ok validate_uid($top), '$top defined before the guard is valid in destructor';
123  }
124
125  SKIP: {
126   skip 'Destructors are always last before perl 5.8' => 2 if "$]" < 5.008;
127
128   $top = uid;
129   my $guard = bless [], 'Scope::Upper::TestUIDDestructor2';
130   ok validate_uid($top), '$top defined before the guard is valid in block';
131  }
132 }