Implement uid() and validate_uid()

[perl/modules/Scope-Upper.git] / t / 74-uid-validate.t

diff --git a/t/74-uid-validate.t b/t/74-uid-validate.t
new file mode 100644 (file)
index 0000000..8e7cdcc
--- /dev/null
+++ b/t/74-uid-validate.t
@@ -0,0 +1,130 @@
+#!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';
+ }
+
+ {
+  $top = uid;
+  my $guard = bless [], 'Scope::Upper::TestUIDDestructor2';
+  ok validate_uid($top), '$top defined before the guard is valid in block';
+ }
+}