@@ -1,5 +1,29 @@
Revision history for indirect
+0.35 2015-04-06 22:20 UTC
+ + Fix : The module could end being disabled in one thread if it was
+ first loaded in another thread and that thread was immediately
+ terminated. This is now fixed and should address test failures
+ of t//09-load-threads.t and t/42-threads-global.t.
+
+0.34 2015-04-02 19:50 UTC
+ + Chg : The new environment variable to enable thread tests on older
+ perls is PERL_FORCE_TEST_THREADS. Note that this variable
+ should only be turned on by authors.
+ + Fix : [RT #100068] : add link to historical tchrist post
+ The link has been added to the documentation. Thanks Olivier
+ Mengué for reporting.
+ + Fix : Segfaults when the module is loaded by several threads (or
+ Windows emulated processes) ran in parallel.
+ + Fix : Update the Windows ActivePerl + gcc 3.4 workaround for
+ ExtUtils::MakeMaker 7.04. Thanks Christian Walde for reporting
+ and feedback on this issue.
+ + Fix : Be really compatible with the optional OP_PARENT feature.
+ + Tst : $ENV{$Config{ldlibpthname}} is now preserved on all platforms,
+ which will address failures of t/41-threads-teardown.t and
+ t/50-external.t with unusual compilers (like icc) that link all
+ their compiled objects to their own libraries.
+
0.33 2014-09-29 20:20 UTC
+ Fix : [RT #99083] : Breaks eval in an END block in Win32 pseudo-forks.
Thanks Graham Knop for reporting.
@@ -9,6 +9,7 @@ lib/indirect.pm
ptable.h
samples/indirect.pl
t/00-load.t
+t/09-load-threads.t
t/10-args.t
t/11-line.t
t/12-env.t
@@ -50,4 +51,3 @@ t/lib/indirect/TestRequired5/c0.pm
t/lib/indirect/TestRequired5/d0.pm
t/lib/indirect/TestRequired6.pm
t/lib/indirect/TestRequiredGlobal.pm
-t/lib/indirect/TestThreads.pm
@@ -4,7 +4,7 @@
"Vincent Pit <perl@profvince.com>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690",
+ "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001",
"license" : [
"perl_5"
],
@@ -25,6 +25,7 @@
"Carp" : "0",
"Config" : "0",
"ExtUtils::MakeMaker" : "0",
+ "POSIX" : "0",
"Test::More" : "0",
"XSLoader" : "0"
}
@@ -56,5 +57,5 @@
"url" : "http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git"
}
},
- "version" : "0.33"
+ "version" : "0.35"
}
@@ -6,13 +6,14 @@ build_requires:
Carp: '0'
Config: '0'
ExtUtils::MakeMaker: '0'
+ POSIX: '0'
Test::More: '0'
XSLoader: '0'
configure_requires:
Config: '0'
ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690'
+generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -31,4 +32,4 @@ resources:
homepage: http://search.cpan.org/dist/indirect/
license: http://dev.perl.org/licenses/
repository: http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git
-version: '0.33'
+version: '0.35'
@@ -23,7 +23,16 @@ if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) {
@Config{qw<bin sitebin>};
$macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl";
$macro{LDFLAGS} = "$ldflags $libdirs $libperl";
- $macro{PERL_ARCHIVE} = '',
+ eval <<' MY_SECTION';
+ package MY;
+ sub dynamic_lib {
+ my $self = shift;
+ my $inherited = $self->SUPER::dynamic_lib(@_);
+ $inherited =~ s/"?\$\(PERL_ARCHIVE\)"?//g;
+ return $inherited;
+ }
+ MY_SECTION
+ die $@ if $@;
}
}
print $is_gcc_34 ? "yes\n" : "no\n";
@@ -56,6 +65,7 @@ my %PREREQ_PM = (
my %BUILD_REQUIRES =(
'Config' => 0,
'ExtUtils::MakeMaker' => 0,
+ 'POSIX' => 0,
'Test::More' => 0,
%PREREQ_PM,
);
@@ -2,7 +2,7 @@ NAME
indirect - Lexically warn about using the indirect method call syntax.
VERSION
- Version 0.33
+ Version 0.35
SYNOPSIS
In a script :
@@ -41,10 +41,9 @@ DESCRIPTION
The indirect syntax is now considered harmful, since its parsing has
many quirks and its use is error prone : when the subroutine "foo" has
not been declared in the current package, "foo $x" actually compiles to
- "$x->foo", and "foo { key => 1 }" to "'key'->foo(1)". In
- <http://www.shadowcat.co.uk/blog/matt-s-trout/indirect-but-still-fatal>,
- Matt S. Trout gives an example of an undesirable indirect method call on
- a block that can cause a particularly bewildering error.
+ "$x->foo", and "foo { key => 1 }" to "'key'->foo(1)". Please refer to
+ the "REFERENCES" section for a more complete list of reasons for
+ avoiding this construct.
This pragma currently does not warn for core functions ("print", "say",
"exec" or "system"). This may change in the future, or may be added as
@@ -177,6 +176,24 @@ CAVEATS
The search for indirect method calls happens before constant folding.
Hence "my $x = new Class if 0" will be caught.
+REFERENCES
+ Numerous articles have been written about the quirks of the indirect
+ object construct :
+
+ * <http://markmail.org/message/o7d5sxnydya7bwvv> : Far More Than
+ Everything You've Ever Wanted to Know about the Indirect Object
+ syntax, Tom Christiansen, 1998-01-28.
+
+ This historical post to the "perl5-porters" mailing list raised
+ awareness about the perils of this syntax.
+
+ * <http://www.shadowcat.co.uk/blog/matt-s-trout/indirect-but-still-fat
+ al> : Indirect but still fatal, Matt S. Trout, 2009-07-29.
+
+ In this blog post, the author gives an example of an undesirable
+ indirect method call on a block that causes a particularly
+ bewildering error.
+
DEPENDENCIES
perl 5.8.1.
@@ -212,8 +229,8 @@ ACKNOWLEDGEMENTS
reporting issues.
COPYRIGHT & LICENSE
- Copyright 2008,2009,2010,2011,2012,2013,2014 Vincent Pit, all rights
- reserved.
+ Copyright 2008,2009,2010,2011,2012,2013,2014,2015 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.
@@ -63,8 +63,12 @@
# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
#endif
-#ifndef OP_SIBLING
-# define OP_SIBLING(O) ((O)->op_sibling)
+#ifndef OpSIBLING
+# ifdef OP_SIBLING
+# define OpSIBLING(O) OP_SIBLING(O)
+# else
+# define OpSIBLING(O) ((O)->op_sibling)
+# endif
#endif
#define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
@@ -109,12 +113,17 @@
#endif
#ifndef I_MULTIPLICITY
-# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
+# if defined(MULTIPLICITY)
# define I_MULTIPLICITY 1
# else
# define I_MULTIPLICITY 0
# endif
#endif
+#if I_MULTIPLICITY
+# ifndef PERL_IMPLICIT_CONTEXT
+# error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
+# endif
+#endif
#if I_MULTIPLICITY && !defined(tTHX)
# define tTHX PerlInterpreter*
#endif
@@ -135,19 +144,40 @@
# undef MY_CXT
# define MY_CXT indirect_globaldata
# undef START_MY_CXT
-# define START_MY_CXT STATIC my_cxt_t MY_CXT;
+# define START_MY_CXT static my_cxt_t MY_CXT;
# undef MY_CXT_INIT
# define MY_CXT_INIT NOOP
# undef MY_CXT_CLONE
# define MY_CXT_CLONE NOOP
#endif
+#if I_THREADSAFE
+/* We must use preexistent global mutexes or we will never be able to destroy
+ * them. */
+# if I_HAS_PERL(5, 9, 3)
+# define I_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex)
+# define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
+# else
+# define I_LOADED_LOCK OP_REFCNT_LOCK
+# define I_LOADED_UNLOCK OP_REFCNT_UNLOCK
+# endif
+#else
+# define I_LOADED_LOCK NOOP
+# define I_LOADED_UNLOCK NOOP
+#endif
+
#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
-# define I_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK
-# define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
+# define I_CHECK_LOCK OP_CHECK_MUTEX_LOCK
+# define I_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
+#elif I_HAS_PERL(5, 9, 3)
+# define I_CHECK_LOCK OP_REFCNT_LOCK
+# define I_CHECK_UNLOCK OP_REFCNT_UNLOCK
#else
-# define I_CHECK_MUTEX_LOCK OP_REFCNT_LOCK
-# define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
+/* Before perl 5.9.3, indirect_ck_*() calls are already protected by the
+ * I_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't
+ * lock it twice. */
+# define I_CHECK_LOCK NOOP
+# define I_CHECK_UNLOCK NOOP
#endif
typedef OP *(*indirect_ck_t)(pTHX_ OP *);
@@ -158,30 +188,103 @@ typedef OP *(*indirect_ck_t)(pTHX_ OP *);
#else
-STATIC void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) {
+static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) {
#define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP))
- I_CHECK_MUTEX_LOCK;
+ I_CHECK_LOCK;
if (!*old_ck_p) {
*old_ck_p = PL_check[type];
PL_check[type] = new_ck;
}
- I_CHECK_MUTEX_UNLOCK;
+ I_CHECK_UNLOCK;
}
#endif
-STATIC void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) {
+static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) {
#define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP))
- I_CHECK_MUTEX_LOCK;
+ I_CHECK_LOCK;
if (*old_ck_p) {
PL_check[type] = *old_ck_p;
*old_ck_p = 0;
}
- I_CHECK_MUTEX_UNLOCK;
+ I_CHECK_UNLOCK;
}
/* --- Helpers ------------------------------------------------------------- */
+/* ... Check if the module is loaded ....................................... */
+
+static I32 indirect_loaded = 0;
+
+#if I_THREADSAFE
+
+#define PTABLE_NAME ptable_loaded
+#define PTABLE_VAL_FREE(V) NOOP
+
+#include "ptable.h"
+
+#define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V))
+#define ptable_loaded_delete(T, K) ptable_loaded_delete(aPTBLMS_ (T), (K))
+#define ptable_loaded_free(T) ptable_loaded_free(aPTBLMS_ (T))
+
+static ptable *indirect_loaded_cxts = NULL;
+
+static int indirect_is_loaded(pTHX_ void *cxt) {
+#define indirect_is_loaded(C) indirect_is_loaded(aTHX_ (C))
+ int res = 0;
+
+ I_LOADED_LOCK;
+ if (indirect_loaded_cxts && ptable_fetch(indirect_loaded_cxts, cxt))
+ res = 1;
+ I_LOADED_UNLOCK;
+
+ return res;
+}
+
+static int indirect_set_loaded_locked(pTHX_ void *cxt) {
+#define indirect_set_loaded_locked(C) indirect_set_loaded_locked(aTHX_ (C))
+ int global_setup = 0;
+
+ if (indirect_loaded <= 0) {
+ assert(indirect_loaded == 0);
+ assert(!indirect_loaded_cxts);
+ indirect_loaded_cxts = ptable_new();
+ global_setup = 1;
+ }
+ ++indirect_loaded;
+ assert(indirect_loaded_cxts);
+ ptable_loaded_store(indirect_loaded_cxts, cxt, cxt);
+
+ return global_setup;
+}
+
+static int indirect_clear_loaded_locked(pTHX_ void *cxt) {
+#define indirect_clear_loaded_locked(C) indirect_clear_loaded_locked(aTHX_ (C))
+ int global_teardown = 0;
+
+ if (indirect_loaded > 1) {
+ assert(indirect_loaded_cxts);
+ ptable_loaded_delete(indirect_loaded_cxts, cxt);
+ --indirect_loaded;
+ } else if (indirect_loaded_cxts) {
+ assert(indirect_loaded == 1);
+ ptable_loaded_free(indirect_loaded_cxts);
+ indirect_loaded_cxts = NULL;
+ indirect_loaded = 0;
+ global_teardown = 1;
+ }
+
+ return global_teardown;
+}
+
+#else
+
+#define indirect_is_loaded(C) (indirect_loaded > 0)
+#define indirect_set_loaded_locked(C) ((indirect_loaded++ <= 0) ? 1 : 0)
+#define indirect_clear_loaded_locked(C) ((--indirect_loaded <= 0) ? 1 : 0)
+
+#endif
+
/* ... Thread-safe hints ................................................... */
#if I_WORKAROUND_REQUIRE_PROPAGATION
@@ -296,7 +399,7 @@ typedef struct {
# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
#endif
-STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
+static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
indirect_ptable_clone_ud *ud = ud_;
indirect_hint_t *h1 = ent->val;
indirect_hint_t *h2;
@@ -318,24 +421,30 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
ptable_hints_store(ud->tbl, ent->key, h2);
}
-STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
+static void indirect_thread_cleanup(pTHX_ void *ud) {
+ int global_teardown;
dMY_CXT;
+ global_teardown = indirect_clear_loaded_locked(&MY_CXT);
+ assert(!global_teardown);
+
SvREFCNT_dec(MY_CXT.global_code);
MY_CXT.global_code = NULL;
+
ptable_free(MY_CXT.map);
MY_CXT.map = NULL;
+
ptable_hints_free(MY_CXT.tbl);
MY_CXT.tbl = NULL;
}
-STATIC int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) {
+static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) {
SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL);
return 0;
}
-STATIC MGVTBL indirect_endav_vtbl = {
+static MGVTBL indirect_endav_vtbl = {
0,
0,
0,
@@ -355,7 +464,7 @@ STATIC MGVTBL indirect_endav_vtbl = {
#endif /* I_THREADSAFE */
#if I_WORKAROUND_REQUIRE_PROPAGATION
-STATIC IV indirect_require_tag(pTHX) {
+static IV indirect_require_tag(pTHX) {
#define indirect_require_tag() indirect_require_tag(aTHX)
const CV *cv, *outside;
@@ -400,7 +509,7 @@ get_enclosing_cv:
}
#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
-STATIC SV *indirect_tag(pTHX_ SV *value) {
+static SV *indirect_tag(pTHX_ SV *value) {
#define indirect_tag(V) indirect_tag(aTHX_ (V))
indirect_hint_t *h;
SV *code = NULL;
@@ -439,7 +548,7 @@ STATIC SV *indirect_tag(pTHX_ SV *value) {
return newSViv(PTR2IV(h));
}
-STATIC SV *indirect_detag(pTHX_ const SV *hint) {
+static SV *indirect_detag(pTHX_ const SV *hint) {
#define indirect_detag(H) indirect_detag(aTHX_ (H))
indirect_hint_t *h;
#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
@@ -464,9 +573,9 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) {
return I_HINT_CODE(h);
}
-STATIC U32 indirect_hash = 0;
+static VOL U32 indirect_hash = 0;
-STATIC SV *indirect_hint(pTHX) {
+static SV *indirect_hint(pTHX) {
#define indirect_hint() indirect_hint(aTHX)
SV *hint = NULL;
@@ -495,17 +604,20 @@ STATIC SV *indirect_hint(pTHX) {
}
#endif
- if (hint && SvIOK(hint))
+ if (hint && SvIOK(hint)) {
return indirect_detag(hint);
- else {
+ } else {
dMY_CXT;
- return MY_CXT.global_code;
+ if (indirect_is_loaded(&MY_CXT))
+ return MY_CXT.global_code;
+ else
+ return NULL;
}
}
/* ... op -> source position ............................................... */
-STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) {
+static void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) {
#define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L))
indirect_op_info_t *oi;
const char *s;
@@ -541,7 +653,7 @@ STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t lin
oi->line = line;
}
-STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
+static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
#define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
dMY_CXT;
@@ -551,17 +663,17 @@ STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
return ptable_fetch(MY_CXT.map, o);
}
-STATIC void indirect_map_delete(pTHX_ const OP *o) {
+static void indirect_map_delete(pTHX_ const OP *o) {
#define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
dMY_CXT;
- if (MY_CXT.map)
+ if (indirect_is_loaded(&MY_CXT) && MY_CXT.map)
ptable_delete(MY_CXT.map, o);
}
/* --- Check functions ----------------------------------------------------- */
-STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
+static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
#define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP))
STRLEN name_len, line_len;
const char *name, *name_end;
@@ -602,9 +714,9 @@ STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *nam
/* ... ck_const ............................................................ */
-STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_const(pTHX_ OP *o) {
+static OP *indirect_ck_const(pTHX_ OP *o) {
o = indirect_old_ck_const(aTHX_ o);
if (indirect_hint()) {
@@ -646,9 +758,9 @@ STATIC OP *indirect_ck_const(pTHX_ OP *o) {
/* ... ck_rv2sv ............................................................ */
-STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
+static OP *indirect_ck_rv2sv(pTHX_ OP *o) {
if (indirect_hint()) {
OP *op = cUNOPo->op_first;
SV *sv;
@@ -713,9 +825,9 @@ done:
/* ... ck_padany ........................................................... */
-STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
+static OP *indirect_ck_padany(pTHX_ OP *o) {
o = indirect_old_ck_padany(aTHX_ o);
if (indirect_hint()) {
@@ -740,10 +852,10 @@ STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
/* ... ck_scope ............................................................ */
-STATIC OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0;
-STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
+static OP *indirect_ck_scope(pTHX_ OP *o) {
OP *(*old_ck)(pTHX_ OP *) = 0;
switch (o->op_type) {
@@ -767,9 +879,9 @@ STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
/* ... ck_method ........................................................... */
-STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_method(pTHX_ OP *o) {
+static OP *indirect_ck_method(pTHX_ OP *o) {
if (indirect_hint()) {
OP *op = cUNOPo->op_first;
@@ -810,9 +922,9 @@ done:
/* "use foo/no foo" compiles its call to import/unimport directly to a
* method_named op. */
-STATIC OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_method_named(pTHX_ OP *o) {
+static OP *indirect_ck_method_named(pTHX_ OP *o) {
if (indirect_hint()) {
STRLEN pos;
line_t line;
@@ -842,9 +954,9 @@ done:
/* ... ck_entersub ......................................................... */
-STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
+static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
-STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
+static OP *indirect_ck_entersub(pTHX_ OP *o) {
SV *code = indirect_hint();
o = indirect_old_ck_entersub(aTHX_ o);
@@ -861,7 +973,7 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
goto done;
oop = lop->op_first;
} while (oop->op_type != OP_PUSHMARK);
- oop = OP_SIBLING(oop);
+ oop = OpSIBLING(oop);
mop = lop->op_last;
if (!oop)
@@ -929,79 +1041,96 @@ done:
return o;
}
-STATIC U32 indirect_initialized = 0;
+/* --- Module setup/teardown ----------------------------------------------- */
-STATIC void indirect_teardown(pTHX_ void *root) {
- if (!indirect_initialized)
- return;
+static void indirect_teardown(pTHX_ void *interp) {
+ dMY_CXT;
#if I_MULTIPLICITY
- if (aTHX != root)
+ if (aTHX != interp)
return;
#endif
- {
- dMY_CXT;
- ptable_free(MY_CXT.map);
- MY_CXT.map = NULL;
-#if I_THREADSAFE
- ptable_hints_free(MY_CXT.tbl);
- MY_CXT.tbl = NULL;
-#endif
+ I_LOADED_LOCK;
+
+ if (indirect_clear_loaded_locked(&MY_CXT)) {
+ indirect_ck_restore(OP_CONST, &indirect_old_ck_const);
+ indirect_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv);
+ indirect_ck_restore(OP_PADANY, &indirect_old_ck_padany);
+ indirect_ck_restore(OP_SCOPE, &indirect_old_ck_scope);
+ indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq);
+
+ indirect_ck_restore(OP_METHOD, &indirect_old_ck_method);
+ indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named);
+ indirect_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub);
}
- indirect_ck_restore(OP_CONST, &indirect_old_ck_const);
- indirect_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv);
- indirect_ck_restore(OP_PADANY, &indirect_old_ck_padany);
- indirect_ck_restore(OP_SCOPE, &indirect_old_ck_scope);
- indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq);
+ I_LOADED_UNLOCK;
+
+ SvREFCNT_dec(MY_CXT.global_code);
+ MY_CXT.global_code = NULL;
+
+ ptable_free(MY_CXT.map);
+ MY_CXT.map = NULL;
- indirect_ck_restore(OP_METHOD, &indirect_old_ck_method);
- indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named);
- indirect_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub);
+#if I_THREADSAFE
+ ptable_hints_free(MY_CXT.tbl);
+ MY_CXT.tbl = NULL;
+#endif
- indirect_initialized = 0;
+ return;
}
-STATIC void indirect_setup(pTHX) {
+static void indirect_setup(pTHX) {
#define indirect_setup() indirect_setup(aTHX)
- if (indirect_initialized)
- return;
+ MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */
+
+ I_LOADED_LOCK;
+
+ if (indirect_set_loaded_locked(&MY_CXT)) {
+ PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
+
+ indirect_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const);
+ indirect_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv);
+ indirect_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany);
+ indirect_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope);
+ indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq);
+
+ indirect_ck_replace(OP_METHOD, indirect_ck_method,
+ &indirect_old_ck_method);
+ indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
+ &indirect_old_ck_method_named);
+ indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub,
+ &indirect_old_ck_entersub);
+ }
+
+ I_LOADED_UNLOCK;
{
- MY_CXT_INIT;
+ HV *stash;
+
+ stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
+ newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
+ newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE));
+
#if I_THREADSAFE
MY_CXT.tbl = ptable_new();
MY_CXT.owner = aTHX;
#endif
+
MY_CXT.map = ptable_new();
MY_CXT.global_code = NULL;
}
- indirect_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const);
- indirect_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv);
- indirect_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany);
- indirect_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope);
- indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq);
-
- indirect_ck_replace(OP_METHOD, indirect_ck_method,
- &indirect_old_ck_method);
- indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
- &indirect_old_ck_method_named);
- indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub,
- &indirect_old_ck_entersub);
-
#if I_MULTIPLICITY
call_atexit(indirect_teardown, aTHX);
#else
call_atexit(indirect_teardown, NULL);
#endif
- indirect_initialized = 1;
+ return;
}
-STATIC U32 indirect_booted = 0;
-
/* --- XS ------------------------------------------------------------------ */
MODULE = indirect PACKAGE = indirect
@@ -1010,16 +1139,6 @@ PROTOTYPES: ENABLE
BOOT:
{
- if (!indirect_booted++) {
- HV *stash;
-
- PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
-
- stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
- newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
- newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE));
- }
-
indirect_setup();
}
@@ -1048,6 +1167,13 @@ PPCODE:
MY_CXT.tbl = t;
MY_CXT.owner = aTHX;
MY_CXT.global_code = global_code_dup;
+ {
+ int global_setup;
+ I_LOADED_LOCK;
+ global_setup = indirect_set_loaded_locked(&MY_CXT);
+ assert(!global_setup);
+ I_LOADED_UNLOCK;
+ }
}
gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
if (gv) {
@@ -11,13 +11,13 @@ indirect - Lexically warn about using the indirect method call syntax.
=head1 VERSION
-Version 0.33
+Version 0.35
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.33';
+ $VERSION = '0.35';
}
=head1 SYNOPSIS
@@ -56,7 +56,7 @@ Global uses :
When enabled, this pragma warns about indirect method calls that are present in your code.
The indirect syntax is now considered harmful, since its parsing has many quirks and its use is error prone : when the subroutine C<foo> has not been declared in the current package, C<foo $x> actually compiles to C<< $x->foo >>, and C<< foo { key => 1 } >> to C<< 'key'->foo(1) >>.
-In L<http://www.shadowcat.co.uk/blog/matt-s-trout/indirect-but-still-fatal>, Matt S. Trout gives an example of an undesirable indirect method call on a block that can cause a particularly bewildering error.
+Please refer to the L</REFERENCES> section for a more complete list of reasons for avoiding this construct.
This pragma currently does not warn for core functions (C<print>, C<say>, C<exec> or C<system>).
This may change in the future, or may be added as optional features that would be enabled by passing options to C<unimport>.
@@ -255,6 +255,26 @@ Indirect constructs that appear in code C<eval>'d during the global destruction
The search for indirect method calls happens before constant folding.
Hence C<my $x = new Class if 0> will be caught.
+=head1 REFERENCES
+
+Numerous articles have been written about the quirks of the indirect object construct :
+
+=over 4
+
+=item *
+
+L<http://markmail.org/message/o7d5sxnydya7bwvv> : B<Far More Than Everything You've Ever Wanted to Know about the Indirect Object syntax>, Tom Christiansen, 1998-01-28.
+
+This historical post to the C<perl5-porters> mailing list raised awareness about the perils of this syntax.
+
+=item *
+
+L<http://www.shadowcat.co.uk/blog/matt-s-trout/indirect-but-still-fatal> : B<Indirect but still fatal>, Matt S. Trout, 2009-07-29.
+
+In this blog post, the author gives an example of an undesirable indirect method call on a block that causes a particularly bewildering error.
+
+=back
+
=head1 DEPENDENCIES
L<perl> 5.8.1.
@@ -291,7 +311,7 @@ Andrew Main and Florian Ragwitz, for testing on real-life code and reporting iss
=head1 COPYRIGHT & LICENSE
-Copyright 2008,2009,2010,2011,2012,2013,2014 Vincent Pit, all rights reserved.
+Copyright 2008,2009,2010,2011,2012,2013,2014,2015 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.
@@ -0,0 +1,327 @@
+#!perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+use VPIT::TestHelpers;
+
+BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
+
+my ($module, $thread_safe_var);
+BEGIN {
+ $module = 'indirect';
+ $thread_safe_var = 'indirect::I_THREADSAFE()';
+}
+
+sub load_test {
+ my $res;
+ if (defined &indirect::msg) {
+ local $@;
+ eval 'BEGIN { indirect->unimport(":fatal") if defined &indirect::msg } return; my $x = new X;';
+ $res = $@;
+ }
+ if (defined $res and $res =~ /^Indirect call of method/) {
+ return 1;
+ } elsif (not defined $res or $res eq '') {
+ return 0;
+ } else {
+ return $res;
+ }
+}
+
+# Keep the rest of the file untouched
+
+BEGIN {
+ my $is_threadsafe;
+
+ if (defined $thread_safe_var) {
+ my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())";
+ if (defined $stat) {
+ require POSIX;
+ my $res = $stat >> 8;
+ if ($res == POSIX::EXIT_SUCCESS()) {
+ $is_threadsafe = 1;
+ } elsif ($res == POSIX::EXIT_FAILURE()) {
+ $is_threadsafe = !1;
+ }
+ }
+ if (not defined $is_threadsafe) {
+ skip_all "Could not detect if $module is thread safe or not";
+ }
+ }
+
+ VPIT::TestHelpers->import(
+ threads => [ $module => $is_threadsafe ],
+ )
+}
+
+my $could_not_create_thread = 'Could not create thread';
+
+use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (2 * 4 + 1) * 2 + 1;
+
+sub is_loaded {
+ my ($affirmative, $desc) = @_;
+
+ my $res = load_test();
+
+ my $expected;
+ if ($affirmative) {
+ $expected = 1;
+ $desc = "$desc: module loaded";
+ } else {
+ $expected = 0;
+ $desc = "$desc: module not loaded";
+ }
+
+ unless (is $res, $expected, $desc) {
+ $res = defined $res ? "'$res'" : 'undef';
+ $expected = "'$expected'";
+ diag("Test '$desc' failed: got $res, expected $expected");
+ }
+
+ return;
+}
+
+BEGIN {
+ local $@;
+ my $code = eval "sub { require $module }";
+ die $@ if $@;
+ *do_load = $code;
+}
+
+is_loaded 0, 'main body, beginning';
+
+# Test serial loadings
+
+SKIP: {
+ my $thr = spawn(sub {
+ my $here = "first serial thread";
+ is_loaded 0, "$here, beginning";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+
+ return;
+ });
+
+ skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr;
+
+ $thr->join;
+ if (my $err = $thr->error) {
+ die $err;
+ }
+}
+
+is_loaded 0, 'main body, in between serial loadings';
+
+SKIP: {
+ my $thr = spawn(sub {
+ my $here = "second serial thread";
+ is_loaded 0, "$here, beginning";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+
+ return;
+ });
+
+ skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr;
+
+ $thr->join;
+ if (my $err = $thr->error) {
+ die $err;
+ }
+}
+
+is_loaded 0, 'main body, after serial loadings';
+
+# Test nested loadings
+
+SKIP: {
+ my $thr = spawn(sub {
+ my $here = 'parent thread';
+ is_loaded 0, "$here, beginning";
+
+ SKIP: {
+ my $kid = spawn(sub {
+ my $here = 'child thread';
+ is_loaded 0, "$here, beginning";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+
+ return;
+ });
+
+ skip "$could_not_create_thread (nested child)" => 2 unless defined $kid;
+
+ $kid->join;
+ if (my $err = $kid->error) {
+ die "in child thread: $err\n";
+ }
+ }
+
+ is_loaded 0, "$here, after child terminated";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+
+ return;
+ });
+
+ skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $thr;
+
+ $thr->join;
+ if (my $err = $thr->error) {
+ die $err;
+ }
+}
+
+is_loaded 0, 'main body, after nested loadings';
+
+# Test parallel loadings
+
+use threads;
+use threads::shared;
+
+my $sync_points = 7;
+
+my @locks_down = (1) x $sync_points;
+my @locks_up = (0) x $sync_points;
+share($_) for @locks_down, @locks_up;
+
+my $default_peers = 2;
+
+sub sync_master {
+ my ($id, $peers) = @_;
+
+ $peers = $default_peers unless defined $peers;
+
+ {
+ lock $locks_down[$id];
+ $locks_down[$id] = 0;
+ cond_broadcast $locks_down[$id];
+ }
+
+ {
+ lock $locks_up[$id];
+ cond_wait $locks_up[$id] until $locks_up[$id] == $peers;
+ }
+}
+
+sub sync_slave {
+ my ($id) = @_;
+
+ {
+ lock $locks_down[$id];
+ cond_wait $locks_down[$id] until $locks_down[$id] == 0;
+ }
+
+ {
+ lock $locks_up[$id];
+ $locks_up[$id]++;
+ cond_signal $locks_up[$id];
+ }
+}
+
+for my $first_thread_ends_first (0, 1) {
+ for my $id (0 .. $sync_points - 1) {
+ {
+ lock $locks_down[$id];
+ $locks_down[$id] = 1;
+ }
+ {
+ lock $locks_up[$id];
+ $locks_up[$id] = 0;
+ }
+ }
+
+ my $thr1_end = 'finishes first';
+ my $thr2_end = 'finishes last';
+
+ ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end)
+ unless $first_thread_ends_first;
+
+ SKIP: {
+ my $thr1 = spawn(sub {
+ my $here = "first simultaneous thread ($thr1_end)";
+ sync_slave 0;
+
+ is_loaded 0, "$here, beginning";
+ sync_slave 1;
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+ sync_slave 2;
+ sync_slave 3;
+
+ sync_slave 4;
+ is_loaded 1, "$here, still loaded while also loaded in the other thread";
+ sync_slave 5;
+
+ sync_slave 6 unless $first_thread_ends_first;
+
+ is_loaded 1, "$here, end";
+
+ return;
+ });
+
+ skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
+
+ my $thr2 = spawn(sub {
+ my $here = "second simultaneous thread ($thr2_end)";
+ sync_slave 0;
+
+ is_loaded 0, "$here, beginning";
+ sync_slave 1;
+
+ sync_slave 2;
+ sync_slave 3;
+ is_loaded 0, "$here, loaded in other thread but not here";
+
+ do_load;
+ is_loaded 1, "$here, after loading";
+ sync_slave 4;
+ sync_slave 5;
+
+ sync_slave 6 if $first_thread_ends_first;
+
+ is_loaded 1, "$here, end";
+
+ return;
+ });
+
+ sync_master($_) for 0 .. 5;
+
+ if (defined $thr2) {
+ ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first;
+
+ $thr1->join;
+ if (my $err = $thr1->error) {
+ die $err;
+ }
+
+ sync_master(6, 1);
+
+ $thr2->join;
+ if (my $err = $thr1->error) {
+ die $err;
+ }
+ } else {
+ sync_master(6, 1) unless $first_thread_ends_first;
+
+ $thr1->join;
+ if (my $err = $thr1->error) {
+ die $err;
+ }
+
+ skip "$could_not_create_thread (parallel 2)" => (4 * 1);
+ }
+ }
+
+ is_loaded 0, 'main body, after simultaneous threads';
+}
+
+do_load;
+is_loaded 1, 'main body, loaded at end';
@@ -3,8 +3,12 @@
use strict;
use warnings;
+BEGIN { require indirect; }
+
use lib 't/lib';
-use indirect::TestThreads;
+use VPIT::TestHelpers (
+ threads => [ 'indirect' => indirect::I_THREADSAFE ],
+);
use Test::Leaner;
@@ -3,14 +3,18 @@
use strict;
use warnings;
+BEGIN { require indirect; }
+
use lib 't/lib';
-use VPIT::TestHelpers;
-use indirect::TestThreads;
+use VPIT::TestHelpers (
+ threads => [ 'indirect' => indirect::I_THREADSAFE ],
+);
use Test::Leaner tests => 3;
-SKIP:
-{
+my $run_perl_failed = 'Could not execute perl subprocess';
+
+SKIP: {
skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002;
my $status = run_perl <<' RUN';
@@ -29,10 +33,12 @@ SKIP:
eval q{return; no indirect hook => \&cb; new Z;};
exit $code;
RUN
- is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault';
+ skip $run_perl_failed => 1 unless defined $status;
+ is $status, 0,
+ 'loading the pragma in a thread and using it outside doesn\'t segfault';
}
-{
+SKIP: {
my $status = run_perl <<' RUN';
use threads;
BEGIN { require indirect; }
@@ -44,10 +50,11 @@ SKIP:
})->join;
exit $code;
RUN
+ skip $run_perl_failed => 1 unless defined $status;
is $status, 0, 'indirect can be loaded in eval STRING during global destruction at the end of a thread';
}
-{
+SKIP: {
my $status = run_perl <<' RUN';
use threads;
use threads::shared;
@@ -62,5 +69,6 @@ SKIP:
})->join;
exit $code;
RUN
+ skip $run_perl_failed => 1 unless defined $status;
is $status, 0, 'indirect does not check eval STRING during global destruction at the end of a thread';
}
@@ -3,8 +3,12 @@
use strict;
use warnings;
+BEGIN { require indirect; }
+
use lib 't/lib';
-use indirect::TestThreads;
+use VPIT::TestHelpers (
+ threads => [ 'indirect' => indirect::I_THREADSAFE ],
+);
use Test::Leaner;
@@ -12,34 +12,40 @@ use VPIT::TestHelpers;
BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
-{
+my $run_perl_failed = 'Could not execute perl subprocess';
+
+SKIP: {
my $status = run_perl 'no indirect; qq{a\x{100}b} =~ /\A[\x00-\x7f]*\z/;';
+ skip $run_perl_failed => 1 unless defined $status;
is $status, 0, 'RT #47866';
}
-SKIP:
-{
+SKIP: {
skip 'Fixed in core only since 5.12' => 1 unless "$]" >= 5.012;
+
my $status = run_perl 'no indirect hook => sub { exit 2 }; new X';
+ skip $run_perl_failed => 1 unless defined $status;
is $status, 2 << 8, 'no semicolon at the end of -e';
}
-SKIP:
-{
+SKIP: {
load_or_skip('Devel::CallParser', undef, undef, 1);
+
my $status = run_perl "use Devel::CallParser (); no indirect; sub ok { } ok 1";
+ skip $run_perl_failed => 1 unless defined $status;
is $status, 0, 'indirect is not getting upset by Devel::CallParser';
}
-SKIP:
-{
+SKIP: {
my $has_package_empty = do {
local $@;
eval 'no warnings "deprecated"; package; 1'
};
skip 'Empty package only available on perl 5.8.x and below' => 1
unless $has_package_empty;
+
my $status = run_perl 'no indirect hook => sub { }; exit 0; package; new X;';
+ skip $run_perl_failed => 1 unless defined $status;
is $status, 0, 'indirect does not croak while package empty is in use';
}
@@ -48,8 +54,7 @@ if ($Config::Config{d_fork} or $Config::Config{d_pseudofork}) {
$fork_status = run_perl 'my $pid = fork; exit 1 unless defined $pid; if ($pid) { waitpid $pid, 0; my $status = $?; exit(($status >> 8) || $status) } else { exit 0 }';
}
-SKIP:
-{
+SKIP: {
my $tests = 2;
skip 'fork() or pseudo-forks are required to check END blocks in subprocesses'
=> $tests unless defined $fork_status;
@@ -57,8 +62,10 @@ SKIP:
=> $tests unless $fork_status == 0;
my $status = run_perl 'require indirect; END { eval q[1] } my $pid = fork; exit 0 unless defined $pid; if ($pid) { waitpid $pid, 0; my $status = $?; exit(($status >> 8) || $status) } else { exit 0 }';
+ skip $run_perl_failed => $tests unless defined $status;
is $status, 0, 'indirect and global END blocks executed at the end of a forked process (RT #99083)';
$status = run_perl 'require indirect; my $pid = fork; exit 0 unless defined $pid; if ($pid) { waitpid $pid, 0; my $status = $?; exit(($status >> 8) || $status) } else { eval q[END { eval q(1) }]; exit 0 }';
+ skip $run_perl_failed => ($tests - 1) unless defined $status;
is $status, 0, 'indirect and local END blocks executed at the end of a forked process';
}
@@ -5,20 +5,56 @@ use warnings;
use Config ();
-my %exports = (
+sub export_to_pkg {
+ my ($subs, $pkg) = @_;
+
+ while (my ($name, $code) = each %$subs) {
+ no strict 'refs';
+ *{$pkg.'::'.$name} = $code;
+ }
+
+ return 1;
+}
+
+my %default_exports = (
load_or_skip => \&load_or_skip,
load_or_skip_all => \&load_or_skip_all,
run_perl => \&run_perl,
skip_all => \&skip_all,
);
+my %features = (
+ threads => \&init_threads,
+ usleep => \&init_usleep,
+);
+
sub import {
- my $pkg = caller;
+ shift;
+ my @opts = @_;
- while (my ($name, $code) = each %exports) {
- no strict 'refs';
- *{$pkg.'::'.$name} = $code;
+ my %exports = %default_exports;
+
+ for (my $i = 0; $i <= $#opts; ++$i) {
+ my $feature = $opts[$i];
+ next unless defined $feature;
+
+ my $args;
+ if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') {
+ ++$i;
+ $args = $opts[$i];
+ } else {
+ $args = [ ];
+ }
+
+ my $handler = $features{$feature};
+ die "Unknown feature '$feature'" unless defined $handler;
+
+ my %syms = $handler->(@$args);
+
+ $exports{$_} = $syms{$_} for sort keys %syms;
}
+
+ export_to_pkg \%exports => scalar caller;
}
my $test_sub = sub {
@@ -108,16 +144,86 @@ sub load_or_skip_all {
sub run_perl {
my $code = shift;
+ if ($code =~ /"/) {
+ die 'Double quotes in evaluated code are not portable';
+ }
+
my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>};
my $ld_name = $Config::Config{ldlibpthname};
my $ldlibpth = $ENV{$ld_name};
local %ENV;
+ $ENV{$ld_name} = $ldlibpth if defined $ldlibpth;
$ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
$ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH;
- $ENV{$ld_name} = $ldlibpth if $^O eq 'android' and defined $ldlibpth;
- system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
+ my $perl = $^X;
+ unless (-e $perl and -x $perl) {
+ $perl = $Config::Config{perlpath};
+ unless (-e $perl and -x $perl) {
+ return undef;
+ }
+ }
+
+ system { $perl } $perl, '-T', map("-I$_", @INC), '-e', $code;
+}
+
+sub init_threads {
+ my ($pkg, $threadsafe, $force_var) = @_;
+
+ skip_all 'This perl wasn\'t built to support threads'
+ unless $Config::Config{useithreads};
+
+ $pkg = 'package' unless defined $pkg;
+ skip_all "This $pkg isn't thread safe" if defined $threadsafe and !$threadsafe;
+
+ $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var;
+ my $force = $ENV{$force_var} ? 1 : !1;
+ skip_all 'perl 5.13.4 required to test thread safety'
+ unless $force or "$]" >= 5.013_004;
+
+ if (($INC{'Test/More.pm'} || $INC{'Test/Leaner.pm'}) && !$INC{'threads.pm'}) {
+ die 'Test::More/Test::Leaner was loaded too soon';
+ }
+
+ load_or_skip_all 'threads', $force ? '0' : '1.67', [ ];
+ load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ];
+
+ require Test::Leaner;
+
+ diag "Threads testing forced by \$ENV{$force_var}" if $force;
+
+ return spawn => \&spawn;
+}
+
+sub init_usleep {
+ my $usleep;
+
+ if (do { local $@; eval { require Time::HiRes; 1 } }) {
+ defined and diag "Using usleep() from 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;
+ };
+ }
+
+ return usleep => $usleep;
+}
+
+sub spawn {
+ local $@;
+ my @diag;
+ my $thread = eval {
+ local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
+ threads->create(@_);
+ };
+ push @diag, "Thread creation error: $@" if $@;
+ diag @diag;
+ return $thread ? $thread : ();
}
package VPIT::TestHelpers::Guard;
@@ -1,51 +0,0 @@
-package indirect::TestThreads;
-
-use strict;
-use warnings;
-
-use Config qw<%Config>;
-
-use VPIT::TestHelpers;
-
-sub import {
- shift;
-
- require indirect;
-
- skip_all 'This indirect isn\'t thread safe' unless indirect::I_THREADSAFE();
-
- my $force = $ENV{PERL_INDIRECT_TEST_THREADS} ? 1 : !1;
- skip_all 'This perl wasn\'t built to support threads'
- unless $Config{useithreads};
- skip_all 'perl 5.13.4 required to test thread safety'
- unless $force or "$]" >= 5.013_004;
-
- load_or_skip_all('threads', $force ? '0' : '1.67', [ ]);
-
- my %exports = (
- spawn => \&spawn,
- );
-
- my $pkg = caller;
- while (my ($name, $code) = each %exports) {
- no strict 'refs';
- *{$pkg.'::'.$name} = $code;
- }
-}
-
-sub spawn {
- local $@;
- my @diag;
- my $thread = eval {
- local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
- threads->create(@_);
- };
- push @diag, "Thread creation error: $@" if $@;
- if (@diag) {
- require Test::Leaner;
- Test::Leaner::diag($_) for @diag;
- }
- return $thread ? $thread : ();
-}
-
-1;