#!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';
}
}