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 }