@@ -1,5 +1,15 @@
Revision history for Lexical-Types
+0.09 2010-01-03 00:00 UTC
+ + Fix : Building and testing with blead.
+ + Fix : Unbalanced scopes when skipping a typed declaration.
+ + Fix : Segfaults when Lexical::Types is loaded for the first time from
+ inside a thread.
+ + Fix : Leaks of memory associated with the root interpreter.
+ + Fix : Work around Kwalitee test misfailures.
+ + Opt : Less memory will be used for non-threaded perls version 5.10.0
+ and below, and for threaded perls from version 5.10.1.
+
0.08 2009-07-04 19:35 UTC
+ Fix : Don't leak the old op info when a pointer table entry is reused.
+ Fix : Possibly missed constructs with eval STRING called in a thread.
@@ -20,6 +20,7 @@ t/21-tie.t
t/22-magic.t
t/23-magic-uvar.t
t/30-threads.t
+t/31-threads-teardown.t
t/40-stress.t
t/91-pod.t
t/92-pod-coverage.t
@@ -27,3 +28,5 @@ t/95-portability-files.t
t/99-kwalitee.t
t/lib/Lexical/Types/TestRequired1.pm
t/lib/Lexical/Types/TestRequired2.pm
+t/lib/Lexical/Types/TestRequired3X.pm
+t/lib/Lexical/Types/TestRequired3Y.pm
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Lexical-Types
-version: 0.08
+version: 0.09
abstract: Extend the semantics of typed lexicals.
author:
- Vincent Pit <perl@profvince.com>
@@ -9,9 +9,11 @@ distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
build_requires:
+ Carp: 0
constant: 0
ExtUtils::MakeMaker: 0
Test::More: 0
+ XSLoader: 0
requires:
Carp: 0
perl: 5.008
@@ -25,7 +27,8 @@ no_index:
directory:
- t
- inc
-generated_by: ExtUtils::MakeMaker version 6.52
+generated_by: ExtUtils::MakeMaker version 6.56
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
+dynamic_config: 1
@@ -15,6 +15,16 @@ if ($^O eq 'MSWin32' && $^V lt v5.9.0) {
my $dist = 'Lexical-Types';
+(my $name = $dist) =~ s{-}{::}g;
+
+(my $file = $dist) =~ s{-}{/}g;
+$file = "lib/$file.pm";
+
+my %PREREQ_PM = (
+ 'Carp' => 0,
+ 'XSLoader' => 0,
+);
+
my %META = (
configure_requires => {
'ExtUtils::MakeMaker' => 0,
@@ -23,7 +33,9 @@ my %META = (
'ExtUtils::MakeMaker' => 0,
'Test::More' => 0,
'constant' => 0,
+ %PREREQ_PM,
},
+ dynamic_config => 1,
resources => {
bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
homepage => "http://search.cpan.org/dist/$dist/",
@@ -33,24 +45,21 @@ my %META = (
);
WriteMakefile(
- NAME => 'Lexical::Types',
- AUTHOR => 'Vincent Pit <perl@profvince.com>',
- LICENSE => 'perl',
- VERSION_FROM => 'lib/Lexical/Types.pm',
- ABSTRACT_FROM => 'lib/Lexical/Types.pm',
- PL_FILES => {},
- @DEFINES,
- PREREQ_PM => {
- 'Carp' => 0,
- 'XSLoader' => 0,
- },
- MIN_PERL_VERSION => 5.008,
- META_MERGE => \%META,
- dist => {
- PREOP => 'pod2text lib/Lexical/Types.pm > $(DISTVNAME)/README',
- COMPRESS => 'gzip -9f', SUFFIX => 'gz'
- },
- clean => {
- FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
- }
+ NAME => $name,
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => $file,
+ ABSTRACT_FROM => $file,
+ PL_FILES => {},
+ @DEFINES,
+ PREREQ_PM => \%PREREQ_PM,
+ MIN_PERL_VERSION => 5.008,
+ META_MERGE => \%META,
+ dist => {
+ PREOP => "pod2text $file > \$(DISTVNAME)/README",
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+ },
+ clean => {
+ FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
+ }
);
@@ -2,7 +2,7 @@ NAME
Lexical::Types - Extend the semantics of typed lexicals.
VERSION
- Version 0.08
+ Version 0.09
SYNOPSIS
{ package Str; }
@@ -228,7 +228,7 @@ ACKNOWLEDGEMENTS
Thanks Florian Ragwitz for suggesting the use of constants for types.
COPYRIGHT & LICENSE
- Copyright 2009 Vincent Pit, all rights reserved.
+ Copyright 2009,2010 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
@@ -35,8 +35,16 @@
# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
#endif
-#ifndef SvIS_FREED
-# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
+#ifndef SvREFCNT_inc_simple_NN
+# define SvREFCNT_inc_simple_NN SvREFCNT_inc
+#endif
+
+#ifndef ENTER_with_name
+# define ENTER_with_name(N) ENTER
+#endif
+
+#ifndef LEAVE_with_name
+# define LEAVE_with_name(N) LEAVE
#endif
/* ... Thread safety and multiplicity ...................................... */
@@ -87,19 +95,39 @@
/* ... Thread-safe hints ................................................... */
-/* If any of those is true, we need to store the hint in a global table. */
-
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
+#if LT_WORKAROUND_REQUIRE_PROPAGATION
typedef struct {
SV *code;
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
- UV requires;
-#endif
+ IV cxreq;
} lt_hint_t;
+#define LT_HINT_STRUCT 1
+
+#define LT_HINT_CODE(H) ((H)->code)
+
+#define LT_HINT_FREE(H) { \
+ lt_hint_t *h = (H); \
+ SvREFCNT_dec(h->code); \
+ PerlMemShared_free(h); \
+}
+
+#else /* LT_WORKAROUND_REQUIRE_PROPAGATION */
+
+typedef SV lt_hint_t;
+
+#define LT_HINT_STRUCT 0
+
+#define LT_HINT_CODE(H) (H)
+
+#define LT_HINT_FREE(H) SvREFCNT_dec(H);
+
+#endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
+
+#if LT_THREADSAFE
+
#define PTABLE_NAME ptable_hints
-#define PTABLE_VAL_FREE(V) { lt_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); }
+#define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
#define pPTBL pTHX
#define pPTBL_ pTHX_
@@ -111,17 +139,15 @@ typedef struct {
#define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
#define ptable_hints_free(T) ptable_hints_free(aTHX_ (T))
-#endif /* LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION */
+#endif /* LT_THREADSAFE */
/* ... Global data ......................................................... */
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
typedef struct {
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
- ptable *tbl; /* It really is a ptable_hints */
-#endif
#if LT_THREADSAFE
+ ptable *tbl; /* It really is a ptable_hints */
tTHX owner;
#endif
SV *default_meth;
@@ -160,15 +186,28 @@ STATIC SV *lt_clone(pTHX_ SV *sv, tTHX owner) {
STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
my_cxt_t *ud = ud_;
lt_hint_t *h1 = ent->val;
- lt_hint_t *h2 = PerlMemShared_malloc(sizeof *h2);
+ lt_hint_t *h2;
- *h2 = *h1;
+ if (ud->owner == aTHX)
+ return;
- if (ud->owner != aTHX)
- h2->code = lt_clone(h1->code, ud->owner);
+#if LT_HINT_STRUCT
- ptable_hints_store(ud->tbl, ent->key, h2);
+ h2 = PerlMemShared_malloc(sizeof *h2);
+ h2->code = lt_clone(h1->code, ud->owner);
SvREFCNT_inc(h2->code);
+#if LT_WORKAROUND_REQUIRE_PROPAGATION
+ h2->cxreq = h1->cxreq;
+#endif
+
+#else /* LT_HINT_STRUCT */
+
+ h2 = lt_clone(h1, ud->owner);
+ SvREFCNT_inc(h2);
+
+#endif /* !LT_HINT_STRUCT */
+
+ ptable_hints_store(ud->tbl, ent->key, h2);
}
STATIC void lt_thread_cleanup(pTHX_ void *);
@@ -192,44 +231,58 @@ STATIC void lt_thread_cleanup(pTHX_ void *ud) {
/* ... Hint tags ........................................................... */
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
-
-STATIC SV *lt_tag(pTHX_ SV *value) {
-#define lt_tag(V) lt_tag(aTHX_ (V))
- lt_hint_t *h;
- dMY_CXT;
+#if LT_WORKAROUND_REQUIRE_PROPAGATION
+STATIC IV lt_require_tag(pTHX) {
+#define lt_require_tag() lt_require_tag(aTHX)
+ const PERL_SI *si;
- value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
+ for (si = PL_curstackinfo; si; si = si->si_prev) {
+ I32 cxix;
- h = PerlMemShared_malloc(sizeof *h);
- h->code = SvREFCNT_inc(value);
+ for (cxix = si->si_cxix; cxix >= 0; --cxix) {
+ const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
- {
- const PERL_SI *si;
- UV requires = 0;
+ if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
+ return PTR2IV(cx);
+ }
+ }
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
+ return PTR2IV(NULL);
+}
+#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
+STATIC SV *lt_tag(pTHX_ SV *value) {
+#define lt_tag(V) lt_tag(aTHX_ (V))
+ lt_hint_t *h;
+ SV *code = NULL;
+ dMY_CXT;
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
- ++requires;
- }
+ if (SvROK(value)) {
+ value = SvRV(value);
+ if (SvTYPE(value) >= SVt_PVCV) {
+ code = value;
+ SvREFCNT_inc_simple_NN(code);
}
-
- h->requires = requires;
}
-#endif
+#if LT_HINT_STRUCT
+ h = PerlMemShared_malloc(sizeof *h);
+ h->code = code;
+# if LT_WORKAROUND_REQUIRE_PROPAGATION
+ h->cxreq = lt_require_tag();
+# endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
+#else /* LT_HINT_STRUCT */
+ h = code;
+#endif /* !LT_HINT_STRUCT */
+
+#if LT_THREADSAFE
/* We only need for the key to be an unique tag for looking up the value later.
* Allocated memory provides convenient unique identifiers, so that's why we
- * use the value pointer as the key itself. */
- ptable_hints_store(MY_CXT.tbl, value, h);
+ * use the hint as the key itself. */
+ ptable_hints_store(MY_CXT.tbl, h, h);
+#endif /* LT_THREADSAFE */
- return newSVuv(PTR2UV(value));
+ return newSViv(PTR2IV(h));
}
STATIC SV *lt_detag(pTHX_ const SV *hint) {
@@ -237,52 +290,21 @@ STATIC SV *lt_detag(pTHX_ const SV *hint) {
lt_hint_t *h;
dMY_CXT;
- if (!(hint && SvOK(hint) && SvIOK(hint)))
+ if (!(hint && SvIOK(hint)))
return NULL;
- h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint)));
-
+ h = INT2PTR(lt_hint_t *, SvIVX(hint));
+#if LT_THREADSAFE
+ h = ptable_fetch(MY_CXT.tbl, h);
+#endif /* LT_THREADSAFE */
#if LT_WORKAROUND_REQUIRE_PROPAGATION
- {
- const PERL_SI *si;
- UV requires = 0;
-
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
-
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
- && ++requires > h->requires)
- return NULL;
- }
- }
- }
-#endif
-
- return h->code;
-}
-
-#else
-
-STATIC SV *lt_tag(pTHX_ SV *value) {
-#define lt_tag(V) lt_tag(aTHX_ (V))
- UV tag = 0;
-
- if (SvOK(value) && SvROK(value)) {
- value = SvRV(value);
- SvREFCNT_inc(value);
- tag = PTR2UV(value);
- }
+ if (lt_require_tag() != h->cxreq)
+ return NULL;
+#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
- return newSVuv(tag);
+ return LT_HINT_CODE(h);
}
-#define lt_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL)
-
-#endif /* LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION */
-
STATIC U32 lt_hash = 0;
STATIC SV *lt_hint(pTHX) {
@@ -328,10 +350,10 @@ typedef struct {
SV *type_pkg;
SV *type_meth;
#endif /* !MULTIPLICITY */
- OP *(*pp_padsv)(pTHX);
+ OP *(*old_pp_padsv)(pTHX);
} lt_op_info;
-STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) {
+STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp_padsv)(pTHX)) {
#define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
lt_op_info *oi;
@@ -384,7 +406,7 @@ STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type
oi->type_meth = type_meth;
#endif /* !MULTIPLICITY */
- oi->pp_padsv = pp_padsv;
+ oi->old_pp_padsv = old_pp_padsv;
#ifdef USE_ITHREADS
MUTEX_UNLOCK(<_op_map_mutex);
@@ -487,7 +509,7 @@ STATIC OP *lt_pp_padsv(pTHX) {
LEAVE;
}
- return CALL_FPTR(oi.pp_padsv)(aTHX);
+ return CALL_FPTR(oi.old_pp_padsv)(aTHX);
}
return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
@@ -565,6 +587,8 @@ STATIC OP *lt_ck_padany(pTHX_ OP *o) {
croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
if (items == 0) {
SvREFCNT_dec(orig_pkg);
+ FREETMPS;
+ LEAVE;
goto skip;
} else {
SV *rsv;
@@ -621,27 +645,72 @@ STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
STATIC U32 lt_initialized = 0;
-/* --- XS ------------------------------------------------------------------ */
+STATIC void lt_teardown(pTHX_ void *root) {
+ dMY_CXT;
-MODULE = Lexical::Types PACKAGE = Lexical::Types
+ if (!lt_initialized)
+ return;
-PROTOTYPES: ENABLE
+#if LT_MULTIPLICITY
+ if (aTHX != root)
+ return;
+#endif
-BOOT:
-{
- if (!lt_initialized++) {
- HV *stash;
+#if LT_THREADSAFE
+ ptable_hints_free(MY_CXT.tbl);
+#endif
+ SvREFCNT_dec(MY_CXT.default_meth);
+ PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_old_ck_padany);
+ lt_old_ck_padany = 0;
+ PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_old_ck_padsv);
+ lt_old_ck_padsv = 0;
+
+ lt_initialized = 0;
+}
+
+STATIC void lt_setup(pTHX) {
+#define lt_setup() lt_setup(aTHX)
+ if (lt_initialized)
+ return;
+
+ {
MY_CXT_INIT;
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
- MY_CXT.tbl = ptable_new();
-#endif
#if LT_THREADSAFE
+ MY_CXT.tbl = ptable_new();
MY_CXT.owner = aTHX;
#endif
MY_CXT.pp_padsv_saved = 0;
MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
SvREADONLY_on(MY_CXT.default_meth);
+ }
+
+ lt_old_ck_padany = PL_check[OP_PADANY];
+ PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
+ lt_old_ck_padsv = PL_check[OP_PADSV];
+ PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_ck_padsv);
+
+#if LT_MULTIPLICITY
+ call_atexit(lt_teardown, aTHX);
+#else
+ call_atexit(lt_teardown, NULL);
+#endif
+
+ lt_initialized = 1;
+}
+
+STATIC U32 lt_booted = 0;
+
+/* --- XS ------------------------------------------------------------------ */
+
+MODULE = Lexical::Types PACKAGE = Lexical::Types
+
+PROTOTYPES: ENABLE
+
+BOOT:
+{
+ if (!lt_booted++) {
+ HV *stash;
lt_op_map = ptable_new();
#ifdef USE_ITHREADS
@@ -650,14 +719,11 @@ BOOT:
PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
- lt_old_ck_padany = PL_check[OP_PADANY];
- PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
- lt_old_ck_padsv = PL_check[OP_PADSV];
- PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_ck_padsv);
-
stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
}
+
+ lt_setup();
}
#if LT_THREADSAFE
@@ -669,7 +735,7 @@ PREINIT:
ptable *t;
int *level;
SV *cloned_default_meth;
-CODE:
+PPCODE:
{
my_cxt_t ud;
dMY_CXT;
@@ -688,10 +754,11 @@ CODE:
{
level = PerlMemShared_malloc(sizeof *level);
*level = 1;
- LEAVE;
+ LEAVE_with_name("sub");
SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
- ENTER;
+ ENTER_with_name("sub");
}
+ XSRETURN(0);
#endif
@@ -13,13 +13,13 @@ Lexical::Types - Extend the semantics of typed lexicals.
=head1 VERSION
-Version 0.08
+Version 0.09
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.08';
+ $VERSION = '0.09';
}
=head1 SYNOPSIS
@@ -298,7 +298,7 @@ Thanks Florian Ragwitz for suggesting the use of constants for types.
=head1 COPYRIGHT & LICENSE
-Copyright 2009 Vincent Pit, all rights reserved.
+Copyright 2009,2010 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
@@ -70,8 +70,8 @@ typedef struct ptable_ent {
#ifndef ptable
typedef struct ptable {
ptable_ent **ary;
- UV max;
- UV items;
+ size_t max;
+ size_t items;
} ptable;
#define ptable ptable
#endif /* !ptable */
@@ -80,7 +80,7 @@ typedef struct ptable {
STATIC ptable *ptable_new(pPTBLMS) {
#define ptable_new() ptable_new(aPTBLMS)
ptable *t = PerlMemShared_malloc(sizeof *t);
- t->max = 127;
+ t->max = 15;
t->items = 0;
t->ary = PerlMemShared_calloc(t->max + 1, sizeof *t->ary);
return t;
@@ -121,9 +121,9 @@ STATIC void *ptable_fetch(const ptable * const t, const void * const key) {
STATIC void ptable_split(pPTBLMS_ ptable * const t) {
#define ptable_split(T) ptable_split(aPTBLMS_ (T))
ptable_ent **ary = t->ary;
- const UV oldsize = t->max + 1;
- UV newsize = oldsize * 2;
- UV i;
+ const size_t oldsize = t->max + 1;
+ size_t newsize = oldsize * 2;
+ size_t i;
ary = PerlMemShared_realloc(ary, newsize * sizeof(*ary));
Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary));
@@ -156,7 +156,7 @@ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const ke
PTABLE_VAL_FREE(oldval);
ent->val = val;
} else if (val) {
- const UV i = PTABLE_HASH(key) & t->max;
+ const size_t i = PTABLE_HASH(key) & t->max;
ent = PerlMemShared_malloc(sizeof *ent);
ent->key = key;
ent->val = val;
@@ -173,7 +173,7 @@ STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent
#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
if (t && t->items) {
register ptable_ent ** const array = t->ary;
- UV i = t->max;
+ size_t i = t->max;
do {
ptable_ent *entry;
for (entry = array[i]; entry; entry = entry->next)
@@ -186,7 +186,7 @@ STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent
STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) {
if (t && t->items) {
register ptable_ent ** const array = t->ary;
- UV i = t->max;
+ size_t i = t->max;
do {
ptable_ent *entry = array[i];
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => (1 + 2) + (1 + 4);
+use Test::More tests => (1 + 2) + (1 + 4) + (3 + 3);
sub Int::TYPEDSCALAR { join ':', (caller 0)[1, 2] }
@@ -20,3 +20,28 @@ use lib 't/lib';
eval 'use Lexical::Types; use Lexical::Types::TestRequired2';
is $@, '', 'second require test didn\'t croak prematurely';
}
+
+{
+ my (@decls, @w);
+ sub cb3 { push @decls, $_[0]; @_ }
+ {
+ no strict 'refs';
+ *{"Int3$_\::TYPEDSCALAR"} = \&Int::TYPEDSCALAR for qw/X Y Z/;
+ }
+ local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
+ eval <<' TESTREQUIRED3';
+ {
+ package Lexical::Types::TestRequired3Z;
+ use Lexical::Types as => \&main::cb3;
+ use Lexical::Types::TestRequired3X;
+ use Lexical::Types::TestRequired3Y;
+ my Int3Z $z;
+ ::is($z, __FILE__.':6', 'pragma in use at the end');
+ }
+ TESTREQUIRED3
+ @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
+ is $@, '', 'third require test didn\'t croak prematurely';
+ is_deeply \@w, [ ], 'third require test didn\'t warn';
+ is_deeply \@decls, [ map "Int3$_", qw/X Z/ ],
+ 'third require test propagated in the right scopes';
+}
@@ -0,0 +1,62 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Config qw/%Config/;
+
+BEGIN {
+ if (!$Config{useithreads}) {
+ require Test::More;
+ Test::More->import;
+ plan(skip_all => 'This perl wasn\'t built to support threads');
+ }
+}
+
+use threads;
+
+use Test::More;
+
+BEGIN {
+ require Lexical::Types;
+ if (Lexical::Types::LT_THREADSAFE()) {
+ plan tests => 1;
+ defined and diag "Using threads $_" for $threads::VERSION;
+ } else {
+ plan skip_all => 'This Lexical::Types isn\'t thread safe';
+ }
+}
+
+sub run_perl {
+ my $code = shift;
+
+ local %ENV;
+ system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
+}
+
+SKIP:
+{
+ skip 'Fails on 5.8.2 and lower' => 1 if $] <= 5.008002;
+
+ my $status = run_perl <<' RUN';
+ { package IntX; package IntY; package IntZ; }
+ my ($code, @expected);
+ sub cb {
+ my $e = shift(@expected) || q{DUMMY};
+ --$code if $_[0] eq $e;
+ ()
+ }
+ use threads;
+ $code = threads->create(sub {
+ $code = @expected = qw/IntX/;
+ eval q{use Lexical::Types as => \&cb; my IntX $x;}; die if $@;
+ return $code;
+ })->join;
+ $code += @expected = qw/IntZ/;
+ eval q{my IntY $y;}; die if $@;
+ eval q{use Lexical::Types as => \&cb; my IntZ $z;}; die if $@;
+ $code += 256 if $code < 0;
+ exit $code;
+ RUN
+ is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault';
+}
@@ -5,5 +5,17 @@ use warnings;
use Test::More;
-eval { require Test::Kwalitee; Test::Kwalitee->import() };
-plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
+eval { require Test::Kwalitee; };
+plan(skip_all => 'Test::Kwalitee not installed') if $@;
+
+SKIP: {
+ eval { Test::Kwalitee->import(); };
+ if (my $err = $@) {
+ 1 while chomp $err;
+ require Test::Builder;
+ my $Test = Test::Builder->new;
+ my $plan = $Test->has_plan;
+ $Test->skip_all($err) if not defined $plan or $plan eq 'no_plan';
+ skip $err => $plan - $Test->current_test;
+ }
+}
@@ -0,0 +1,9 @@
+package Lexical::Types::TestRequired3X;
+
+use Lexical::Types as => \&main::cb3;
+
+my Int3X $x;
+Test::More::is($x, __FILE__.':'.(__LINE__-1),
+ 'pragma in use after double setup');
+
+1;
@@ -0,0 +1,6 @@
+package Lexical::Types::TestRequired3Y;
+
+my Int3Y $y;
+Test::More::is($y, undef, 'pragma not in use in require after double setup');
+
+1;