From: Vincent Pit Date: Fri, 9 Sep 2011 23:53:46 +0000 (+0200) Subject: Implement uid() and validate_uid() X-Git-Tag: v0.18~4 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=0f7334e9f0acbdac38c362be678bd6ecb658cb0b Implement uid() and validate_uid() --- diff --git a/MANIFEST b/MANIFEST index e5ae94c..79d90df 100644 --- a/MANIFEST +++ b/MANIFEST @@ -47,9 +47,14 @@ t/65-uplevel-multi.t t/66-uplevel-context.t t/67-uplevel-scope.t t/69-uplevel-threads.t +t/70-uid-target.t +t/74-uid-validate.t +t/75-uid-uplevel.t +t/79-uid-threads.t t/81-stress-level.t t/85-stress-unwind.t t/86-stress-uplevel.t +t/87-stress-uid.t t/91-pod.t t/92-pod-coverage.t t/95-portability-files.t diff --git a/Upper.xs b/Upper.xs index 0ae07f0..259d2fc 100644 --- a/Upper.xs +++ b/Upper.xs @@ -179,6 +179,134 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define MY_CXT_CLONE NOOP #endif +/* --- Unique context ID global storage ------------------------------------ */ + +/* ... Sequence ID counter ................................................. */ + +typedef struct { + UV *seqs; + STRLEN size; +} su_uv_array; + +STATIC su_uv_array su_uid_seq_counter; + +#ifdef USE_ITHREADS + +STATIC perl_mutex su_uid_seq_counter_mutex; + +#define SU_LOCK(M) MUTEX_LOCK(M) +#define SU_UNLOCK(M) MUTEX_UNLOCK(M) + +#else /* USE_ITHREADS */ + +#define SU_LOCK(M) +#define SU_UNLOCK(M) + +#endif /* !USE_ITHREADS */ + +STATIC UV su_uid_seq_next(pTHX_ UV depth) { +#define su_uid_seq_next(D) su_uid_seq_next(aTHX_ (D)) + UV seq; + UV *seqs; + + SU_LOCK(&su_uid_seq_counter_mutex); + + seqs = su_uid_seq_counter.seqs; + + if (depth >= su_uid_seq_counter.size) { + UV i; + + seqs = PerlMemShared_realloc(seqs, (depth + 1) * sizeof(UV)); + for (i = su_uid_seq_counter.size; i <= depth; ++i) + seqs[i] = 0; + + su_uid_seq_counter.seqs = seqs; + su_uid_seq_counter.size = depth + 1; + } + + seq = ++seqs[depth]; + + SU_UNLOCK(&su_uid_seq_counter_mutex); + + return seq; +} + +/* ... UID storage ......................................................... */ + +typedef struct { + UV seq; + U32 flags; +} su_uid; + +#define SU_UID_ACTIVE 1 + +STATIC UV su_uid_depth(pTHX_ I32 cxix) { +#define su_uid_depth(I) su_uid_depth(aTHX_ (I)) + const PERL_SI *si; + UV depth; + + depth = cxix; + for (si = PL_curstackinfo->si_prev; si; si = si->si_prev) + depth += si->si_cxix + 1; + + return depth; +} + +typedef struct { + su_uid **map; + STRLEN used; + STRLEN alloc; +} su_uid_storage; + +STATIC void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) { +#define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D)) + su_uid **old_map = old_cxt->map; + + if (old_map) { + su_uid **new_map = new_cxt->map; + STRLEN old_used = old_cxt->used; + STRLEN old_alloc = old_cxt->alloc; + STRLEN new_used, new_alloc; + STRLEN i; + + new_used = max_depth < old_used ? max_depth : old_used; + new_cxt->used = new_used; + + if (new_used <= new_cxt->alloc) + new_alloc = new_cxt->alloc; + else { + new_alloc = new_used; + Renew(new_map, new_alloc, su_uid *); + for (i = new_cxt->alloc; i < new_alloc; ++i) + new_map[i] = NULL; + new_cxt->map = new_map; + new_cxt->alloc = new_alloc; + } + + for (i = 0; i < new_alloc; ++i) { + su_uid *new_uid = new_map[i]; + + if (i < new_used) { /* => i < max_depth && i < old_used */ + su_uid *old_uid = old_map[i]; + + if (old_uid && (old_uid->flags & SU_UID_ACTIVE)) { + if (!new_uid) { + Newx(new_uid, 1, su_uid); + new_map[i] = new_uid; + } + *new_uid = *old_uid; + continue; + } + } + + if (new_uid) + new_uid->flags &= ~SU_UID_ACTIVE; + } + } + + return; +} + /* --- unwind() global storage --------------------------------------------- */ typedef struct { @@ -216,6 +344,8 @@ typedef struct { #endif bool old_catch; OP *old_op; + + su_uid_storage new_uid_storage, old_uid_storage; } su_uplevel_ud; STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { @@ -226,6 +356,10 @@ STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { Newx(sud, 1, su_uplevel_ud); sud->next = NULL; + sud->new_uid_storage.map = NULL; + sud->new_uid_storage.used = 0; + sud->new_uid_storage.alloc = 0; + Newx(si, 1, PERL_SI); si->si_stack = newAV(); AvREAL_off(si->si_stack); @@ -244,6 +378,18 @@ STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { Safefree(si->si_cxstack); SvREFCNT_dec(si->si_stack); Safefree(si); + + if (sud->new_uid_storage.map) { + su_uid **map = sud->new_uid_storage.map; + STRLEN alloc = sud->new_uid_storage.alloc; + STRLEN i; + + for (i = 0; i < alloc; ++i) + Safefree(map[i]); + + Safefree(map); + } + Safefree(sud); return; @@ -267,6 +413,7 @@ typedef struct { char *stack_placeholder; su_unwind_storage unwind_storage; su_uplevel_storage uplevel_storage; + su_uid_storage uid_storage; } my_cxt_t; START_MY_CXT @@ -967,9 +1114,10 @@ STATIC U8 su_op_gimme_reverse(U8 gimme) { #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END -STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX) { -#define su_uplevel_storage_new() su_uplevel_storage_new(aTHX) +STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { +#define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I)) su_uplevel_ud *sud; + UV depth; dMY_CXT; sud = MY_CXT.uplevel_storage.root; @@ -983,6 +1131,11 @@ STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX) { sud->next = MY_CXT.uplevel_storage.top; MY_CXT.uplevel_storage.top = sud; + depth = su_uid_depth(cxix); + su_uid_storage_dup(&sud->new_uid_storage, &MY_CXT.uid_storage, depth); + sud->old_uid_storage = MY_CXT.uid_storage; + MY_CXT.uid_storage = sud->new_uid_storage; + return sud; } @@ -990,6 +1143,18 @@ STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S)) dMY_CXT; + sud->new_uid_storage = MY_CXT.uid_storage; + MY_CXT.uid_storage = sud->old_uid_storage; + { + su_uid **map; + UV i, alloc; + map = sud->new_uid_storage.map; + alloc = sud->new_uid_storage.alloc; + for (i = 0; i < alloc; ++i) { + if (map[i]) + map[i]->flags &= SU_UID_ACTIVE; + } + } MY_CXT.uplevel_storage.top = sud->next; if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) { @@ -1233,6 +1398,9 @@ found_it: { dMY_CXT; + sud->new_uid_storage = MY_CXT.uid_storage; + MY_CXT.uid_storage = sud->old_uid_storage; + MY_CXT.uplevel_storage.top = sud->next; sud->next = MY_CXT.uplevel_storage.root; MY_CXT.uplevel_storage.root = sud; @@ -1324,7 +1492,7 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base; SPAGAIN; - sud = su_uplevel_storage_new(); + sud = su_uplevel_storage_new(cxix); sud->cxix = cxix; sud->died = 1; @@ -1480,12 +1648,166 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { return ret; } +/* --- Unique context ID --------------------------------------------------- */ + +STATIC su_uid *su_uid_storage_fetch(pTHX_ UV depth) { +#define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D)) + su_uid **map, *uid; + STRLEN alloc; + dMY_CXT; + + map = MY_CXT.uid_storage.map; + alloc = MY_CXT.uid_storage.alloc; + + if (depth >= alloc) { + STRLEN i; + + Renew(map, depth + 1, su_uid *); + for (i = alloc; i <= depth; ++i) + map[i] = NULL; + + MY_CXT.uid_storage.map = map; + MY_CXT.uid_storage.alloc = depth + 1; + } + + uid = map[depth]; + + if (!uid) { + Newx(uid, 1, su_uid); + uid->seq = 0; + uid->flags = 0; + map[depth] = uid; + } + + if (depth >= MY_CXT.uid_storage.used) + MY_CXT.uid_storage.used = depth + 1; + + return uid; +} + +STATIC int su_uid_storage_check(pTHX_ UV depth, UV seq) { +#define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S)) + su_uid *uid; + dMY_CXT; + + if (depth >= MY_CXT.uid_storage.used) + return 0; + + uid = MY_CXT.uid_storage.map[depth]; + + return uid && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); +} + +STATIC void su_uid_drop(pTHX_ void *ud_) { + su_uid *uid = ud_; + + uid->flags &= ~SU_UID_ACTIVE; +} + +STATIC void su_uid_bump(pTHX_ void *ud_) { + su_ud_reap *ud = ud_; + + SAVEDESTRUCTOR_X(su_uid_drop, ud->cb); +} + +STATIC SV *su_uid_get(pTHX_ I32 cxix) { +#define su_uid_get(I) su_uid_get(aTHX_ (I)) + su_uid *uid; + SV *uid_sv; + UV depth; + + depth = su_uid_depth(cxix); + uid = su_uid_storage_fetch(depth); + + if (!(uid->flags & SU_UID_ACTIVE)) { + su_ud_reap *ud; + + uid->seq = su_uid_seq_next(depth); + uid->flags |= SU_UID_ACTIVE; + + Newx(ud, 1, su_ud_reap); + SU_UD_ORIGIN(ud) = NULL; + SU_UD_HANDLER(ud) = su_uid_bump; + ud->cb = (SV *) uid; + su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); + } + + uid_sv = sv_newmortal(); + sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq); + return uid_sv; +} + +#ifdef grok_number + +#define su_grok_number(S, L, VP) grok_number((S), (L), (VP)) + +#else /* grok_number */ + +#define IS_NUMBER_IN_UV 0x1 + +STATIC int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { +#define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP)) + STRLEN i; + SV *tmpsv; + + /* This crude check should be good enough for a fallback implementation. + * Better be too strict than too lax. */ + for (i = 0; i < len; ++i) { + if (!isDIGIT(s[i])) + return 0; + } + + tmpsv = sv_newmortal(); + sv_setpvn(tmpsv, s, len); + *valuep = sv_2uv(tmpsv); + + return IS_NUMBER_IN_UV; +} + +#endif /* !grok_number */ + +STATIC int su_uid_validate(pTHX_ SV *uid) { +#define su_uid_validate(U) su_uid_validate(aTHX_ (U)) + const char *s; + STRLEN len, p = 0; + UV depth, seq; + int type; + + s = SvPV_const(uid, len); + + while (p < len && s[p] != '-') + ++p; + if (p >= len) + croak("UID contains only one part"); + + type = su_grok_number(s, p, &depth); + if (type != IS_NUMBER_IN_UV) + croak("First UID part is not an unsigned integer"); + + ++p; /* Skip '-'. As we used to have p < len, len - (p + 1) >= 0. */ + + type = su_grok_number(s + p, len - p, &seq); + if (type != IS_NUMBER_IN_UV) + croak("Second UID part is not an unsigned integer"); + + return su_uid_storage_check(depth, seq); +} + /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC void su_teardown(pTHX_ void *param) { su_uplevel_ud *cur; + su_uid **map; dMY_CXT; + map = MY_CXT.uid_storage.map; + if (map) { + STRLEN i; + for (i = 0; i < MY_CXT.uid_storage.used; ++i) + Safefree(map[i]); + Safefree(map); + } + cur = MY_CXT.uplevel_storage.root; if (cur) { su_uplevel_ud *prev; @@ -1518,6 +1840,10 @@ STATIC void su_setup(pTHX) { MY_CXT.uplevel_storage.root = NULL; MY_CXT.uplevel_storage.count = 0; + MY_CXT.uid_storage.map = NULL; + MY_CXT.uid_storage.used = 0; + MY_CXT.uid_storage.alloc = 0; + call_atexit(su_teardown, NULL); return; @@ -1636,6 +1962,11 @@ BOOT: { HV *stash; + MUTEX_INIT(&su_uid_seq_counter_mutex); + + su_uid_seq_counter.seqs = NULL; + su_uid_seq_counter.size = 0; + stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "TOP", newSViv(0)); newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); @@ -1650,12 +1981,22 @@ BOOT: void CLONE(...) PROTOTYPE: DISABLE +PREINIT: + su_uid_storage new_cxt; PPCODE: + { + dMY_CXT; + new_cxt.map = NULL; + new_cxt.used = 0; + new_cxt.alloc = 0; + su_uid_storage_dup(&new_cxt, &MY_CXT.uid_storage, MY_CXT.uid_storage.used); + } { MY_CXT_CLONE; MY_CXT.uplevel_storage.top = NULL; MY_CXT.uplevel_storage.root = NULL; MY_CXT.uplevel_storage.count = 0; + MY_CXT.uid_storage = new_cxt; } XSRETURN(0); @@ -1904,3 +2245,27 @@ PPCODE: } } while (--cxix >= 0); croak("Can't uplevel outside a subroutine"); + +void +uid(...) +PROTOTYPE: ;$ +PREINIT: + I32 cxix; + SV *uid; +PPCODE: + SU_GET_CONTEXT(0, 0); + uid = su_uid_get(cxix); + EXTEND(SP, 1); + PUSHs(uid); + XSRETURN(1); + +void +validate_uid(SV *uid) +PROTOTYPE: $ +PREINIT: + SV *ret; +PPCODE: + ret = su_uid_validate(uid) ? &PL_sv_yes : &PL_sv_no; + EXTEND(SP, 1); + PUSHs(ret); + XSRETURN(1); diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 6ef56c0..f2a97c5 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -128,6 +128,28 @@ L : target('hello'); # "hello from Uplevel::target()" +L and L : + + use Scope::Upper qw; + + my $uid; + + { + $uid = uid(); + { + if ($uid eq uid(UP)) { # yes + ... + } + if (validate_uid($uid)) { # yes + ... + } + } + } + + if (validate_uid($uid)) { # no + ... + } + =head1 DESCRIPTION This module lets you defer actions I that will take place when the control flow returns into an upper scope. @@ -149,7 +171,11 @@ return values immediately to an upper level with L, and know which cont =item * -execute a subroutine in the setting of an upper subroutine stack frame with L. +execute a subroutine in the setting of an upper subroutine stack frame with L ; + +=item * + +uniquely identify contextes with L and L. =back @@ -353,6 +379,73 @@ A simple wrapper lets you mimic the interface of L : Albeit the three exceptions listed above, it passes all the tests of L. +=head2 C + +Returns an unique identifier (UID) for the context (or dynamic scope) pointed by C<$context>, or for the current context if C<$context> is omitted. +This UID will only be valid for the life time of the context it represents, and another UID will be generated next time the same scope is executed. + + my $uid; + + { + $uid = uid; + if ($uid eq uid()) { # yes, this is the same context + ... + } + { + if ($uid eq uid()) { # no, we are one scope below + ... + } + if ($uid eq uid(UP)) { # yes, UP points to the same scope as $uid + ... + } + } + } + + # $uid is now invalid + + { + if ($uid eq uid()) { # no, this is another block + ... + } + } + +For example, each loop iteration gets its own UID : + + my %uids; + + for (1 .. 5) { + my $uid = uid; + $uids{$uid} = $_; + } + + # %uids has 5 entries + +The UIDs are not guaranteed to be numbers, so you must use the C operator to compare them. + +To check whether a given UID is valid, you can use the L function. + +=head2 C + +Returns true if and only if C<$uid> is the UID of a currently valid context (that is, it designates a scope that is higher than the current one in the call stack). + + my $uid; + + { + $uid = uid(); + if (validate_uid($uid)) { # yes + ... + } + { + if (validate_uid($uid)) { # yes + ... + } + } + } + + if (validate_uid($uid)) { # no + ... + } + =head1 CONSTANTS =head2 C @@ -484,6 +577,7 @@ our %EXPORT_TAGS = ( localize localize_elem localize_delete unwind want_at uplevel + uid validate_uid > ], words => [ qw ], consts => [ qw ], diff --git a/t/01-import.t b/t/01-import.t index de0260a..d27e6b9 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2 * 15; +use Test::More tests => 2 * 17; require Scope::Upper; @@ -15,6 +15,8 @@ my %syms = ( unwind => undef, want_at => ';$', uplevel => '&@', + uid => ';$', + validate_uid => '$', TOP => '', HERE => '', UP => ';$', diff --git a/t/70-uid-target.t b/t/70-uid-target.t new file mode 100644 index 0000000..3a0ca29 --- /dev/null +++ b/t/70-uid-target.t @@ -0,0 +1,103 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 3 + 6 + 4 + 1 + 5; + +use Scope::Upper qw; + +{ + local $@; + eval { + my $here = uid; + }; + is $@, '', 'uid() does not croak'; +} + +{ + local $@; + eval { + my $here = uid HERE; + }; + is $@, '', 'uid(HERE) does not croak'; +} + +{ + local $@; + eval { + my $up = uid UP; + }; + is $@, '', 'uid(UP) does not croak'; +} + +{ + my $here = uid; + is $here, uid(), '$here eq uid()'; + is $here, uid(HERE), '$here eq uid(HERE)'; + { + is $here, uid(UP), '$here eq uid(UP) (in block)'; + } + sub { + is $here, uid(UP), '$here eq uid(UP) (in sub)'; + }->(); + local $@; + eval { + is $here, uid(UP), '$here eq uid(UP) (in eval block)'; + }; + eval q{ + is $here, uid(UP), '$here eq uid(UP) (in eval string)'; + }; +} + +{ + my $here; + { + { + $here = uid(UP); + isnt $here, uid(), 'uid(UP) != uid(HERE)'; + } + is $here, uid(), '$here defined in an older block is now OK'; + } + isnt $here, uid(), '$here defined in an older block is no longer OK'; + { + isnt $here, uid(), '$here defined in an older block has been overwritten'; + } +} + +{ + my $first; + for (1, 2) { + if ($_ == 1) { + $first = uid(); + } else { + isnt $first, uid(), 'a new UID for each loop iteration'; + } + } +} + +{ + my $top; + my $uid; + + sub Scope::Upper::TestUIDDestructor::DESTROY { + $uid = uid; + isnt $uid, $top, '$uid is not the outside UID'; + { + is uid(UP), $uid, 'uid(UP) in block in destructor is correct'; + } + } + + { + my $guard = bless [], 'Scope::Upper::TestUIDDestructor'; + $top = uid; + } + isnt $uid, undef, '$uid was set in the destructor'; + + { + isnt $uid, uid(), '$uid is no longer valid (in block)'; + sub { + isnt $uid, uid(), '$uid is no longer valid (in sub in block)'; + }->(); + } +} diff --git a/t/74-uid-validate.t b/t/74-uid-validate.t new file mode 100644 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; + +{ + 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'; + } +} diff --git a/t/75-uid-uplevel.t b/t/75-uid-uplevel.t new file mode 100644 index 0000000..ddd9277 --- /dev/null +++ b/t/75-uid-uplevel.t @@ -0,0 +1,161 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 2 * 32 + 2 * 21; + +use Scope::Upper qw; + +for my $run (1, 2) { + sub { + my $above_uid = uid; + my $there = "in the sub above the target (run $run)"; + + my $uplevel_uid = sub { + my $target_uid = uid; + my $there = "in the target sub (run $run)"; + + my $uplevel_uid = sub { + my $between_uid = uid; + my $there = "in the sub between the target and the source (run $run)"; + + my $uplevel_uid = sub { + my $source_uid = uid; + my $there = "in the source sub (run $run)"; + + my $uplevel_uid = uplevel { + my $uplevel_uid = uid; + my $there = "in the uplevel callback (run $run)"; + my $invalid = 'temporarily invalid'; + + ok validate_uid($uplevel_uid), "\$uplevel_uid is valid $there"; + ok !validate_uid($source_uid), "\$source_uid is $invalid $there"; + ok !validate_uid($between_uid), "\$between_uid is $invalid $there"; + ok !validate_uid($target_uid), "\$target_uid is $invalid $there"; + ok validate_uid($above_uid), "\$above_uid is valid $there"; + + isnt $uplevel_uid, $source_uid, "\$uplevel_uid != \$source_uid $there"; + isnt $uplevel_uid, $between_uid, "\$uplevel_uid != \$between_uid $there"; + isnt $uplevel_uid, $target_uid, "\$uplevel_uid != \$target_uid $there"; + isnt $uplevel_uid, $above_uid, "\$uplevel_uid != \$above_uid $there"; + + { + my $here = uid; + + isnt $here, $source_uid, "\$here != \$source_uid in block $there"; + isnt $here, $between_uid, "\$here != \$between_uid in block $there"; + isnt $here, $target_uid, "\$here != \$target_uid in block $there"; + isnt $here, $above_uid, "\$here != \$above_uid in block $there"; + } + + is uid(UP), $above_uid, "uid(UP) == \$above_uid $there"; + + return $uplevel_uid; + } UP UP; + + ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; + ok validate_uid($source_uid), "\$source_uid is valid again $there"; + ok validate_uid($between_uid), "\$between_uid is valid again $there"; + ok validate_uid($target_uid), "\$target_uid is valid again $there"; + ok validate_uid($above_uid), "\$above_uid is still valid $there"; + + return $uplevel_uid; + }->(); + + ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; + ok validate_uid($between_uid), "\$between_uid is valid again $there"; + ok validate_uid($target_uid), "\$target_uid is valid again $there"; + ok validate_uid($above_uid), "\$above_uid is still valid $there"; + + return $uplevel_uid; + }->(); + + ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; + ok validate_uid($target_uid), "\$target_uid is valid again $there"; + ok validate_uid($above_uid), "\$above_uid is still valid $there"; + + return $uplevel_uid; + }->(); + + ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; + ok validate_uid($above_uid), "\$above_uid is still valid $there"; + + sub { + my $here = uid; + my $there = "in a new sub at replacing the target"; + + ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; + ok validate_uid($above_uid), "\$above_uid is still valid $there"; + + isnt $here, $uplevel_uid, "\$here != \$uplevel_uid $there"; + + is uid(UP), $above_uid, "uid(UP) == \$above_uid $there"; + }->(); + }->(); +} + +for my $run (1, 2) { + sub { + my $first_sub = uid; + my $there = "in the first sub (run $run)"; + my $invalid = 'temporarily invalid'; + + uplevel { + my $first_uplevel = uid; + my $there = "in the first uplevel (run $run)"; + + ok !validate_uid($first_sub), "\$first_sub is $invalid $there"; + ok validate_uid($first_uplevel), "\$first_uplevel is valid $there"; + + isnt $first_uplevel, $first_sub, "\$first_uplevel != \$first_sub $there"; + isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there"; + + my ($second_sub, $second_uplevel) = sub { + my $second_sub = uid; + my $there = "in the second sub (run $run)"; + + my $second_uplevel = uplevel { + my $second_uplevel = uid; + my $there = "in the second uplevel (run $run)"; + + ok !validate_uid($first_sub), "\$first_sub is $invalid $there"; + ok validate_uid($first_uplevel), "\$first_uplevel is valid $there"; + ok !validate_uid($second_sub), "\$second_sub is $invalid $there"; + ok validate_uid($second_uplevel), "\$second_uplevel is valid $there"; + + isnt $second_uplevel, $second_sub, + "\$second_uplevel != \$second_sub $there"; + is uid(UP), $first_uplevel, "uid(UP) == \$first_uplevel $there"; + + return $second_uplevel; + }; + + return $second_sub, $second_uplevel; + }->(); + + ok validate_uid($first_uplevel), "\$first_uplevel is still valid $there"; + ok !validate_uid($second_sub), "\$second_sub is no longer valid $there"; + ok !validate_uid($second_uplevel), + "\$second_uplevel is no longer valid $there"; + + uplevel { + my $third_uplevel = uid; + my $there = "in the third uplevel (run $run)"; + + ok !validate_uid($first_uplevel), "\$first_uplevel is $invalid $there"; + ok !validate_uid($second_sub), "\$second_sub is no longer valid $there"; + ok !validate_uid($second_uplevel), + "\$second_uplevel is no longer valid $there"; + ok validate_uid($third_uplevel), "\$third_uplevel is valid $there"; + + isnt $third_uplevel, $first_uplevel, + "\$third_uplevel != \$first_uplevel $there"; + isnt $third_uplevel, $second_sub, "\$third_uplevel != \$second_sub $there"; + isnt $third_uplevel, $second_uplevel, + "\$third_uplevel != \$second_uplevel $there"; + isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there"; + } + } + }->(); +} diff --git a/t/79-uid-threads.t b/t/79-uid-threads.t new file mode 100644 index 0000000..4818c03 --- /dev/null +++ b/t/79-uid-threads.t @@ -0,0 +1,78 @@ +#!perl -T + +use strict; +use warnings; + +sub skipall { + my ($msg) = @_; + require Test::More; + Test::More::plan(skip_all => $msg); +} + +use Config qw<%Config>; + +BEGIN { + my $force = $ENV{PERL_SCOPE_UPPER_TEST_THREADS} ? 1 : !1; + my $t_v = $force ? '0' : '1.67'; + skipall 'This perl wasn\'t built to support threads' + unless $Config{useithreads}; + skipall 'perl 5.13.4 required to test thread safety' + unless $force or "$]" >= 5.013004; + skipall "threads $t_v required to test thread safety" + unless eval "use threads $t_v; 1"; +} + +use Test::More; + +use Scope::Upper qw; + +my $num; + +BEGIN { + skipall 'This Scope::Upper isn\'t thread safe' unless SU_THREADSAFE; + plan tests => ($num = 30) * 5 + 1; + defined and diag "Using threads $_" for $threads::VERSION; + if (eval "use Time::HiRes; 1") { + defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION; + *usleep = \&Time::HiRes::usleep; + } else { + diag 'Using fallback usleep'; + *usleep = sub { + my $s = int($_[0] / 2.5e5); + sleep $s if $s; + }; + } +} + +my $top = uid; + +sub cb { + my $tid = threads->tid(); + + my $here = uid; + my $up; + { + $up = uid HERE; + is uid(UP), $here, "uid(UP) == \$here in block (in thread $tid)"; + } + + is uid(UP), $top, "uid(UP) == \$top (in thread $tid)"; + + usleep rand(1e6); + + ok validate_uid($here), "\$here is valid (in thread $tid)"; + ok !validate_uid($up), "\$up is no longer valid (in thread $tid)"; + + return $here; +} + +my %uids; + +for my $thread (map threads->create(\&cb), 1 .. $num) { + my $tid = $thread->tid; + my $uid = $thread->join; + ++$uids{$uid}; + ok !validate_uid($uid), "\$here is no longer valid (out of thread $tid)"; +} + +is scalar(keys %uids), $num, 'all the UIDs were different'; diff --git a/t/87-stress-uid.t b/t/87-stress-uid.t new file mode 100644 index 0000000..7338b45 --- /dev/null +++ b/t/87-stress-uid.t @@ -0,0 +1,62 @@ +#!perl -T + +use strict; +use warnings; + +use lib 't/lib'; +use Test::Leaner 'no_plan'; + +use Scope::Upper qw; + +my $max_level = 10; + +our $inner_uplevels; + +sub rec { + my $n = shift; + my $level = shift; + my $target = shift; + my @uids = @_; + + if ($n > 0) { + my @args = ($n - 1 => ($level, $target) => @uids); + if ($inner_uplevels) { + return uplevel { + rec(@args, uid()); + }; + } else { + return rec(@args, uid()); + } + } + + my $desc = "level=$level, target=$target, inner_uplevels=$inner_uplevels"; + + uplevel { + for my $i (1 .. $target) { + my $j = $level - $i; + ok !validate_uid($uids[$j]), "UID $j is invalid for $desc"; + } + for my $i ($target + 1 .. $level) { + my $j = $level - $i; + ok validate_uid($uids[$j]), "UID $j is valid for $desc"; + } + } CALLER($target); +} + +{ + local $inner_uplevels = 0; + for my $level (1 .. $max_level) { + for my $target (1 .. $level) { + rec($level => ($level, $target)); + } + } +} + +{ + local $inner_uplevels = 1; + for my $level (1 .. $max_level) { + for my $target (1 .. $level) { + rec($level => ($level, $target)); + } + } +}