indirect-0.36/000755 000765 000024 00000000000 12552274372 014065 5ustar00vincentstaff000000 000000 indirect-0.36/Changes000644 000765 000024 00000035462 12552274154 015370 0ustar00vincentstaff000000 000000 Revision history for indirect 0.36 2015-07-17 22:15 UTC + Fix : [RT #104312] : fatal hides perl errors in modules no indirect 'fatal' will no longer hide compilation errors occurring before indirect constructs. Thanks Lukas Mai for reporting. 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. + Fix : Segfaults during global destruction of a thread or a pseudo-fork. 0.32 2014-09-21 20:15 UTC + Add : Support for the PERL_OP_PARENT optional feature introduced in perl 5.21.2. + Fix : [RT #92806] : Tests that use run_perl() fail on Android Thanks Brian Fraser for the patch. + Fix : indirect constructs will no longer segfault while inside the empty package on perl 5.8.x. This fix may also prevent some segfaults during global destruction. 0.31 2013-09-05 16:45 UTC + Fix : [RT #88428] : no indirect in eval can trigger for direct calls on __PACKAGE__ Thanks Graham Knop for reporting. + Tst : Author tests are no longer bundled with this distribution. They are only made available to authors in the git repository. 0.30 2013-05-16 15:55 UTC + Fix : [RT #83806] : false positives with Devel::Declare [RT #83839] : false positive using ? : syntax Thanks Andrew Main for the patch. However, please note that the reason this patch seems to fix thinks has not been explained. + Fix : [RT #84649] : incorrect RT link in metadata Thanks Karen Etheridge for reporting. 0.29 2013-03-05 01:30 UTC + Fix : [RT #83659] : false positives Proper method calls in string-like environments (like "@{[ $x->new ]}" will no longer be reported as indirect. This was a regression in 0.28. Thanks Andrew Main for reporting. + Fix : Broken linkage on Windows with gcc 3.4, which appears in particular when using ActivePerl's default compiler suite. For those setups, the indirect shared library will now be linked against the perl dll directly (instead of the import library). 0.28 2013-02-26 17:05 UTC + Fix : [RT #83450] : newlines confuse indirect Perl sometimes resets the line buffer between the object and the method name (e.g. for "sort Class\n->method" outside of eval), and this could cause direct method calls to be reported as indirect. Thanks Gianni Ceccarelli for reporting. + Fix : Check functions are now replaced and restored in a thread-safe manner, either by using the wrap_op_checker() function from perl when it is available (starting from perl 5.16) or by taking the OP_REFCNT mutex on older perls. 0.27 2013-01-30 19:00 UTC + Fix : [RT #82562] : indirect/Devel::CallParser interaction indirect has been taught to play nicely with Devel::CallParser. Thanks Andrew Main for the patch. + Tst : Author tests overhaul. 0.26 2011-10-23 14:25 UTC + Add : "no indirect 'global'" enables the pragma for the whole program, except for lexical scopes that "use indirect" explicitely. + Chg : Passing both the 'fatal' and 'hook' options to unimport() is now considered an error, and will result in an exception. unimport() used to consider only the first passed option of those two, and silently ignored the other. + Tst : Test failures of t/41-threads-teardown.t and t/50-external.t on Cygwin should have been addressed. + Tst : Threads tests will not fail anymore if resources constraints prevent the system from creating all the required threads. 0.25 2011-08-24 15:40 UTC + Fix : RT #69291 is now also fixed for perl 5.8. The pragma will no longer vivify the "indirect" entry in the hints hash %^H on perl 5.8. + Tst : Attempt to make t/50-external.t pass on Cygwin. 0.24 2011-07-17 23:15 UTC + Fix : [RT #64521] : "no indirect" leaking into eval. This is currently only fixed for perl 5.10 (perl 5.12 and higher were never affected). It was caused by a very stupid mistake of mine that was introduced in indirect version 0.23. Thanks Michael G Schwern for reporting. + Fix : [RT #69291] : indirect.pm breaks %^H. This was caused by the same mistake as for the previous bug, and as such it is also only fixed for perl 5.10 (and never affected perl 5.12). Thanks Andrew Main for reporting. + Doc : C++ compilers are officially NOT supported. 0.23 2010-10-03 00:15 UTC + Fix : Some indirect constructs could be incorrectly reported when several modules were used in the same scope. This caused t/30-scope.t to fail randomly. + Tst : Threads tests are now only run on perl 5.13.4 and higher. They could segfault randomly because of what seems to be an internal bug of Perl, which has been addressed in 5.13.4. There is also an environment variable that allows you to forcefully run those tests, but it should be set only for author testing and not for end users. 0.22 2010-08-16 16:00 UTC + Add : Indirect constructs are now reported for code interpolated in quote-like environments, like "${\( ... )}", "@{[ ... ]}", s/pattern/ ... /e, qr/(?{ ... })/ or qr/(??{ ... })/. + Add : You can now make the pragma lethal by passing anything matching /^:?fatal$/i to import(), including "FATAL" and ":Fatal". + Fix : [RT #60378] : segmentation fault on indirect_ck_method. This caused constructs like "@{[ $obj->$meth ]}" to segfault when $meth was a lexical. Thanks Tokuhiro Matsuno for reporting. 0.21 2010-05-31 23:10 UTC + Chg : perl 5.8.1 is now required (instead of 5.8.0). + Fix : [RT #57699] : indirect fail with 64-bit int on 5.13.1. It was actually a problem with thread destructors segfaulting because they weren't called at the right time anymore. Thanks Andrew Main for reporting. + Tst : A few more regression tests about the scope leak bug. 0.20 2010-04-18 21:25 UTC + Fix : [RT #50570] : "indirect" leaking into LWP. Thanks Andrew Main for reporting. More generally, the require propagation workaround on 5.8-5.10.0 has been overhauled, and other scope leaks should be fixed. + Fix : Test failures with 5.12 on Windows where Strawberry Perl crashes because the SystemRoot environment variable is missing. + Fix : Work around Kwalitee test misfailures. 0.19 2009-08-28 18:40 UTC + Add : The new constant I_FORKSAFE can be tested to know whether the module will behave nicely when fork()ing. It's currently always true except on Windows where you need perl 5.10.1 for it to be true. + Fix : I_THREADSAFE and I_FORKSAFE ought to be true when PERL_INDIRECT_PM_DISABLE is set. + Fix : The pragma could still leak if you passed to the "hook" option a reference to the same (named) subroutine from two different require scopes. The fix also provides a better solution for RT #47902. + Fix : Segfaults when indirect is loaded for the first time from inside a thread. + Fix : Leaks of memory associated with the root interpreter. + 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.18 2009-08-23 16:15 UTC + Add : When set, the PERL_INDIRECT_PM_DISABLE environment variable disables the pragma globally. 0.17 2009-07-16 12:10 UTC + Fix : [RT #47902] : "no indirect" leaking again. This actually turned out to be a bug in how the hook coderefs were stored in the hints hash. Thanks Andrew Main for reporting once again. + Fix : t/80-regressions.t failing on Windows. + Tst : Yet more cleanups. 0.16 2009-07-14 16:50 UTC + Add : Indirect calls on blocks are now reported. For those, '{' is passed to the hook as the object description. + Add : The new indirect::msg() function publicizes the default warning/exception message. + Fix : [RT #47866] : Segfault with UTF-8 regexps. Thanks Andrew Main for reporting. + Tst : Cleanups. 0.15 2009-07-08 22:55 UTC + Fix : Invalid constructs with the same method and package name were not reported. + Fix : The error line number used to point to the end of the expression instead of its beginning. 0.14 2009-06-04 21:55 UTC + Fix : Prevent bogus invalid syntaxes caused by reallocated memory chunks. Thanks Andrew Main for reporting with a reproducible test case. 0.13 2009-05-24 18:50 UTC + Add : The hook now receives the file name and the line where the error happened in respectively $_[2] and $_[3]. + Fix : Pass mortalized copies of the method name and object to the hook. This seems to fix some rare crashes. + Fix : Work around a bug in perl 5.10.0 and lower. Thanks Andrew Main for teaching me about this issue. + Fix : Report the correct file in error messages (a regression from the previous version). 0.12 2009-05-03 14:30 UTC + Add : You can specify the action to execute for each indirect construct encountered with the new "hook => $coderef" unimport() option. + Chg : A ptable is now used internally for the op => position mapping. + Fix : The pragma is now built with thread safety features enabled whenever possible (a notable exception is perl 5.8.x on Win32, as something seems wrong with its context handling). The new indirect::I_THREADSAFE() constant reflects this. + Fix : A negation precedence nit in indirect_ck_entersub(). + Tst : "use/no indirect" while parsing an indirect construct. + Tst : Thread safety. 0.11 2009-02-08 18:35 UTC + Fix : Potential collisions by hashing pointers with a wrong format. + Upd : Resources in META.yml. 0.10 2009-01-17 12:40 UTC Re-release 0.09_01 as stable. 0.09_01 2008-12-08 17:55 UTC + Fix : Invalid memory read with "${\(new Foo)}" constructs. The corresponding test is turned back on. + Tst : Refinements in t/30-scope.t 0.09 2008-12-05 20:35 UTC + Add : Support for perl 5.8. + Tst : Skip a test in t/10-good.t that randomly segfaults for (I guess) systems stricter than linux in the way they manage their memory. 0.08 2008-10-22 14:45 UTC + Fix : A rare edge case for package whose names are prefix of 'main'. + Tst : Test $$ as variable and state variables. 0.07_03 2008-10-17 20:10 UTC + Add : Support and tests for variables with spaces after the sigil. + Upd : META.yml spec updated to 1.4. 0.07_02 2008-10-15 21:10 UTC + Add : Support and tests for package variables. + Tst : Coverage improved by removing dead code. 0.07_01 2008-10-15 16:00 UTC + Fix : [RT #40055] : Not handling RV2SV => GV(SV) correctly, which could cause 'no indirect; print' segfaults. Thanks Goro Fuji for reporting. 0.06 2008-10-11 16:45 UTC + Doc : Nits. + Tst : Test "no indirect 'anything'", "foo Class->bar", and indirect uses of exec() and system(). 0.05 2008-10-02 14:40 UTC + Chg : Now the old check function is always called before storing an op into the map. + Fix : Misc code and docs refinements. 0.04 2008-08-30 19:00 UTC + Fix : Clean up the op->src hash when we're done with an entersub. + Tst : No longer fork for testing. IPC::Cmd isn't required anymore. 0.03 2008-08-12 15:25 UTC This release is kindly supported by Copenhagen Hotel Centrum WiFi. + Fix : Tests used not to pass PERL5OPTS to their kids. This lead to failures under CPAN. I think. + Tst : Refinements. 0.02 2008-08-11 15:55 UTC + Fix : Some building failures with old gcc versions that didn't seem to like the ((hint == 2) ? croak : warn)(msg) construct. I think. + Rem : Unused cruft from a previous implementation. + Tst : Fail more gracefully when we can't capture buffers or when the child returned an error. 0.01 2008-08-10 20:40 UTC First version, released on an unsuspecting world. indirect-0.36/indirect.xs000644 000765 000024 00000072134 12552234731 016244 0ustar00vincentstaff000000 000000 /* This file is part of the indirect Perl module. * See http://search.cpan.org/dist/indirect/ */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define __PACKAGE__ "indirect" #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) /* --- Compatibility wrappers ---------------------------------------------- */ #ifndef NOOP # define NOOP #endif #ifndef dNOOP # define dNOOP #endif #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif #ifndef SvPV_const # define SvPV_const SvPV #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const SvPV_nolen #endif #ifndef SvPVX_const # define SvPVX_const SvPVX #endif #ifndef SvREFCNT_inc_simple_void_NN # ifdef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN # else # define SvREFCNT_inc_simple_void_NN SvREFCNT_inc # endif #endif #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef mPUSHp # define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L)))) #endif #ifndef mPUSHu # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) #endif #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif #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)))))) #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) # ifndef PL_linestr # define PL_linestr PL_parser->linestr # endif # ifndef PL_bufptr # define PL_bufptr PL_parser->bufptr # endif # ifndef PL_oldbufptr # define PL_oldbufptr PL_parser->oldbufptr # endif # ifndef PL_lex_inwhat # define PL_lex_inwhat PL_parser->lex_inwhat # endif #else # ifndef PL_linestr # define PL_linestr PL_Ilinestr # endif # ifndef PL_bufptr # define PL_bufptr PL_Ibufptr # endif # ifndef PL_oldbufptr # define PL_oldbufptr PL_Ioldbufptr # endif # ifndef PL_lex_inwhat # define PL_lex_inwhat PL_Ilex_inwhat # endif #endif #ifndef I_WORKAROUND_REQUIRE_PROPAGATION # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) #endif /* ... Thread safety and multiplicity ...................................... */ /* Safe unless stated otherwise in Makefile.PL */ #ifndef I_FORKSAFE # define I_FORKSAFE 1 #endif #ifndef I_MULTIPLICITY # 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 #if I_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) # define I_THREADSAFE 1 # ifndef MY_CXT_CLONE # define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # endif #else # define I_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT indirect_globaldata # undef START_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_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 /* 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 *); #ifdef wrap_op_checker # define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) #else 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_LOCK; if (!*old_ck_p) { *old_ck_p = PL_check[type]; PL_check[type] = new_ck; } I_CHECK_UNLOCK; } #endif 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_LOCK; if (*old_ck_p) { PL_check[type] = *old_ck_p; *old_ck_p = 0; } 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_NEED_DELETE 1 #define PTABLE_NEED_WALK 0 #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 typedef struct { SV *code; IV require_tag; } indirect_hint_t; #define I_HINT_STRUCT 1 #define I_HINT_CODE(H) ((H)->code) #define I_HINT_FREE(H) { \ indirect_hint_t *h = (H); \ SvREFCNT_dec(h->code); \ PerlMemShared_free(h); \ } #else /* I_WORKAROUND_REQUIRE_PROPAGATION */ typedef SV indirect_hint_t; #define I_HINT_STRUCT 0 #define I_HINT_CODE(H) (H) #define I_HINT_FREE(H) SvREFCNT_dec(H); #endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */ #if I_THREADSAFE #define PTABLE_NAME ptable_hints #define PTABLE_VAL_FREE(V) I_HINT_FREE(V) #define PTABLE_NEED_DELETE 0 #define PTABLE_NEED_WALK 1 #define pPTBL pTHX #define pPTBL_ pTHX_ #define aPTBL aTHX #define aPTBL_ aTHX_ #include "ptable.h" #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 /* I_THREADSAFE */ /* Define the op->str ptable here because we need to be able to clean it during * thread cleanup. */ typedef struct { char *buf; STRLEN pos; STRLEN size; STRLEN len; line_t line; } indirect_op_info_t; #define PTABLE_NAME ptable #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); } #define PTABLE_NEED_DELETE 1 #define PTABLE_NEED_WALK 0 #define pPTBL pTHX #define pPTBL_ pTHX_ #define aPTBL aTHX #define aPTBL_ aTHX_ #include "ptable.h" #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) #define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K)) #define ptable_clear(T) ptable_clear(aTHX_ (T)) #define ptable_free(T) ptable_free(aTHX_ (T)) #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { #if I_THREADSAFE ptable *tbl; /* It really is a ptable_hints */ tTHX owner; #endif ptable *map; SV *global_code; } my_cxt_t; START_MY_CXT #if I_THREADSAFE typedef struct { ptable *tbl; #if I_HAS_PERL(5, 13, 2) CLONE_PARAMS *params; #else CLONE_PARAMS params; #endif } indirect_ptable_clone_ud; #if I_HAS_PERL(5, 13, 2) # define indirect_ptable_clone_ud_init(U, T, O) \ (U).tbl = (T); \ (U).params = Perl_clone_params_new((O), aTHX) # define indirect_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) # define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) #else # define indirect_ptable_clone_ud_init(U, T, O) \ (U).tbl = (T); \ (U).params.stashes = newAV(); \ (U).params.flags = 0; \ (U).params.proto_perl = (O) # define indirect_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) # 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_) { indirect_ptable_clone_ud *ud = ud_; indirect_hint_t *h1 = ent->val; indirect_hint_t *h2; #if I_HINT_STRUCT h2 = PerlMemShared_malloc(sizeof *h2); h2->code = indirect_dup_inc(h1->code, ud); #if I_WORKAROUND_REQUIRE_PROPAGATION h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); #endif #else /* I_HINT_STRUCT */ h2 = indirect_dup_inc(h1, ud); #endif /* !I_HINT_STRUCT */ ptable_hints_store(ud->tbl, ent->key, h2); } #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION static IV indirect_require_tag(pTHX) { #define indirect_require_tag() indirect_require_tag(aTHX) const CV *cv, *outside; cv = PL_compcv; if (!cv) { /* If for some reason the pragma is operational at run-time, try to discover * the current cv in use. */ const PERL_SI *si; 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; switch (CxTYPE(cx)) { case CXt_SUB: case CXt_FORMAT: /* The propagation workaround is only needed up to 5.10.0 and at that * time format and sub contexts were still identical. And even later the * cv members offsets should have been kept the same. */ cv = cx->blk_sub.cv; goto get_enclosing_cv; case CXt_EVAL: cv = cx->blk_eval.cv; goto get_enclosing_cv; default: break; } } } cv = PL_main_cv; } get_enclosing_cv: for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) cv = outside; return PTR2IV(cv); } #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ static SV *indirect_tag(pTHX_ SV *value) { #define indirect_tag(V) indirect_tag(aTHX_ (V)) indirect_hint_t *h; SV *code = NULL; #if I_THREADSAFE dMY_CXT; if (!MY_CXT.tbl) return newSViv(0); #endif /* I_THREADSAFE */ if (SvROK(value)) { value = SvRV(value); if (SvTYPE(value) >= SVt_PVCV) { code = value; SvREFCNT_inc_simple_void_NN(code); } } #if I_HINT_STRUCT h = PerlMemShared_malloc(sizeof *h); h->code = code; # if I_WORKAROUND_REQUIRE_PROPAGATION h->require_tag = indirect_require_tag(); # endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ #else /* I_HINT_STRUCT */ h = code; #endif /* !I_HINT_STRUCT */ #if I_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 hint as the key itself. */ ptable_hints_store(MY_CXT.tbl, h, h); #endif /* I_THREADSAFE */ return newSViv(PTR2IV(h)); } 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 dMY_CXT; #endif #if I_THREADSAFE if (!MY_CXT.tbl) return NULL; #endif /* I_THREADSAFE */ h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE h = ptable_fetch(MY_CXT.tbl, h); #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION if (indirect_require_tag() != h->require_tag) return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); } static VOL U32 indirect_hash = 0; static SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) SV *hint = NULL; if (IN_PERL_RUNTIME) return NULL; #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) if (!PL_parser) return NULL; #endif #ifdef cop_hints_fetch_pvn hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, indirect_hash, 0); #elif I_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, __PACKAGE__, __PACKAGE_LEN__, 0, indirect_hash); #else { SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); if (val) hint = *val; } #endif if (hint && SvIOK(hint)) { return indirect_detag(hint); } else { dMY_CXT; 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) { #define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L)) indirect_op_info_t *oi; const char *s; STRLEN len; dMY_CXT; /* No need to check for MY_CXT.map != NULL because this code path is always * guarded by indirect_hint(). */ if (!(oi = ptable_fetch(MY_CXT.map, o))) { Newx(oi, 1, indirect_op_info_t); ptable_store(MY_CXT.map, o, oi); oi->buf = NULL; oi->size = 0; } if (sv) { s = SvPV_const(sv, len); } else { s = "{"; len = 1; } if (len > oi->size) { Safefree(oi->buf); Newx(oi->buf, len, char); oi->size = len; } Copy(s, oi->buf, len, char); oi->len = len; oi->pos = pos; oi->line = line; } 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; /* No need to check for MY_CXT.map != NULL because this code path is always * guarded by indirect_hint(). */ return ptable_fetch(MY_CXT.map, o); } static void indirect_map_delete(pTHX_ const OP *o) { #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) dMY_CXT; if (indirect_is_loaded(&MY_CXT) && MY_CXT.map) ptable_delete(MY_CXT.map, o); } /* --- Safe version of call_sv() ------------------------------------------- */ static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) { #define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F)) I32 ret, cxix; PERL_CONTEXT saved_cx; SV *saved_errsv = NULL; if (SvTRUE(ERRSV)) { if (IN_PERL_COMPILETIME && PL_errors) sv_catsv(PL_errors, ERRSV); else saved_errsv = newSVsv(ERRSV); SvCUR_set(ERRSV, 0); } cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); /* The last popped context will be reused by call_sv(), but our callers may * still need its previous value. Back it up so that it isn't clobbered. */ saved_cx = cxstack[cxix]; ret = call_sv(sv, flags | G_EVAL); cxstack[cxix] = saved_cx; if (SvTRUE(ERRSV)) { /* Discard the old ERRSV, and reuse the variable to temporarily store the * new one. */ if (saved_errsv) sv_setsv(saved_errsv, ERRSV); else saved_errsv = newSVsv(ERRSV); SvCUR_set(ERRSV, 0); /* Immediately flush all errors. */ if (IN_PERL_COMPILETIME) { #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) if (PL_parser) ++PL_parser->error_count; #elif defined(PL_error_count) ++PL_error_count; #else ++PL_Ierror_count; #endif if (PL_errors) { sv_setsv(ERRSV, PL_errors); SvCUR_set(PL_errors, 0); } } sv_catsv(ERRSV, saved_errsv); SvREFCNT_dec(saved_errsv); croak(NULL); } else if (saved_errsv) { /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval * block has ever been executed. */ sv_setsv(ERRSV, saved_errsv); SvREFCNT_dec(saved_errsv); } return ret; } /* --- Check functions ----------------------------------------------------- */ 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; const char *line, *line_end; const char *p; line = SvPV_const(PL_linestr, line_len); line_end = line + line_len; name = SvPV_const(name_sv, name_len); if (name_len >= 1 && *name == '$') { ++name; --name_len; while (line_bufptr < line_end && *line_bufptr != '$') ++line_bufptr; if (line_bufptr >= line_end) return 0; } name_end = name + name_len; p = line_bufptr; while (1) { p = ninstr(p, line_end, name, name_end); if (!p) return 0; if (!isALNUM(p[name_len])) break; /* p points to a word that has name as prefix, skip the rest of the word */ p += name_len + 1; while (isALNUM(*p)) ++p; } *name_pos = p - line; return 1; } /* ... ck_const ............................................................ */ static OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0; static OP *indirect_ck_const(pTHX_ OP *o) { o = indirect_old_ck_const(aTHX_ o); if (indirect_hint()) { SV *sv = cSVOPo_sv; if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) { STRLEN pos; if (indirect_find(sv, PL_oldbufptr, &pos)) { STRLEN len; /* If the constant is equal to the current package name, try to look for * a "__PACKAGE__" coming before what we got. We only need to check this * when we already had a match because __PACKAGE__ can only appear in * direct method calls ("new __PACKAGE__" is a syntax error). */ len = SvCUR(sv); if (PL_curstash && len == (STRLEN) HvNAMELEN_get(PL_curstash) && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) { STRLEN pos_pkg; SV *pkg = sv_newmortal(); sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1); if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) { sv = pkg; pos = pos_pkg; } } indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); return o; } } } indirect_map_delete(o); return o; } /* ... ck_rv2sv ............................................................ */ static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; static OP *indirect_ck_rv2sv(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; SV *sv; const char *name = NULL; STRLEN pos, len; OPCODE type = (OPCODE) op->op_type; switch (type) { case OP_GV: case OP_GVSV: { GV *gv = cGVOPx_gv(op); name = GvNAME(gv); len = GvNAMELEN(gv); break; } default: if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) { SV *nsv = cSVOPx_sv(op); if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV)) name = SvPV_const(nsv, len); } } if (!name) goto done; sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, name, len); if (!indirect_find(sv, PL_oldbufptr, &pos)) { /* If it failed, retry without the current stash */ const char *stash = HvNAME_get(PL_curstash); STRLEN stashlen = HvNAMELEN_get(PL_curstash); if ((len < stashlen + 2) || strnNE(name, stash, stashlen) || name[stashlen] != ':' || name[stashlen+1] != ':') { /* Failed again ? Try to remove main */ stash = "main"; stashlen = 4; if ((len < stashlen + 2) || strnNE(name, stash, stashlen) || name[stashlen] != ':' || name[stashlen+1] != ':') goto done; } sv_setpvn(sv, "$", 1); stashlen += 2; sv_catpvn_nomg(sv, name + stashlen, len - stashlen); if (!indirect_find(sv, PL_oldbufptr, &pos)) goto done; } o = indirect_old_ck_rv2sv(aTHX_ o); indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); return o; } done: o = indirect_old_ck_rv2sv(aTHX_ o); indirect_map_delete(o); return o; } /* ... ck_padany ........................................................... */ static OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0; static OP *indirect_ck_padany(pTHX_ OP *o) { o = indirect_old_ck_padany(aTHX_ o); if (indirect_hint()) { SV *sv; const char *s = PL_oldbufptr, *t = PL_bufptr - 1; while (s < t && isSPACE(*s)) ++s; if (*s == '$' && ++s <= t) { while (s < t && isSPACE(*s)) ++s; while (s < t && isSPACE(*t)) --t; sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, s, t - s + 1); indirect_map_store(o, s - SvPVX_const(PL_linestr), sv, CopLINE(&PL_compiling)); return o; } } indirect_map_delete(o); return o; } /* ... ck_scope ............................................................ */ 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) { OP *(*old_ck)(pTHX_ OP *) = 0; switch (o->op_type) { case OP_SCOPE: old_ck = indirect_old_ck_scope; break; case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break; } o = old_ck(aTHX_ o); if (indirect_hint()) { indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr), NULL, CopLINE(&PL_compiling)); return o; } indirect_map_delete(o); return o; } /* We don't need to clean the map entries for leave ops because they can only * be created by mutating from a lineseq. */ /* ... ck_method ........................................................... */ static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; static OP *indirect_ck_method(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; /* Indirect method call is only possible when the method is a bareword, so * don't trip up on $obj->$meth. */ if (op && op->op_type == OP_CONST) { const indirect_op_info_t *oi = indirect_map_fetch(op); STRLEN pos; line_t line; SV *sv; if (!oi) goto done; sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); pos = oi->pos; /* Keep the old line so that we really point to the first line of the * expression. */ line = oi->line; o = indirect_old_ck_method(aTHX_ o); /* o may now be a method_named */ indirect_map_store(o, pos, sv, line); return o; } } done: o = indirect_old_ck_method(aTHX_ o); indirect_map_delete(o); return o; } /* ... ck_method_named ..................................................... */ /* "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_ck_method_named(pTHX_ OP *o) { if (indirect_hint()) { STRLEN pos; line_t line; SV *sv; sv = cSVOPo_sv; if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) goto done; sv = sv_mortalcopy(sv); if (!indirect_find(sv, PL_oldbufptr, &pos)) goto done; line = CopLINE(&PL_compiling); o = indirect_old_ck_method_named(aTHX_ o); indirect_map_store(o, pos, sv, line); return o; } done: o = indirect_old_ck_method_named(aTHX_ o); indirect_map_delete(o); return o; } /* ... ck_entersub ......................................................... */ static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; static OP *indirect_ck_entersub(pTHX_ OP *o) { SV *code = indirect_hint(); o = indirect_old_ck_entersub(aTHX_ o); if (code) { const indirect_op_info_t *moi, *ooi; OP *mop, *oop; LISTOP *lop; oop = o; do { lop = (LISTOP *) oop; if (!(lop->op_flags & OPf_KIDS)) goto done; oop = lop->op_first; } while (oop->op_type != OP_PUSHMARK); oop = OpSIBLING(oop); mop = lop->op_last; if (!oop) goto done; switch (oop->op_type) { case OP_CONST: case OP_RV2SV: case OP_PADSV: case OP_SCOPE: case OP_LEAVE: break; default: goto done; } if (mop->op_type == OP_METHOD) mop = cUNOPx(mop)->op_first; else if (mop->op_type != OP_METHOD_NAMED) goto done; moi = indirect_map_fetch(mop); if (!moi) goto done; ooi = indirect_map_fetch(oop); if (!ooi) goto done; /* When positions are identical, the method and the object must have the * same name. But it also means that it is an indirect call, as "foo->foo" * results in different positions. */ if ( moi->line < ooi->line || (moi->line == ooi->line && moi->pos <= ooi->pos)) { SV *file; dSP; ENTER; SAVETMPS; #ifdef USE_ITHREADS file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0)); #else file = sv_mortalcopy(CopFILESV(&PL_compiling)); #endif PUSHMARK(SP); EXTEND(SP, 4); mPUSHp(ooi->buf, ooi->len); mPUSHp(moi->buf, moi->len); PUSHs(file); mPUSHu(moi->line); PUTBACK; indirect_call_sv(code, G_VOID); PUTBACK; FREETMPS; LEAVE; } } done: return o; } /* --- Module setup/teardown ----------------------------------------------- */ static void indirect_teardown(pTHX_ void *interp) { dMY_CXT; 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); } I_LOADED_UNLOCK; SvREFCNT_dec(MY_CXT.global_code); MY_CXT.global_code = NULL; ptable_free(MY_CXT.map); MY_CXT.map = NULL; #if I_THREADSAFE ptable_hints_free(MY_CXT.tbl); MY_CXT.tbl = NULL; #endif return; } static void indirect_setup(pTHX) { #define indirect_setup() indirect_setup(aTHX) 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; { 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; } call_atexit(indirect_teardown, NULL); return; } /* --- XS ------------------------------------------------------------------ */ MODULE = indirect PACKAGE = indirect PROTOTYPES: ENABLE BOOT: { indirect_setup(); } #if I_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; SV *global_code_dup; PPCODE: { indirect_ptable_clone_ud ud; dMY_CXT; t = ptable_new(); indirect_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud); indirect_ptable_clone_ud_deinit(ud); } { MY_CXT_CLONE; MY_CXT.map = ptable_new(); 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; } } XSRETURN(0); #endif /* I_THREADSAFE */ SV * _tag(SV *value) PROTOTYPE: $ CODE: RETVAL = indirect_tag(value); OUTPUT: RETVAL void _global(SV *code) PROTOTYPE: $ PPCODE: if (!SvOK(code)) code = NULL; else if (SvROK(code)) code = SvRV(code); { dMY_CXT; SvREFCNT_dec(MY_CXT.global_code); MY_CXT.global_code = SvREFCNT_inc(code); } XSRETURN(0); indirect-0.36/lib/000755 000765 000024 00000000000 12552274372 014633 5ustar00vincentstaff000000 000000 indirect-0.36/Makefile.PL000644 000765 000024 00000005700 12552247461 016040 0ustar00vincentstaff000000 000000 use 5.008_001; use strict; use warnings; use ExtUtils::MakeMaker; use Config; my @DEFINES; my %macro; my $is_gcc_34 = 0; print "Checking if this is gcc 3.4 on Windows trying to link against an import library... "; if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) { my ($libperl, $gccversion) = map $_ || '', @Config{qw}; if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) { $is_gcc_34 = 1; my ($lddlflags, $ldflags) = @Config{qw}; $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags; $libperl = "-l$libperl"; my $libdirs = join ' ', map { s/(?}; $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl"; $macro{LDFLAGS} = "$ldflags $libdirs $libperl"; 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"; # Threads, Windows and 5.8.x don't seem to be best friends if ($^O eq 'MSWin32' and "$]" < 5.009) { push @DEFINES, '-DI_MULTIPLICITY=0'; } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' and "$]" < 5.010_001) { push @DEFINES, '-DI_FORKSAFE=0'; } @DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES; %macro = (macro => { %macro }) if %macro; # Beware of the circle my $dist = 'indirect'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'Carp' => 0, 'XSLoader' => 0, ); my %BUILD_REQUIRES =( 'Config' => 0, 'ExtUtils::MakeMaker' => 0, 'IO::Handle' => 0, 'IO::Select' => 0, 'IPC::Open3' => 0, 'POSIX' => 0, 'Socket' => 0, 'Test::More' => 0, 'lib' => 0, %PREREQ_PM, ); my %META = ( configure_requires => { 'Config' => 0, 'ExtUtils::MakeMaker' => 0, }, build_requires => { %BUILD_REQUIRES, }, dynamic_config => 1, resources => { bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist", homepage => "http://search.cpan.org/dist/$dist/", license => 'http://dev.perl.org/licenses/', repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", }, ); WriteMakefile( NAME => $name, AUTHOR => 'Vincent Pit ', LICENSE => 'perl', VERSION_FROM => $file, ABSTRACT_FROM => $file, PL_FILES => {}, @DEFINES, BUILD_REQUIRES => \%BUILD_REQUIRES, PREREQ_PM => \%PREREQ_PM, MIN_PERL_VERSION => '5.008001', META_MERGE => \%META, dist => { PREOP => "pod2text -u $file > \$(DISTVNAME)/README", COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, clean => { FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*" }, %macro, ); indirect-0.36/MANIFEST000644 000765 000024 00000002266 12552273610 015216 0ustar00vincentstaff000000 000000 Changes MANIFEST META.json META.yml Makefile.PL README indirect.xs 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 t/20-good.t t/21-bad.t t/22-bad-mixed.t t/23-bad-notaint.t t/30-scope.t t/31-hints.t t/32-global.t t/33-compilation-errors.t t/40-threads.t t/41-threads-teardown.t t/42-threads-global.t t/45-memory.t t/46-stress.t t/47-stress-use.t t/50-external.t t/51-dd-newlines.t t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm t/lib/indirect/Test0/Fffff/Vvvvvvv.pm t/lib/indirect/Test0/Oooooo/Pppppppp.pm t/lib/indirect/Test1/il1.pm t/lib/indirect/Test1/il2.pm t/lib/indirect/Test2.pm t/lib/indirect/Test3.pm t/lib/indirect/Test4.pm t/lib/indirect/Test5.pm t/lib/indirect/TestCompilationError.pm t/lib/indirect/TestRequired1.pm t/lib/indirect/TestRequired2.pm t/lib/indirect/TestRequired3X.pm t/lib/indirect/TestRequired3Y.pm t/lib/indirect/TestRequired4/a0.pm t/lib/indirect/TestRequired4/b0.pm t/lib/indirect/TestRequired4/c0.pm t/lib/indirect/TestRequired5/a0.pm t/lib/indirect/TestRequired5/b0.pm t/lib/indirect/TestRequired5/c0.pm t/lib/indirect/TestRequired5/d0.pm t/lib/indirect/TestRequired6.pm t/lib/indirect/TestRequiredGlobal.pm indirect-0.36/META.json000644 000765 000024 00000003252 12552274372 015510 0ustar00vincentstaff000000 000000 { "abstract" : "Lexically warn about using the indirect method call syntax.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "indirect", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Carp" : "0", "Config" : "0", "ExtUtils::MakeMaker" : "0", "IO::Handle" : "0", "IO::Select" : "0", "IPC::Open3" : "0", "POSIX" : "0", "Socket" : "0", "Test::More" : "0", "XSLoader" : "0", "lib" : "0" } }, "configure" : { "requires" : { "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "XSLoader" : "0", "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Name=indirect" }, "homepage" : "http://search.cpan.org/dist/indirect/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git" } }, "version" : "0.36", "x_serialization_backend" : "JSON::PP version 2.27300" } indirect-0.36/META.yml000644 000765 000024 00000001773 12552274372 015346 0ustar00vincentstaff000000 000000 --- abstract: 'Lexically warn about using the indirect method call syntax.' author: - 'Vincent Pit ' build_requires: Carp: '0' Config: '0' ExtUtils::MakeMaker: '0' IO::Handle: '0' IO::Select: '0' IPC::Open3: '0' POSIX: '0' Socket: '0' Test::More: '0' XSLoader: '0' lib: '0' configure_requires: Config: '0' ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: indirect no_index: directory: - t - inc requires: Carp: '0' XSLoader: '0' perl: '5.008001' resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=indirect 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.36' x_serialization_backend: 'CPAN::Meta::YAML version 0.016' indirect-0.36/ptable.h000644 000765 000024 00000013572 12525146060 015505 0ustar00vincentstaff000000 000000 /* This file is part of the indirect Perl module. * See http://search.cpan.org/dist/indirect/ */ /* This is a pointer table implementation essentially copied from the ptr_table * implementation in perl's sv.c, except that it has been modified to use memory * shared across threads. * Copyright goes to the original authors, bug reports to me. */ /* This header is designed to be included several times with different * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */ #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #endif #undef pPTBLMS #undef pPTBLMS_ #undef aPTBLMS #undef aPTBLMS_ /* Context for PerlMemShared_* functions */ #ifdef PERL_IMPLICIT_SYS # define pPTBLMS pTHX # define pPTBLMS_ pTHX_ # define aPTBLMS aTHX # define aPTBLMS_ aTHX_ #else # define pPTBLMS void # define pPTBLMS_ # define aPTBLMS # define aPTBLMS_ #endif #ifndef pPTBL # define pPTBL pPTBLMS #endif #ifndef pPTBL_ # define pPTBL_ pPTBLMS_ #endif #ifndef aPTBL # define aPTBL aPTBLMS #endif #ifndef aPTBL_ # define aPTBL_ aPTBLMS_ #endif #ifndef PTABLE_NAME # define PTABLE_NAME ptable #endif #ifndef PTABLE_JOIN # define PTABLE_PASTE(A, B) A ## B # define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) #endif #ifndef PTABLE_PREFIX # define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) #endif #ifndef PTABLE_NEED_DELETE # define PTABLE_NEED_DELETE 1 #endif #ifndef PTABLE_NEED_WALK # define PTABLE_NEED_WALK 1 #endif #ifndef ptable_ent typedef struct ptable_ent { struct ptable_ent *next; const void * key; void * val; } ptable_ent; #define ptable_ent ptable_ent #endif /* !ptable_ent */ #ifndef ptable typedef struct ptable { ptable_ent **ary; size_t max; size_t items; } ptable; #define ptable ptable #endif /* !ptable */ #ifndef ptable_new static ptable *ptable_new(pPTBLMS) { #define ptable_new() ptable_new(aPTBLMS) ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t)); t->max = 15; t->items = 0; t->ary = VOID2(ptable_ent **, PerlMemShared_calloc(t->max + 1, sizeof *t->ary)); return t; } #endif /* !ptable_new */ #ifndef PTABLE_HASH # define PTABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) #endif #ifndef ptable_find static ptable_ent *ptable_find(const ptable * const t, const void * const key) { #define ptable_find ptable_find ptable_ent *ent; const UV hash = PTABLE_HASH(key); ent = t->ary[hash & t->max]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } return NULL; } #endif /* !ptable_find */ #ifndef ptable_fetch static void *ptable_fetch(const ptable * const t, const void * const key) { #define ptable_fetch ptable_fetch const ptable_ent *const ent = ptable_find(t, key); return ent ? ent->val : NULL; } #endif /* !ptable_fetch */ #ifndef ptable_split static void ptable_split(pPTBLMS_ ptable * const t) { #define ptable_split(T) ptable_split(aPTBLMS_ (T)) ptable_ent **ary = t->ary; const size_t oldsize = t->max + 1; size_t newsize = oldsize * 2; size_t i; ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary))); Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary)); t->max = --newsize; t->ary = ary; for (i = 0; i < oldsize; i++, ary++) { ptable_ent **curentp, **entp, *ent; if (!*ary) continue; curentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { if ((newsize & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; continue; } else entp = &ent->next; } } } #endif /* !ptable_split */ static void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { ptable_ent *ent = ptable_find(t, key); if (ent) { #ifdef PTABLE_VAL_FREE void *oldval = ent->val; PTABLE_VAL_FREE(oldval); #endif ent->val = val; } else if (val) { const size_t i = PTABLE_HASH(key) & t->max; ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent)); ent->key = key; ent->val = val; ent->next = t->ary[i]; t->ary[i] = ent; t->items++; if (ent->next && t->items > t->max) ptable_split(t); } } #if PTABLE_NEED_DELETE static void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) { ptable_ent *prev, *ent; const size_t i = PTABLE_HASH(key) & t->max; prev = NULL; ent = t->ary[i]; for (; ent; prev = ent, ent = ent->next) { if (ent->key == key) break; } if (ent) { if (prev) prev->next = ent->next; else t->ary[i] = ent->next; #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(ent->val); #endif PerlMemShared_free(ent); } } #endif /* PTABLE_NEED_DELETE */ #if PTABLE_NEED_WALK && !defined(ptable_walk) static void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { #define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry; for (entry = array[i]; entry; entry = entry->next) if (entry->val) cb(aTHX_ entry, userdata); } while (i--); } } #endif /* PTABLE_NEED_WALK && !defined(ptable_walk) */ static void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry = array[i]; while (entry) { ptable_ent * const nentry = entry->next; #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(entry->val); #endif PerlMemShared_free(entry); entry = nentry; } array[i] = NULL; } while (i--); t->items = 0; } } static void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); PerlMemShared_free(t->ary); PerlMemShared_free(t); } #undef pPTBL #undef pPTBL_ #undef aPTBL #undef aPTBL_ #undef PTABLE_NAME #undef PTABLE_VAL_FREE #undef PTABLE_NEED_DELETE #undef PTABLE_NEED_WALK indirect-0.36/README000644 000765 000024 00000021533 12552274372 014751 0ustar00vincentstaff000000 000000 NAME indirect - Lexically warn about using the indirect method call syntax. VERSION Version 0.36 SYNOPSIS In a script : no indirect; # lexically enables the pragma my $x = new Apple 1, 2, 3; # warns { use indirect; # lexically disables the pragma my $y = new Pear; # legit, does not warn { # lexically specify an hook called for each indirect construct no indirect hook => sub { die "You really wanted $_[0]\->$_[1] at $_[2]:$_[3]" }; my $z = new Pineapple 'fresh'; # croaks 'You really wanted...' } } try { ... }; # warns if try() hasn't been declared in this package no indirect 'fatal'; # or ':fatal', 'FATAL', ':Fatal' ... if (defied $foo) { ... } # croaks, note the typo Global uses : # Globally enable the pragma from the command-line perl -M-indirect=global -e 'my $x = new Banana;' # warns # Globally enforce the pragma each time perl is executed export PERL5OPT="-M-indirect=global,fatal" perl -e 'my $y = new Coconut;' # croaks DESCRIPTION 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 "foo" has not been declared in the current package, "foo $x" actually compiles to "$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 optional features that would be enabled by passing options to "unimport". This module is not a source filter. METHODS "unimport" no indirect; no indirect 'fatal'; no indirect hook => sub { my ($obj, $name, $file, $line) = @_; ... }; no indirect 'global'; no indirect 'global, 'fatal'; no indirect 'global', hook => sub { ... }; Magically called when "no indirect @opts" is encountered. Turns the module on. The policy to apply depends on what is first found in @opts : * If it is a string that matches "/^:?fatal$/i", the compilation will croak when the first indirect method call is found. This option is mutually exclusive with the 'hook' option. * If the key/value pair "hook => $hook" comes first, $hook will be called for each error with a string representation of the object as $_[0], the method name as $_[1], the current file as $_[2] and the line number as $_[3]. If and only if the object is actually a block, $_[0] is assured to start by '{'. This option is mutually exclusive with the 'fatal' option. * If none of "fatal" and "hook" are specified, a warning will be emitted for each indirect method call. * If @opts contains a string that matches "/^:?global$/i", the pragma will be globally enabled for all code compiled after the current "no indirect" statement, except for code that is in the lexical scope of "use indirect". This option may come indifferently before or after the "fatal" or "hook" options, in the case they are also passed to "unimport". The global policy applied is the one resulting of the "fatal" or "hook" options, thus defaults to a warning when none of those are specified : no indirect 'global'; # warn for any indirect call no indirect qw; # die on any indirect call no indirect 'global', hook => \&hook # custom global action Note that if another policy is installed by a "no indirect" statement further in the code, it will overrule the global policy : no indirect 'global'; # warn globally { no indirect 'fatal'; # throw exceptions for this lexical scope ... require Some::Module; # the global policy will apply for the # compilation phase of this module } "import" use indirect; Magically called at each "use indirect". Turns the module off. As explained in "unimport"'s description, an "use indirect" statement will lexically override a global policy previously installed by "no indirect 'global', ..." (if there's one). FUNCTIONS "msg" my $msg = msg($object, $method, $file, $line); Returns the default error message that "indirect" generates when an indirect method call is reported. CONSTANTS "I_THREADSAFE" True iff the module could have been built with thread-safety features enabled. "I_FORKSAFE" True iff this module could have been built with fork-safety features enabled. This will always be true except on Windows where it's false for perl 5.10.0 and below . DIAGNOSTICS "Indirect call of method "%s" on object "%s" at %s line %d." The default warning/exception message thrown when an indirect method call on an object is found. "Indirect call of method "%s" on a block at %s line %d." The default warning/exception message thrown when an indirect method call on a block is found. ENVIRONMENT "PERL_INDIRECT_PM_DISABLE" If this environment variable is set to true when the pragma is used for the first time, the XS code won't be loaded and, although the 'indirect' lexical hint will be set to true in the scope of use, the pragma itself won't do anything. In this case, the pragma will always be considered to be thread-safe, and as such "I_THREADSAFE" will be true. This is useful for disabling "indirect" in production environments. Note that clearing this variable after "indirect" was loaded has no effect. If you want to re-enable the pragma later, you also need to reload it by deleting the 'indirect.pm' entry from %INC. CAVEATS The implementation was tweaked to work around several limitations of vanilla "perl" pragmas : it's thread safe, and does not suffer from a "perl 5.8.x-5.10.0" bug that causes all pragmas to propagate into "require"d scopes. Before "perl" 5.12, "meth $obj" (no semicolon) at the end of a file is not seen as an indirect method call, although it is as soon as there is another token before the end (as in "meth $obj;" or "meth $obj 1"). If you use "perl" 5.12 or greater, those constructs are correctly reported. With 5.8 perls, the pragma does not propagate into "eval STRING". This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. 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 : * : 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. * : 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. A C compiler. This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. Carp (standard since perl 5), XSLoader (since perl 5.6.0). AUTHOR Vincent Pit, "", . You can contact me by mail or on "irc.perl.org" (vincent). BUGS Please report any bugs or feature requests to "bug-indirect at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc indirect Tests code coverage report is available at . ACKNOWLEDGEMENTS Bram, for motivation and advices. Andrew Main and Florian Ragwitz, for testing on real-life code and reporting issues. COPYRIGHT & LICENSE 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. indirect-0.36/samples/000755 000765 000024 00000000000 12552274372 015531 5ustar00vincentstaff000000 000000 indirect-0.36/t/000755 000765 000024 00000000000 12552274372 014330 5ustar00vincentstaff000000 000000 indirect-0.36/t/00-load.t000644 000765 000024 00000000240 12473621134 015637 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'indirect' ); } diag( "Testing indirect $indirect::VERSION, Perl $], $^X" ); indirect-0.36/t/09-load-threads.t000644 000765 000024 00000012645 12525143616 017316 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; 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 use lib 't/lib'; use VPIT::TestHelpers threads => [ $module, $thread_safe_var ]; 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'; indirect-0.36/t/10-args.t000644 000765 000024 00000003723 12473621134 015666 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 4 + 3 + 1 + 2; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub expect { my ($pkg) = @_; qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/; } { my @warns; { local $SIG{__WARN__} = sub { push @warns, "@_" }; eval <<' HERE'; return; no indirect; my $x = new Warn1; $x = new Warn2; HERE } my $w1 = shift @warns; my $w2 = shift @warns; is $@, '', 'didn\'t croak without arguments'; like $w1, expect('Warn1'), 'first warning caught without arguments'; like $w2, expect('Warn2'), 'second warning caught without arguments'; is_deeply \@warns, [ ], 'no more warnings without arguments'; } for my $fatal (':fatal', 'FATAL', ':Fatal') { { local $SIG{__WARN__} = sub { die "warn:@_" }; eval <<" HERE"; die qq{shouldn't even compile\n}; no indirect '$fatal'; my \$x = new Croaked; \$x = new NotReached; HERE } like $@, expect('Croaked'), "croaks when $fatal is specified"; } { { local $SIG{__WARN__} = sub { "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; no indirect 'whatever', hook => sub { die 'hook:' . join(':', @_) . "\n" }; my $x = new Hooked; $x = new AlsoNotReached; HERE } like $@, qr/^hook:Hooked:new:\(eval\s+\d+\):\d+$/, 'calls the specified hook'; } { my $no_hook_and_fatal = qr/^The 'fatal' and 'hook' options are mutually exclusive at \(eval \d+\) line \d+/; { local $SIG{__WARN__} = sub { die "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; no indirect 'fatal', hook => sub { }; new NotReached; HERE } like $@, $no_hook_and_fatal, '"no indirect qw" croaks'; { local $SIG{__WARN__} = sub { die "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; no indirect hook => sub { }, 'fatal'; new NotReached; HERE } like $@, $no_hook_and_fatal, '"no indirect qw" croaks'; } indirect-0.36/t/11-line.t000644 000765 000024 00000001747 12473621134 015666 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3 * 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub expect { my ($pkg, $line) = @_; return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+\(eval\s+\d+\)\s+line\s+$line/; } { local $/ = "####"; while () { chomp; s/^\s+//; my ($code, $lines) = split /#+/, $_, 2; $lines = eval "[ sort ($lines) ]"; if ($@) { diag "Couldn't parse line numbers: $@"; next; } my (@warns, @lines); { local $SIG{__WARN__} = sub { push @warns, "@_" }; eval "return; no indirect hook => sub { push \@lines, \$_[3] }; $code"; } is $@, '', 'did\'t croak'; is_deeply \@warns, [ ], 'didn\'t warn'; is_deeply [ sort @lines ], $lines, 'correct line numbers'; } } __DATA__ my $x = new X; # 1 #### my $x = new X; # 1 #### my $x = new X; $x = new X; # 1, 1 #### my $x = new X new X; # 1, 2 indirect-0.36/t/12-env.t000644 000765 000024 00000000720 12473621134 015516 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 3; { local $ENV{PERL_INDIRECT_PM_DISABLE} = 1; my $err = 0; my $res = eval <<' TEST_ENV_VARIABLE'; return 1; no indirect hook => sub { ++$err }; my $x = new Flurbz; TEST_ENV_VARIABLE is $@, '', 'PERL_INDIRECT_PM_DISABLE test doesn\'t croak'; is $res, 1, 'PERL_INDIRECT_PM_DISABLE test returns the correct value'; is $err, 0, 'PERL_INDIRECT_PM_DISABLE test didn\'t generate any error'; } indirect-0.36/t/20-good.t000644 000765 000024 00000017571 12473621134 015671 0ustar00vincentstaff000000 000000 #!perl -T package NotEmpty; sub new; package main; use strict; use warnings; use Test::More tests => 119 * 8 + 10; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } my ($obj, $pkg, $cb, $x, @a); our ($y, $meth); sub meh; sub zap (&); my @warns; sub try { my ($code) = @_; @warns = (); { local $SIG{__WARN__} = sub { push @warns, @_ }; eval $code; } } { local $/ = "####"; while () { chomp; s/\s*$//; s/(.*?)$//m; my ($skip, $prefix) = split /#+/, $1; $skip = 0 unless defined $skip; $prefix = '' unless defined $prefix; s/\s*//; SKIP: { skip "$_: $skip" => 8 if eval $skip; { local $_ = $_; s/Pkg/Empty/g; try "return; $prefix; use indirect; $_"; is $@, '', "use indirect: $_"; is @warns, 0, 'no reports'; try "return; $prefix; no indirect; $_"; is $@, '', "no indirect: $_"; is @warns, 0, 'no reports'; } { local $_ = $_; s/Pkg/NotEmpty/g; try "return; $prefix; use indirect; $_"; is $@, '', "use indirect, defined: $_"; is @warns, 0, 'no reports'; try "return; $prefix; no indirect; $_"; is $@, '', "no indirect, defined: $_"; is @warns, 0, 'no reports'; } } } } # These tests must be run outside of eval to be meaningful. { sub Zlott::Owww::new { } my (@warns, $hook, $desc, $id); BEGIN { $hook = sub { push @warns, indirect::msg(@_) }; $desc = "test sort and line endings %d: no indirect construct"; $id = 1; } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; }; BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } } __DATA__ $obj = Pkg->new; #### $obj = Pkg->new(); #### $obj = Pkg->new(1); #### $obj = Pkg->new(q{foo}, bar => $obj); #### $obj = Pkg -> new ; #### $obj = Pkg -> new ( ) ; #### $obj = Pkg -> new ( 1 ) ; #### $obj = Pkg -> new ( 'foo' , bar => $obj ); #### $obj = Pkg -> new ; #### $obj = Pkg -> new ( ) ; #### $obj = Pkg -> new ( 1 ) ; #### $obj = Pkg -> new ( "foo" , bar => $obj ); #### $obj = new->new; #### $obj = new->new; # new new #### $obj = new->newnew; #### $obj = newnew->new; #### $obj = Pkg->$cb; #### $obj = Pkg->$cb(); #### $obj = Pkg->$cb($pkg); #### $obj = Pkg->$cb(sub { 'foo' }, bar => $obj); #### $obj = Pkg->$meth; #### $obj = Pkg -> $meth ( 1, 2 ); #### $obj = $pkg->new ; #### $obj = $pkg -> new ( ); #### $obj = $pkg -> new ( $pkg ); #### $obj = $pkg -> new ( qr/foo/, foo => qr/bar/ ); #### $obj = $pkg -> $cb ; #### $obj = $pkg -> ($cb) (); #### $obj = $pkg->$cb( $obj ); #### $obj = $pkg->$cb(qw); #### $obj = $pkg->$meth; #### $obj = $pkg -> $meth ( 1 .. 10 ); #### $obj = $y->$cb; #### $obj = $y -> $cb ( 'foo', 1, 2, 'bar' ); #### $obj = $y->$meth; #### $obj = $y-> $meth ( qr(hello), ); #### meh; #### meh $_; #### meh $x; #### meh $x, 1, 2; #### meh $y; #### meh $y, 1, 2; #### "$]" < 5.010 # use feature 'state'; state $z meh $z; #### "$]" < 5.010 # use feature 'state'; state $z meh $z, 1, 2; #### print; #### print $_; #### print $x; #### print $x "oh hai\n"; #### print $y; #### print $y "hello thar\n"; #### "$]" < 5.010 # use feature 'state'; state $z print $z; #### "$]" < 5.010 # use feature 'state'; state $z print $z "lolno\n"; #### print STDOUT "bananananananana\n"; #### $x->foo($pkg->$cb) #### $obj = "apple ${\($x->new)} pear" #### $obj = "apple @{[$x->new]} pear" #### $obj = "apple ${\($y->new)} pear" #### $obj = "apple @{[$y->new]} pear" #### $obj = "apple ${\($x->$cb)} pear" #### $obj = "apple @{[$x->$cb]} pear" #### $obj = "apple ${\($y->$cb)} pear" #### $obj = "apple @{[$y->$cb]} pear" #### $obj = "apple ${\($x->$meth)} pear" #### $obj = "apple @{[$x->$meth]} pear" #### $obj = "apple ${\($y->$meth)} pear" #### $obj = "apple @{[$y->$meth]} pear" #### # local $_ = "foo"; s/foo/return; Pkg->new/e; #### # local $_ = "bar"; s/foo/return; Pkg->new/e; #### # local $_ = "foo"; s/foo/return; Pkg->$cb/e; #### # local $_ = "bar"; s/foo/return; Pkg->$cb/e; #### # local $_ = "foo"; s/foo/return; Pkg->$meth/e; #### # local $_ = "bar"; s/foo/return; Pkg->$meth/e; #### # local $_ = "foo"; s/foo/return; $x->new/e; #### # local $_ = "bar"; s/foo/return; $x->new/e; #### # local $_ = "foo"; s/foo/return; $x->$cb/e; #### # local $_ = "bar"; s/foo/return; $x->$cb/e; #### # local $_ = "foo"; s/foo/return; $x->$meth/e; #### # local $_ = "bar"; s/foo/return; $x->$meth/e; #### # local $_ = "foo"; s/foo/return; $y->new/e; #### # local $_ = "bar"; s/foo/return; $y->new/e; #### # local $_ = "foo"; s/foo/return; $y->$cb/e; #### # local $_ = "bar"; s/foo/return; $y->$cb/e; #### # local $_ = "foo"; s/foo/return; $y->$meth/e; #### # local $_ = "bar"; s/foo/return; $y->$meth/e; #### "foo" =~ /(?{Pkg->new})/; #### "foo" =~ /(?{Pkg->$cb})/; #### "foo" =~ /(?{Pkg->$meth})/; #### "foo" =~ /(?{$x->new})/; #### "foo" =~ /(?{$x->$cb})/; #### "foo" =~ /(?{$x->$meth})/; #### "foo" =~ /(?{$y->new})/; #### "foo" =~ /(?{$y->$cb})/; #### "foo" =~ /(?{$y->$meth})/; #### exec $x $x, @a; #### exec { $a[0] } @a; #### system $x $x, @a; #### system { $a[0] } @a; #### zap { }; #### zap { 1; }; #### zap { 1; 1; }; #### zap { zap { }; 1; }; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### sub { my $self = shift; return $self->new ? $self : undef; } #### sub { my $self = shift; return $self ? $self->new : undef; } #### sub { my $self = shift; return $_[0] ? undef : $self->new; } #### package Hurp; __PACKAGE__->new; #### package Hurp; __PACKAGE__->new # Hurp #### package Hurp; __PACKAGE__->new; # Hurp #### package __PACKAGE_; __PACKAGE__->new # __PACKAGE_ #### package __PACKAGE_; __PACKAGE_->new # __PACKAGE__ #### package __PACKAGE___; __PACKAGE__->new # __PACKAGE___ #### package __PACKAGE___; __PACKAGE___->new # __PACKAGE__ indirect-0.36/t/21-bad.t000644 000765 000024 00000021327 12473621134 015462 0ustar00vincentstaff000000 000000 #!perl -T package NotEmpty; sub new; package main; use strict; use warnings; my ($tests, $reports); BEGIN { $tests = 88; $reports = 100; } use Test::More tests => 3 * (4 * $tests + $reports) + 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } my ($obj, $x); our ($y, $bloop); sub expect { my ($expected) = @_; die unless $expected; map { my ($meth, $obj, $file, $line) = @$_; $meth = quotemeta $meth; $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\""; $file = '\((?:re_)?eval \d+\)' unless defined $file; $line = '\d+' unless defined $line; qr/^Indirect call of method "$meth" on $obj at $file line $line/ } eval $expected; } my @warns; sub try { my ($code) = @_; @warns = (); { local $SIG{__WARN__} = sub { push @warns, @_ }; eval $code; } } { local $/ = "####"; while () { chomp; s/\s*$//; s/(.*?)$//m; my ($skip, $prefix) = split /#+/, $1; $skip = 0 unless defined $skip; $prefix = '' unless defined $prefix; s/\s*//; SKIP: { if (do { local $@; eval $skip }) { my ($code, $expected) = split /^-{4,}$/m, $_, 2; my @expected = expect($expected); skip "$_: $skip" => 3 * (4 + @expected); } { local $_ = $_; s/Pkg/Empty/g; my ($code, $expected) = split /^-{4,}$/m, $_, 2; my @expected = expect($expected); try "return; $prefix; use indirect; $code"; is $@, '', "use indirect: $code"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $code"; is $@, '', "no indirect: $code"; is @warns, @expected, 'correct number of reports'; for my $i (0 .. $#expected) { like $warns[$i], $expected[$i], "report $i is correct"; } } { local $_ = $_; s/Pkg/NotEmpty/g; my ($code, $expected) = split /^-{4,}$/m, $_, 2; my @expected = expect($expected); try "return; $prefix; use indirect; $code"; is $@, '', "use indirect, defined: $code"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $code"; is $@, '', "no indirect, defined: $code"; is @warns, @expected, 'correct number of reports'; for my $i (0 .. $#expected) { like $warns[$i], $expected[$i], "report $i is correct"; } } SKIP: { local $_ = $_; s/Pkg/Empty/g; my ($code, $expected) = split /^-{4,}$/m, $_, 2; my @expected = expect($expected); skip 'No space tests on perl 5.11' => 4 + @expected if "$]" >= 5.011 and "$]" < 5.012; $code =~ s/\$/\$ \n\t /g; try "return; $prefix; use indirect; $code"; is $@, '', "use indirect, spaces: $code"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $code"; is $@, '', "no indirect, spaces: $code"; is @warns, @expected, 'correct number of reports'; for my $i (0 .. $#expected) { like $warns[$i], $expected[$i], "report $i is correct"; } } } } } eval { my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval "return; no indirect 'whatever'; \$obj = new Pkg1;"; } is $@, '', 'no indirect "whatever" didn\'t croak'; is @warns, 1, 'only one warning'; my $warn = shift @warns; like $warn, qr/^Indirect call of method "new" on object "Pkg1"/, 'no indirect "whatever" enables the pragma'; is_deeply \@warns, [ ], 'nothing more'; } __DATA__ $obj = new Pkg; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg if 0; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg(); ---- [ 'new', 'Pkg' ] #### $obj = new Pkg(1); ---- [ 'new', 'Pkg' ] #### $obj = new Pkg(1, 2); ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 , 2 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 , 2 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new $x; ---- [ 'new', '$x' ] #### $obj = new $x(); ---- [ 'new', '$x' ] #### $obj = new $x('foo'); ---- [ 'new', '$x' ] #### $obj = new $x qq{foo}, 1; ---- [ 'new', '$x' ] #### $obj = new $x qr{foo\s+bar}, 1 .. 1; ---- [ 'new', '$x' ] #### $obj = new $x(qw); ---- [ 'new', '$x' ] #### $obj = new $_; ---- [ 'new', '$_' ] #### $obj = new $_ ( ); ---- [ 'new', '$_' ] #### $obj = new $_ qr/foo/ ; ---- [ 'new', '$_' ] #### $obj = new $_ qq(bar baz); ---- [ 'new', '$_' ] #### meh $_; ---- [ 'meh', '$_' ] #### meh $_ 1, 2; ---- [ 'meh', '$_' ] #### meh $$; ---- [ 'meh', '$$' ] #### meh $$ 1, 2; ---- [ 'meh', '$$' ] #### meh $x; ---- [ 'meh', '$x' ] #### meh $x 1, 2; ---- [ 'meh', '$x' ] #### meh $x, 1, 2; ---- [ 'meh', '$x' ] #### meh $y; ---- [ 'meh', '$y' ] #### meh $y 1, 2; ---- [ 'meh', '$y' ] #### meh $y, 1, 2; ---- [ 'meh', '$y' ] #### "$]" < 5.010 # use feature 'state'; state $z meh $z; ---- [ 'meh', '$z' ] #### "$]" < 5.010 # use feature 'state'; state $z meh $z 1, 2; ---- [ 'meh', '$z' ] #### "$]" < 5.010 # use feature 'state'; state $z meh $z, 1, 2; ---- [ 'meh', '$z' ] #### package sploosh; our $sploosh; meh $sploosh::sploosh; ---- [ 'meh', '$sploosh::sploosh' ] #### package sploosh; our $sploosh; meh $sploosh; ---- [ 'meh', '$sploosh' ] #### package sploosh; meh $main::bloop; ---- [ 'meh', '$main::bloop' ] #### package sploosh; meh $bloop; ---- [ 'meh', '$bloop' ] #### package ma; meh $bloop; ---- [ 'meh', '$bloop' ] #### package sploosh; our $sploosh; package main; meh $sploosh::sploosh; ---- [ 'meh', '$sploosh::sploosh' ] #### new Pkg->wut; ---- [ 'new', 'Pkg' ] #### new Pkg->wut(); ---- [ 'new', 'Pkg' ] #### new Pkg->wut, "Wut"; ---- [ 'new', 'Pkg' ] #### $obj = PkgPkg Pkg; ---- [ 'PkgPkg', 'Pkg' ] #### $obj = PkgPkg Pkg; # PkgPkg Pkg ---- [ 'PkgPkg', 'Pkg' ] #### $obj = new newnew; ---- [ 'new', 'newnew' ] #### $obj = new newnew; # new newnew ---- [ 'new', 'newnew' ] #### $obj = feh feh; ---- [ 'feh', 'feh' ] #### $obj = feh feh; # feh feh ---- [ 'feh', 'feh' ] #### new Pkg (meh $x) ---- [ 'meh', '$x' ], [ 'new', 'Pkg' ] #### Pkg->new(meh $x) ---- [ 'meh', '$x' ] #### $obj = "apple ${\(new Pkg)} pear" ---- [ 'new', 'Pkg' ] #### $obj = "apple @{[new Pkg]} pear" ---- [ 'new', 'Pkg' ] #### $obj = "apple ${\(new $x)} pear" ---- [ 'new', '$x' ] #### $obj = "apple @{[new $x]} pear" ---- [ 'new', '$x' ] #### $obj = "apple ${\(new $y)} pear" ---- [ 'new', '$y' ] #### $obj = "apple @{[new $y]} pear" ---- [ 'new', '$y' ] #### $obj = "apple ${\(new $x qq|${\(stuff $y)}|)} pear" ---- [ 'stuff', '$y' ], [ 'new', '$x' ] #### $obj = "apple @{[new $x qq|@{[stuff $y]}|]} pear" ---- [ 'stuff', '$y' ], [ 'new', '$x' ] #### # local $_ = "foo"; s/foo/return; new Pkg/e; ---- [ 'new', 'Pkg' ] #### # local $_ = "bar"; s/foo/return; new Pkg/e; ---- [ 'new', 'Pkg' ] #### # local $_ = "foo"; s/foo/return; new $x/e; ---- [ 'new', '$x' ] #### # local $_ = "bar"; s/foo/return; new $x/e; ---- [ 'new', '$x' ] #### # local $_ = "foo"; s/foo/return; new $y/e; ---- [ 'new', '$y' ] #### # local $_ = "bar"; s/foo/return; new $y/e; ---- [ 'new', '$y' ] #### "foo" =~ /(?{new Pkg})/; ---- [ 'new', 'Pkg' ] #### "foo" =~ /(?{new $x})/; ---- [ 'new', '$x' ] #### "foo" =~ /(?{new $y})/; ---- [ 'new', '$y' ] #### "foo" =~ /(??{new Pkg})/; ---- [ 'new', 'Pkg' ] #### "foo" =~ /(??{new $x})/; ---- [ 'new', '$x' ] #### "foo" =~ /(??{new $y})/; ---- [ 'new', '$y' ] #### meh { }; ---- [ 'meh', '{' ] #### meh { 1; }; ---- [ 'meh', '{' ] #### meh { 1; 1; }; ---- [ 'meh', '{' ] #### meh { new Pkg; 1; }; ---- [ 'new', 'Pkg' ], [ 'meh', '{' ] #### meh { feh $x; 1; }; ---- [ 'feh', '$x' ], [ 'meh', '{' ] #### meh { feh $x; use indirect; new Pkg; 1; }; ---- [ 'feh', '$x' ], [ 'meh', '{' ] #### meh { feh $y; 1; }; ---- [ 'feh', '$y' ], [ 'meh', '{' ] #### meh { feh $x; 1; } new Pkg, feh $y; ---- [ 'feh', '$x' ], [ 'new', 'Pkg' ], [ 'feh', '$y' ], [ 'meh', '{' ] #### $obj = "apple @{[new { feh $x; meh $y; 1 }]} pear" ---- [ 'feh', '$x' ], [ 'meh', '$y' ], [ 'new', '{' ] #### package __PACKAGE_; new __PACKAGE_; ---- [ 'new', '__PACKAGE_' ] #### package __PACKAGE___; new __PACKAGE___; ---- [ 'new', '__PACKAGE___' ] #### package Hurp; new { __PACKAGE__ }; # Hurp ---- [ 'new', '{' ] #### package __PACKAGE_; new { __PACKAGE__ }; ---- [ 'new', '{' ] #### package __PACKAGE__; new { __PACKAGE__ }; ---- [ 'new', '{' ] #### package __PACKAGE___; new { __PACKAGE__ }; ---- [ 'new', '{' ] indirect-0.36/t/22-bad-mixed.t000644 000765 000024 00000002634 12473621134 016567 0ustar00vincentstaff000000 000000 #!perl -T package NotEmpty; sub new; package main; use strict; use warnings; use Test::More tests => 3 * 9; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub meh; my @warns; sub try { my ($code) = @_; @warns = (); { local $SIG{__WARN__} = sub { push @warns, @_ }; eval $code; } } { local $/ = "####"; while () { chomp; s/\s*$//; s/(.*?)$//m; my ($skip, $prefix) = split /#+/, $1; $skip = 0 unless defined $skip; $prefix = '' unless defined $prefix; s/\s*//; SKIP: { skip "$_: $skip" => 9 if do { local $@; eval $skip }; { local $_ = $_; s/Pkg/Empty/g; try "return; $prefix; use indirect; $_"; is $@, '', "use indirect: $_"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $_"; is $@, '', "no indirect: $_"; is @warns, 0, 'correct number of reports'; } { local $_ = $_; s/Pkg/NotEmpty/g; try "return; $prefix; use indirect; $_"; is $@, '', "use indirect, defined: $_"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $_"; is $@, '', "use indirect, defined: $_"; is @warns, 1, 'correct number of reports'; like $warns[0], qr/^Indirect call of method "meh" on object "NotEmpty" at \(eval \d+\) line \d+/, 'report 0 is correct'; } } } } __DATA__ meh Pkg->new; #### meh Pkg->new(); #### meh Pkg->new, "Wut"; indirect-0.36/t/23-bad-notaint.t000644 000765 000024 00000000427 12473621134 017134 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 1; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } { my @warns; { no indirect hook => sub { push @warns, \@_ }; eval { meh { } }; } is_deeply \@warns, [ [ '{', 'meh', $0, __LINE__-2 ] ], 'covering OP_CONST'; } indirect-0.36/t/30-scope.t000644 000765 000024 00000015202 12473621134 016040 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; my $tests; BEGIN { $tests = 18 } use Test::More tests => (1 + $tests + 1) + 2 + 3 + 3 + 3 + 5 + 4 + 5 + 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } use lib 't/lib'; my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18; sub expect { my ($obj, $file, $prefix) = @_; $obj = quotemeta $obj; $file = $file ? quotemeta $file : '\(eval \d+\)'; $prefix = defined $prefix ? quotemeta $prefix : 'warn:'; qr/^${prefix}Indirect call of method "new" on object "$obj" at $file line \d+/; } { my $code = do { local $/; }; my (%res, $num, @left); { local $SIG{__WARN__} = sub { ++$num; my $w = join '', 'warn:', @_; if ($w =~ /"P(\d+)"/ and not exists $res{$1}) { $res{$1} = $w; } else { push @left, "[$num] $w"; } }; eval "return; $code"; } is $@, '', 'DATA compiled fine'; for (1 .. $tests) { my $w = $res{$_}; if ($wrong{$_}) { like $w, expect("P$_"), "$_ should warn"; } else { is $w, undef, "$_ shouldn't warn"; } } is @left, 0, 'nothing left'; diag "Extraneous warnings:\n", @left if @left; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; no indirect; my $x = new Foo'; } is $@, '', "eval 'no indirect; my \$x = new Foo'"; is @w, 1, 'got one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('Foo'), 'correct warning'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; { no indirect; eval 'return; my $x = new Bar'; } } is $@, '', "no indirect; eval 'my \$x = new Bar'"; if ("$]" < 5.009_005) { is @w, 0, 'no warnings caught'; pass 'placeholder'; } else { is @w, 1, 'got one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('Bar'), 'correct warning'; } } SKIP: { skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 2 if "$]" < 5.009_005; my @w; my $test = sub { eval 'return; new XYZ' }; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; no indirect; BEGIN { $test->() }'; } is $@, '', 'eval test doesn\'t croak prematurely'; is @w, 0, 'eval did not throw a warning'; diag join "\n", 'All warnings:', @w if @w; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;"; } is $@, '', 'first require test doesn\'t croak prematurely'; is @w, 1, 'first require threw only one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('Foo'), 'first require test catch errors in current scope'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval "return; no indirect; use indirect::TestRequired2; my \$x = new Bar;"; } is $@, '', 'second require test doesn\'t croak prematurely'; @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008_003; my $w = shift @w; like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'), 'second require test caught error for Baz'; SKIP: { skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1 if "$]" < 5.009_005; $w = shift @w; like $w, expect('Blech'), 'second require test caught error for Blech'; } $w = shift @w; like $w, expect('Bar'), 'second require test caught error for Bar'; is_deeply \@w, [ ], 'second require test doesn\'t have more errors'; } { local @main::new; my (@err, @w); sub cb3 { push @err, $_[0] }; local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval <<' TESTREQUIRED3'; { package indirect::TestRequired3Z; sub new { push @main::new, __PACKAGE__ } no indirect hook => \&main::cb3; use indirect::TestRequired3X; use indirect::TestRequired3Y; new indirect::TestRequired3Z; } TESTREQUIRED3 @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008_003; is $@, '', "pragma leak when reusing callback test doesn't croak prematurely"; is_deeply \@w, [ ], "pragma leak when reusing callback test doesn't warn"; is_deeply \@err, [ map "indirect::TestRequired3$_", qw ], "pragma leak when reusing callback test caught the right errors"; is_deeply \@main::new, [ map "indirect::TestRequired3$_", qw ], "pragma leak when reusing callback test ran the three constructors"; } { eval <<' SNIP'; return; no indirect ':fatal'; use indirect::Test1::il1 (); use indirect::Test1::il2 (); SNIP is $@, '', 'RT #47902'; } # This test may not fail for the old version when ran in taint mode { my $err = eval <<' SNIP'; use indirect::TestRequired4::a0; indirect::TestRequired4::a0::error(); SNIP like $err, qr/^Can't locate object method "new" via package "X"/, 'RT #50570'; } # This test must be in the topmost scope BEGIN { eval 'use indirect::TestRequired5::a0' } my $err = indirect::TestRequired5::a0::error(); like $err, qr/^Can't locate object method "new" via package "X"/, 'identifying requires by their eval context pointer is not enough'; { my @w; no indirect hook => sub { push @w, indirect::msg(@_) }; use indirect::TestRequired6; indirect::TestRequired6::bar(); is_deeply \@w, [ ], 'indirect syntax in sub'; @w = (); indirect::TestRequired6::baz(); is_deeply \@w, [ ], 'indirect syntax in eval in sub'; } { local $@; eval { require indirect::Test2 }; is $@, '', 'direct call in string is not fooled by newlines'; } { local $@; eval { require indirect::Test3 }; like $@, expect('$x', 't/lib/indirect/Test3.pm', ''), 'indirect call in string is not fooled by newlines'; } { local $@; eval { require indirect::Test4 }; is $@, '', 'direct call in string is not fooled by more newlines'; } { local $@; eval { require indirect::Test5 }; is $@, '', 'direct call in sort in string is not fooled by newlines'; } __DATA__ my $a = new P1; { no indirect; my $b = new P2; { my $c = new P3; } { use indirect; my $d = new P4; } my $e = new P5; } my $f = new P6; no indirect; my $g = new P7; use indirect; my $h = new P8; { no indirect; eval { my $i = new P9 }; } eval { no indirect; my $j = new P10 }; { use indirect; new P11 do { use indirect; new P12 }; } { use indirect; new P13 do { no indirect; new P14 }; } { no indirect; new P15 do { use indirect; new P16 }; } { no indirect; new P17 do { no indirect; new P18 }; } indirect-0.36/t/31-hints.t000644 000765 000024 00000001044 12473621134 016054 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; SKIP: { skip 'This fails on perl 5.11.x even without using indirect' => 1 if "$]" >= 5.011 and "$]" < 5.012; local %^H = (a => 1); require indirect; # Force %^H repopulation with an Unicode match my $x = "foo"; utf8::upgrade($x); $x =~ /foo/i; my $hints = join ',', map { $_, defined $^H{$_} ? $^H{$_} : '(undef)' } sort keys(%^H); is $hints, 'a,1', 'indirect does not vivify entries in %^H'; } indirect-0.36/t/32-global.t000644 000765 000024 00000006251 12473621134 016175 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; my $tests; BEGIN { $tests = 9 } use Test::More tests => (1 + $tests + 1) + 3 + 5 + 2 + 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } use lib 't/lib'; my %wrong = map { $_ => 1 } 2, 3, 5, 6, 7, 9; sub expect { my ($pkg, $file, $prefix) = @_; $file = defined $file ? quotemeta $file : '\(eval \d+\)'; $prefix = defined $prefix ? quotemeta $prefix : 'warn:'; qr/^${prefix}Indirect call of method "new" on object "$pkg" at $file line \d+/; } { my $code = do { local $/; }; my (%res, $num, @left); { local $SIG{__WARN__} = sub { ++$num; my $w = join '', 'warn:', @_; if ($w =~ /"P(\d+)"/ and not exists $res{$1}) { $res{$1} = $w; } else { push @left, "[$num] $w"; } }; eval "return; $code"; } is $@, '', 'DATA compiled fine'; for (1 .. $tests) { my $w = $res{$_}; if ($wrong{$_}) { like $w, expect("P$_"), "$_ should warn"; } else { is $w, undef, "$_ shouldn't warn"; } } is @left, 0, 'nothing left'; diag "Extraneous warnings:\n", @left if @left; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect "global" }; BEGIN { eval q[return; new XYZ] }'; } is $@, '', 'eval test did not croak prematurely'; is @w, 1, 'eval test threw one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('XYZ'), 'eval test threw the correct warning'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect "global" }; use indirect::TestRequiredGlobal'; } is $@, '', 'require test did not croak prematurely'; is @w, 3, 'require test threw three warnings'; diag join "\n", 'All warnings:', @w if @w > 3; like $w[0], expect('ABC', 't/lib/indirect/TestRequiredGlobal.pm'), 'require test first warning is correct'; like $w[1], expect('DEF'), 'require test second warning is correct'; like $w[2], expect('GHI'), 'require test third warning is correct'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect qw }; new MNO'; } like $@, expect('MNO', undef, ''), 'fatal test throw the correct exception'; is @w, 0, 'fatal test did not throw any warning'; diag join "\n", 'All warnings:', @w if @w; } { my @w; my @h; my $hook = sub { push @h, join '', 'hook:', indirect::msg(@_) }; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect hook => $hook, "global" }; new PQR'; } is $@, '', 'hook test did not croak prematurely'; is @w, 0, 'hook test did not throw any warning'; diag join "\n", 'All warnings:', @w if @w; is @h, 1, 'hook test hooked up three violations'; diag join "\n", 'All captured violations:', @h if @h > 1; like $h[0], expect('PQR', undef, 'hook:'), 'hook test captured the correct error'; } __DATA__ my $a = new P1; { no indirect 'global'; my $b = new P2; { my $c = new P3; } { use indirect; my $d = new P4; } my $e = new P5; } my $f = new P6; no indirect; my $g = new P7; use indirect; my $h = new P8; { no indirect; eval { my $i = new P9 }; } indirect-0.36/t/33-compilation-errors.t000644 000765 000024 00000004031 12552265606 020566 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 5; use lib 't/lib'; use VPIT::TestHelpers 'capture'; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub compile_err_code { my ($fatal) = @_; if ($fatal) { $fatal = 'no indirect q[fatal]; sub foo { \$bar }'; } else { $fatal = 'no indirect;'; } return "use strict; use warnings; $fatal; baz \$_; sub qux { \$ook }"; } my $indirect_msg = qr/Indirect call of method "baz" on object "\$_"/; my $core_err1 = qr/Global symbol "\$bar"/; my $core_err2 = qr/Global symbol "\$ook"/; my $aborted = qr/Execution of -e aborted due to compilation errors\./; my $failed_req = qr/Compilation failed in require/; my $line_end = qr/[^\n]*\n/; my $compile_err_warn_exp = qr/$indirect_msg$line_end$core_err2$line_end/o; my $compile_err_fatal_exp = qr/$core_err1$line_end$indirect_msg$line_end/o; SKIP: { my ($stat, $out, $err) = capture_perl compile_err_code(0); skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; like $err, qr/\A$compile_err_warn_exp$aborted$line_end\z/o, 'no indirect warn does not hide compilation errors outside of eval'; } SKIP: { my $code = compile_err_code(0); my ($stat, $out, $err) = capture_perl "eval q[$code]; die \$@ if \$@"; skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; like $err, qr/\A$compile_err_warn_exp\z/o, 'no indirect warn does not hide compilation errors inside of eval'; } SKIP: { my ($stat, $out, $err) = capture_perl compile_err_code(1); skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; like $err, qr/\A$compile_err_fatal_exp\z/o, 'no indirect fatal does not hide compilation errors outside of eval'; } { local $@; eval compile_err_code(1); like $@, qr/\A$compile_err_fatal_exp\z/o, 'no indirect fatal does not hide compilation errors inside of eval'; } { local $@; eval { require indirect::TestCompilationError }; like $@, qr/\A$compile_err_fatal_exp$failed_req$line_end\z/o, 'no indirect fatal does not hide compilation errors inside of require'; } indirect-0.36/t/40-threads.t000644 000765 000024 00000003161 12515220022 016347 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ]; use Test::Leaner; sub expect { my ($pkg) = @_; qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/; } { no indirect; sub try { my $tid = threads->tid(); for (1 .. 2) { { my $class = "Coconut$tid"; my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval 'die "the code compiled but it shouldn\'t have\n"; no indirect ":fatal"; my $x = new ' . $class . ' 1, 2;'; } like $@ || '', expect($class), "\"no indirect\" in eval in thread $tid died as expected"; is_deeply \@warns, [ ], "\"no indirect\" in eval in thread $tid didn't warn"; } SKIP: { skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3 unless "$]" >= 5.010; my $class = "Pineapple$tid"; my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval 'return; my $y = new ' . $class . ' 1, 2;'; } is $@, '', "\"no indirect\" propagated into eval in thread $tid didn't croak"; my $first = shift @warns; like $first || '', expect($class), "\"no indirect\" propagated into eval in thread $tid warned once"; is_deeply \@warns, [ ], "\"no indirect\" propagated into eval in thread $tid warned just once"; } } } } my @threads = map spawn(\&try), 1 .. 10; $_->join for @threads; pass 'done'; done_testing(scalar(@threads) * 2 * (2 + 3) + 1); indirect-0.36/t/41-threads-teardown.t000644 000765 000024 00000003303 12525144571 020206 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ], 'run_perl', ); use Test::Leaner tests => 3; SKIP: { skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002; my $status = run_perl <<' RUN'; my ($code, @expected); BEGIN { $code = 2; @expected = qw; } sub cb { --$code if $_[0] eq shift(@expected) || q{DUMMY} } use threads; $code = threads->create(sub { eval q{return; no indirect hook => \&cb; new X;}; return $code; })->join; eval q{new Y;}; eval q{return; no indirect hook => \&cb; new Z;}; exit $code; RUN 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; } sub X2::DESTROY { eval 'no indirect; 1'; exit 1 if $@ } threads->create(sub { my $x = bless { }, 'X2'; $x->{self} = $x; return; })->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; my $code : shared; $code = 0; no indirect hook => sub { lock $code; ++$code }; sub X3::DESTROY { eval $_[0]->{code} } threads->create(sub { my $x = bless { code => 'new Z3' }, 'X3'; $x->{self} = $x; return; })->join; exit $code; RUN skip RUN_PERL_FAILED() => 1 unless defined $status; my $code = $status >> 8; is $code, 1, 'indirect checks eval STRING during global destruction at the end of a cloned thread'; } indirect-0.36/t/42-threads-global.t000644 000765 000024 00000001610 12515220271 017612 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ]; use Test::Leaner; sub expect { my ($pkg) = @_; qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/; } my $error; no indirect 'global', 'hook' => sub { $error = indirect::msg(@_) }; sub try { my $tid = threads->tid(); for my $run (1 .. 2) { my $desc = "global indirect hook (thread $tid, run $run)"; my $class = "Mango$tid"; my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval "return; my \$x = new $class 1, 2;" } is $@, '', "$desc: did not croak"; is_deeply \@warns, [ ], "$desc: no warnings"; like $error, expect($class), "$desc: correct error"; } } my @threads = map spawn(\&try), 1 .. 10; $_->join for @threads; done_testing(scalar(@threads) * 3 * 2); indirect-0.36/t/45-memory.t000644 000765 000024 00000000326 12473621134 016246 0ustar00vincentstaff000000 000000 #!perl -T use lib 't/lib'; use Test::More tests => 1; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } eval "require indirect::Test0::Oooooo::Pppppppp"; is($@, '', 'memory reallocation to an uncatched optype'); indirect-0.36/t/46-stress.t000644 000765 000024 00000001000 12473621134 016250 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; my $count; BEGIN { $count = 1_000 } use lib 't/lib'; use Test::Leaner tests => 2 * $count; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } for (1 .. $count) { my @errs; { local $SIG{__WARN__} = sub { die @_ }; eval q( return; no indirect hook => sub { push @errs, [ @_[0, 1, 3] ] }; my $x = new Wut; ); } is $@, '', "didn't croak at run $_"; is_deeply \@errs, [ [ 'Wut', 'new', 4 ] ], "got the right data at run $_"; } indirect-0.36/t/47-stress-use.t000644 000765 000024 00000001351 12473621134 017054 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3 * (2 * 1); my $n = 1_000; sub linear { my ($n, $force_use) = @_; my @lines; my $use = $force_use; for (1 .. $n) { my $stmt = $use ? 'use indirect;' : 'no indirect;'; $use = !$use unless defined $force_use; push @lines, "{ $stmt }"; } return '{ no indirect; ', @lines, '}'; } for my $test ([ 1, 'always use' ], [ 0, 'always no' ], [ undef, 'mixed' ]) { my ($force_use, $desc) = @$test; my $code = join "\n", linear $n, $force_use; my ($err, @warns); { local $SIG{__WARN__} = sub { push @warns, "@_" }; local $@; eval $code; $err = $@; } is $err, '', "linear ($desc): no errror"; is @warns, 0, "linear ($desc): no warnings"; diag $_ for @warns; } indirect-0.36/t/50-external.t000644 000765 000024 00000005121 12515220642 016546 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Config; use Test::More tests => 6; use lib 't/lib'; use VPIT::TestHelpers 'run_perl'; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } 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 '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: { 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: { 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'; } my $fork_status; 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: { my $tests = 2; skip 'fork() or pseudo-forks are required to check END blocks in subprocesses' => $tests unless defined $fork_status; skip "Could not even fork a simple process (sample returned $fork_status)" => $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'; } indirect-0.36/t/51-dd-newlines.t000644 000765 000024 00000001030 12473621134 017135 0ustar00vincentstaff000000 000000 #!perl use lib 't/lib'; use VPIT::TestHelpers; BEGIN { load_or_skip_all("Devel::Declare", 0.006007, undef); } use Test::More tests => 1; sub foo { } sub foo_magic { my($declarator, $offset) = @_; $offset += Devel::Declare::toke_move_past_token($offset); my $linestr = Devel::Declare::get_linestr(); substr $linestr, $offset, 0, "\n\n"; Devel::Declare::set_linestr($linestr); } BEGIN { Devel::Declare->setup_for("main", { foo => { const => \&foo_magic } }); } no indirect ":fatal"; sub bar { my $x; foo; $x->m; } ok 1; indirect-0.36/t/lib/000755 000765 000024 00000000000 12552274372 015076 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/000755 000765 000024 00000000000 12552274372 016677 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/Test/000755 000765 000024 00000000000 12552274372 016015 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/VPIT/000755 000765 000024 00000000000 12552274372 015660 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000034144 12552247044 020462 0ustar00vincentstaff000000 000000 package VPIT::TestHelpers; use strict; use warnings; use Config (); =head1 NAME VPIT::TestHelpers =head1 SYNTAX use VPIT::TestHelpers ( feature1 => \@feature1_args, feature2 => \@feature2_args, ); =cut sub export_to_pkg { my ($subs, $pkg) = @_; while (my ($name, $code) = each %$subs) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } return 1; } sub sanitize_prefix { my $prefix = shift; if (defined $prefix) { if (length $prefix and $prefix !~ /_$/) { $prefix .= '_'; } } else { $prefix = ''; } return $prefix; } my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); my %features = ( threads => \&init_threads, usleep => \&init_usleep, run_perl => \&init_run_perl, capture => \&init_capture, ); sub import { shift; my @opts = @_; 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 { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return $glob ? *$glob{CODE} : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } =head1 FEATURES =head2 C =over 4 =item * Import : use VPIT::TestHelpers run_perl => [ $p ] where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : none =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub fresh_perl_env (&) { my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; 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; my $perl = $^X; unless (-e $perl and -x $perl) { $perl = $Config::Config{perlpath}; unless (-e $perl and -x $perl) { return undef; } } return $handler->($perl, '-T', map("-I$_", @INC)); } sub init_run_perl { my $p = sanitize_prefix(shift); return ( run_perl => \&run_perl, "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, ); } sub run_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, '-e', $code; }; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers capture => [ $p ]; where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - Neither VMS nor OS/2 =item - L =item - L =item - L =item - On MSWin32 : L =back =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub init_capture { my $p = sanitize_prefix(shift); skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; load_or_skip_all 'IO::Handle', '0', [ ]; load_or_skip_all 'IO::Select', '0', [ ]; load_or_skip_all 'IPC::Open3', '0', [ ]; if ($^O eq 'MSWin32') { load_or_skip_all 'Socket', '0', [ ]; } return ( capture => \&capture, "${p}CAPTURE_FAILED" => \&capture_failed_msg, capture_perl => \&capture_perl, "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } # Inspired from IPC::Cmd sub capture { my @cmd = @_; my $want = wantarray; my $fail = sub { my $err = $!; my $ext_err = $^O eq 'MSWin32' ? $^E : undef; my $syscall = shift; my $args = join ', ', @_; my $msg = "$syscall($args) failed: "; if (defined $err) { no warnings 'numeric'; my ($err_code, $err_str) = (int $err, "$err"); $msg .= "$err_str ($err_code)"; } if (defined $ext_err) { no warnings 'numeric'; my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); $msg .= ", $ext_err_str ($ext_err_code)"; } die "$msg\n"; }; my ($status, $content_out, $content_err); local $@; my $ok = eval { my ($pid, $out, $err); if ($^O eq 'MSWin32') { my $pipe = sub { socketpair $_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC or $fail->(qw); shutdown $_[0], 1 or $fail->(qw); shutdown $_[1], 0 or $fail->(qw); return 1; }; local (*IN_R, *IN_W); local (*OUT_R, *OUT_W); local (*ERR_R, *ERR_W); $pipe->(*IN_R, *IN_W); $pipe->(*OUT_R, *OUT_W); $pipe->(*ERR_R, *ERR_W); $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); close *IN_W or $fail->(qw); $out = *OUT_R; $err = *ERR_R; } else { my $in = IO::Handle->new; $out = IO::Handle->new; $out->autoflush(1); $err = IO::Handle->new; $err->autoflush(1); $pid = IPC::Open3::open3($in, $out, $err, @cmd); close $in; } # Forward signals to the child (except SIGKILL) my %sig_handlers; foreach my $s (keys %SIG) { $sig_handlers{$s} = sub { kill "$s" => $pid; $SIG{$s} = $sig_handlers{$s}; }; } local $SIG{$_} = $sig_handlers{$_} for keys %SIG; unless ($want) { close $out or $fail->(qw); close $err or $fail->(qw); waitpid $pid, 0; $status = $?; return 1; } my $sel = IO::Select->new(); $sel->add($out, $err); my $fd_out = fileno $out; my $fd_err = fileno $err; my %contents; $contents{$fd_out} = ''; $contents{$fd_err} = ''; while (my @ready = $sel->can_read) { for my $fh (@ready) { my $buf; my $bytes_read = sysread $fh, $buf, 4096; if (not defined $bytes_read) { $fail->('sysread', 'fd(' . fileno($fh) . ')'); } elsif ($bytes_read) { $contents{fileno($fh)} .= $buf; } else { $sel->remove($fh); close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); last unless $sel->count; } } } waitpid $pid, 0; $status = $?; if ($^O eq 'MSWin32') { # Manual CRLF translation that couldn't be done with sysread. s/\x0D\x0A/\n/g for values %contents; } $content_out = $contents{$fd_out}; $content_err = $contents{$fd_err}; 1; }; if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err and $content_err =~ /^open3/) { # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 # could be reported to STDERR instead of being propagated, so work around # this. $ok = 0; $@ = $content_err; } if ($ok) { return ($status, $content_out, $content_err); } else { my $err = $@; chomp $err; return (undef, $err); } } sub capture_failed_msg { my $details = shift; my $msg = 'Could not capture command output'; $msg .= " ($details)" if defined $details; return $msg; } sub capture_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my @perl = @_; capture @perl, '-e', $code; }; } sub capture_perl_failed_msg { my $details = shift; my $msg = 'Could not capture perl output'; $msg .= " ($details)" if defined $details; return $msg; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers threads => [ $pkg, $threadsafe_var, $force_var ]; where : =over 8 =item - C<$pkg> is the target package name that will be exercised by this test ; =item - C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; =item - C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). =back =item * Dependencies : =over 8 =item - C 5.13.4 =item - L =item - L 1.67 =item - L 1.14 =back =item * Exports : =over 8 =item - C =back =back =cut sub init_threads { my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; if (defined $pkg and defined $threadsafe_var) { my $threadsafe; my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); if (defined $stat) { require POSIX; my $res = $stat >> 8; if ($res == POSIX::EXIT_SUCCESS()) { $threadsafe = 1; } elsif ($res == POSIX::EXIT_FAILURE()) { $threadsafe = !1; } } if (not defined $threadsafe) { skip_all "Could not detect if $pkg is thread safe or not"; } elsif (not $threadsafe) { skip_all "This $pkg is not thread safe"; } } $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; unless ($INC{'threads.pm'}) { my $test_module; if ($INC{'Test/Leaner.pm'}) { $test_module = 'Test::Leaner'; } elsif ($INC{'Test/More.pm'}) { $test_module = 'Test::More'; } die "$test_module was loaded too soon" if defined $test_module; } load_or_skip_all 'threads', $force ? '0' : '1.67', [ ]; load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; diag "Threads testing forced by \$ENV{$force_var}" if $force; return spawn => \&spawn; } 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 : (); } =head2 C =over 4 =item * Import : use VPIT::TestHelpers 'usleep' => [ @impls ]; where : =over 8 =item - C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked. When the list is empty, it defaults to all of them. =back =item * Dependencies : none =item * Exports : =over 8 =item - C =back =back =cut sub init_usleep { my (@impls) = @_; my %impls = ( 'Time::HiRes' => sub { if (do { local $@; eval { require Time::HiRes; 1 } }) { defined and diag "Using usleep() from Time::HiRes $_" for $Time::HiRes::VERSION; return \&Time::HiRes::usleep; } else { return undef; } }, 'select' => sub { if ($Config::Config{d_select}) { diag 'Using select()-based fallback usleep()'; return sub ($) { my $s = $_[0]; my $r = 0; while ($s > 0) { my ($found, $t) = select(undef, undef, undef, $s / 1e6); last unless defined $t; $t = int($t * 1e6); $s -= $t; $r += $t; } return $r; }; } else { return undef; } }, 'sleep' => sub { diag 'Using sleep()-based fallback usleep()'; return sub ($) { my $ms = int $_[0]; my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1); my $t = sleep $s; return $t * 1e6; }; }, ); @impls = qw unless @impls; my $usleep; for my $impl (@impls) { next unless defined $impl and $impls{$impl}; $usleep = $impls{$impl}->(); last if defined $usleep; } skip_all "Could not find a suitable usleep() implementation among: @impls" unless $usleep; return usleep => $usleep; } =head1 CLASSES =head2 C Syntax : { my $guard = VPIT::TestHelpers::Guard->new($coderef); ... } # $codref called here =cut package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } =head1 AUTHOR Vincent Pit, C<< >>, L. =head1 COPYRIGHT & LICENSE Copyright 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. =cut 1; indirect-0.36/t/lib/Test/Leaner.pm000644 000765 000024 00000045374 12473621134 017570 0ustar00vincentstaff000000 000000 package Test::Leaner; use 5.006; use strict; use warnings; =head1 NAME Test::Leaner - A slimmer Test::More for when you favor performance over completeness. =head1 VERSION Version 0.05 =cut our $VERSION = '0.05'; =head1 SYNOPSIS use Test::Leaner tests => 10_000; for (1 .. 10_000) { ... is $one, 1, "checking situation $_"; } =head1 DESCRIPTION When profiling some L-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L itself, even though every single test actually involved a costly C. This module aims to be a partial replacement to L in those situations where you want to run a large number of simple tests. Its functions behave the same as their L counterparts, except for the following differences : =over 4 =item * Stringification isn't forced on the test operands. However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. =item * L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. =item * C (the sub C in package C) is not aliased to L. =item * L and L don't special case regular expressions that are passed as C<'/.../'> strings. A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). =item * L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. =item * L doesn't guard for memory cycles. If the two first arguments present parallel memory cycles, the test may result in an infinite loop. =item * The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. Moreover, this allows a much faster variant of L. =item * C, C, C, C, C, C, C, C blocks and C are not implemented. =back =cut use Exporter (); my $main_process; BEGIN { $main_process = $$; if ("$]" >= 5.008 and $INC{'threads.pm'}) { my $use_ithreads = do { require Config; no warnings 'once'; $Config::Config{useithreads}; }; if ($use_ithreads) { require threads::shared; *THREADSAFE = sub () { 1 }; } } unless (defined &Test::Leaner::THREADSAFE) { *THREADSAFE = sub () { 0 } } } my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); our @EXPORT = qw< plan skip done_testing pass fail ok is isnt like unlike cmp_ok is_deeply diag note BAIL_OUT >; =head1 ENVIRONMENT =head2 C If this environment variable is set, L will replace its functions by those from L. Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. This may be useful if your L-based test script fails and you want extra diagnostics. =cut sub _handle_import_args { my @imports; my $i = 0; while ($i <= $#_) { my $item = $_[$i]; my $splice; if (defined $item) { if ($item eq 'import') { push @imports, @{ $_[$i+1] }; $splice = 2; } elsif ($item eq 'no_diag') { lock $plan if THREADSAFE; $no_diag = 1; $splice = 1; } } if ($splice) { splice @_, $i, $splice; } else { ++$i; } } return @imports; } if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { require Test::More; my $leaner_stash = \%Test::Leaner::; my $more_stash = \%Test::More::; my %stubbed; for (@EXPORT) { my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} : undef; unless (defined $replacement) { $stubbed{$_}++; $replacement = sub { @_ = ("$_ is not implemented in this version of Test::More"); goto &croak; }; } no warnings 'redefine'; $leaner_stash->{$_} = $replacement; } my $import = sub { my $class = shift; my @imports = &_handle_import_args; if (@imports == grep /^!/, @imports) { # All imports are negated, or @imports is empty my %negated; /^!(.*)/ and ++$negated{$1} for @imports; push @imports, grep !$negated{$_}, @EXPORT; } my @test_more_imports; for (@imports) { if ($stubbed{$_}) { my $pkg = caller; no strict 'refs'; *{$pkg."::$_"} = $leaner_stash->{$_}; } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) { push @test_more_imports, $_; } else { # Croak for symbols in Test::More but not in Test::Leaner Exporter::import($class, $_); } } my $test_more_import = 'Test::More'->can('import'); return unless $test_more_import; @_ = ( 'Test::More', @_, import => \@test_more_imports, ); { lock $plan if THREADSAFE; push @_, 'no_diag' if $no_diag; } goto $test_more_import; }; no warnings 'redefine'; *import = $import; return 1; } sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } BEGIN { if (THREADSAFE) { threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing; } lock $plan if THREADSAFE; $plan = undef; $test = 0; $failed = 0; } sub carp { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } sub _sanitize_comment { $_[0] =~ s/\n+\z//; $_[0] =~ s/#/\\#/g; $_[0] =~ s/\n/\n# /g; } =head1 FUNCTIONS The following functions from L are implemented and exported by default. =head2 C plan tests => $count; plan 'no_plan'; plan skip_all => $reason; See L. =cut sub plan { my ($key, $value) = @_; return unless $key; lock $plan if THREADSAFE; croak("You tried to plan twice") if defined $plan; my $plan_str; if ($key eq 'no_plan') { croak("no_plan takes no arguments") if $value; $plan = NO_PLAN; } elsif ($key eq 'tests') { croak("Got an undefined number of tests") unless defined $value; croak("You said to run 0 tests") unless $value; croak("Number of tests must be a positive integer. You gave it '$value'") unless $value =~ /^\+?[0-9]+$/; $plan = $value; $plan_str = "1..$value"; } elsif ($key eq 'skip_all') { $plan = SKIP_ALL; $plan_str = '1..0 # SKIP'; if (defined $value) { _sanitize_comment($value); $plan_str .= " $value" if length $value; } } else { my @args = grep defined, $key, $value; croak("plan() doesn't understand @args"); } if (defined $plan_str) { local $\; print $TAP_STREAM "$plan_str\n"; } exit 0 if $plan == SKIP_ALL; return 1; } sub import { my $class = shift; my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; &plan; } @_ = ($class, @imports); goto &Exporter::import; } =head2 C skip $reason => $count; See L. =cut sub skip { my ($reason, $count) = @_; lock $plan if THREADSAFE; if (not defined $count) { carp("skip() needs to know \$how_many tests are in the block") unless defined $plan and $plan == NO_PLAN; $count = 1; } elsif ($count =~ /[^0-9]/) { carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); $count = 1; } for (1 .. $count) { ++$test; my $skip_str = "ok $test # skip"; if (defined $reason) { _sanitize_comment($reason); $skip_str .= " $reason" if length $reason; } local $\; print $TAP_STREAM "$skip_str\n"; } no warnings 'exiting'; last SKIP; } =head2 C done_testing; done_testing $count; See L. =cut sub done_testing { my ($count) = @_; lock $plan if THREADSAFE; $count = $test unless defined $count; croak("Number of tests must be a positive integer. You gave it '$count'") unless $count =~ /^\+?[0-9]+$/; if (not defined $plan or $plan == NO_PLAN) { $plan = $count; # $plan can't be NO_PLAN anymore $done_testing = 1; local $\; print $TAP_STREAM "1..$plan\n"; } else { if ($done_testing) { @_ = ('done_testing() was already called'); goto &fail; } elsif ($plan != $count) { @_ = ("planned to run $plan tests but done_testing() expects $count"); goto &fail; } } return 1; } =head2 C ok $ok; ok $ok, $desc; See L. =cut sub ok ($;$) { my ($ok, $desc) = @_; lock $plan if THREADSAFE; ++$test; my $test_str = "ok $test"; $ok or do { $test_str = "not $test_str"; ++$failed; }; if (defined $desc) { _sanitize_comment($desc); $test_str .= " - $desc" if length $desc; } local $\; print $TAP_STREAM "$test_str\n"; return $ok; } =head2 C pass; pass $desc; See L. =cut sub pass (;$) { unshift @_, 1; goto &ok; } =head2 C fail; fail $desc; See L. =cut sub fail (;$) { unshift @_, 0; goto &ok; } =head2 C is $got, $expected; is $got, $expected, $desc; See L. =cut sub is ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( (not(defined $got xor defined $expected) and $got eq $expected), $desc, ); goto &ok; } =head2 C isnt $got, $expected; isnt $got, $expected, $desc; See L. =cut sub isnt ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( ((defined $got xor defined $expected) or $got ne $expected), $desc, ); goto &ok; } my %binops = ( 'or' => 'or', 'xor' => 'xor', 'and' => 'and', '||' => 'hor', ('//' => 'dor') x ("$]" >= 5.010), '&&' => 'hand', '|' => 'bor', '^' => 'bxor', '&' => 'band', 'lt' => 'lt', 'le' => 'le', 'gt' => 'gt', 'ge' => 'ge', 'eq' => 'eq', 'ne' => 'ne', 'cmp' => 'cmp', '<' => 'nlt', '<=' => 'nle', '>' => 'ngt', '>=' => 'nge', '==' => 'neq', '!=' => 'nne', '<=>' => 'ncmp', '=~' => 'like', '!~' => 'unlike', ('~~' => 'smartmatch') x ("$]" >= 5.010), '+' => 'add', '-' => 'substract', '*' => 'multiply', '/' => 'divide', '%' => 'modulo', '<<' => 'lshift', '>>' => 'rshift', '.' => 'concat', '..' => 'flipflop', '...' => 'altflipflop', ',' => 'comma', '=>' => 'fatcomma', ); my %binop_handlers; sub _create_binop_handler { my ($op) = @_; my $name = $binops{$op}; croak("Operator $op not supported") unless defined $name; { local $@; eval <<"IS_BINOP"; sub is_$name (\$\$;\$) { my (\$got, \$expected, \$desc) = \@_; \@_ = (scalar(\$got $op \$expected), \$desc); goto &ok; } IS_BINOP die $@ if $@; } $binop_handlers{$op} = do { no strict 'refs'; \&{__PACKAGE__."::is_$name"}; } } =head2 C like $got, $regexp_expected; like $got, $regexp_expected, $desc; See L. =head2 C unlike $got, $regexp_expected; unlike $got, $regexp_expected, $desc; See L. =cut { no warnings 'once'; *like = _create_binop_handler('=~'); *unlike = _create_binop_handler('!~'); } =head2 C cmp_ok $got, $op, $expected; cmp_ok $got, $op, $expected, $desc; See L. =cut sub cmp_ok ($$$;$) { my ($got, $op, $expected, $desc) = @_; my $handler = $binop_handlers{$op}; unless ($handler) { local $Test::More::Level = ($Test::More::Level || 0) + 1; $handler = _create_binop_handler($op); } @_ = ($got, $expected, $desc); goto $handler; } =head2 C is_deeply $got, $expected; is_deeply $got, $expected, $desc; See L. =cut BEGIN { local $@; if (eval { require Scalar::Util; 1 }) { *_reftype = \&Scalar::Util::reftype; } else { # Stolen from Scalar::Util::PP require B; my %tmap = qw< B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP >; *_reftype = sub ($) { my $r = shift; return undef unless length ref $r; my $t = ref B::svref_2object($r); return exists $tmap{$t} ? $tmap{$t} : length ref $$r ? 'REF' : 'SCALAR' } } } sub _deep_ref_check { my ($x, $y, $ry) = @_; no warnings qw; if ($ry eq 'ARRAY') { return 0 unless $#$x == $#$y; my ($ex, $ey); for (0 .. $#$y) { $ex = $x->[$_]; $ey = $y->[$_]; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'HASH') { return 0 unless keys(%$x) == keys(%$y); my ($ex, $ey); for (keys %$y) { return 0 unless exists $x->{$_}; $ex = $x->{$_}; $ey = $y->{$_}; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { return _deep_check($$x, $$y); } return 0; } sub _deep_check { my ($x, $y) = @_; no warnings qw; return 0 if defined $x xor defined $y; # Try object identity/eq overloading first. It also covers the case where # $x and $y are both undefined. # If either $x or $y is overloaded but none has eq overloading, the test will # break at that point. return 1 if not(ref $x xor ref $y) and $x eq $y; # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. my $ry = _reftype($y); return 0 if _reftype($x) ne $ry; # Shortcut if $x and $y are both not references and failed the previous # $x eq $y test. return 0 unless $ry; # We know that $x and $y are both references of type $ry, without overloading. _deep_ref_check($x, $y, $ry); } sub is_deeply { @_ = ( &_deep_check, $_[2], ); goto &ok; } sub _diag_fh { my $fh = shift; return unless @_; lock $plan if THREADSAFE; return if $no_diag; my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; _sanitize_comment($msg); return unless length $msg; local $\; print $fh "# $msg\n"; return 0; }; =head2 C diag @lines; See L. =cut sub diag { unshift @_, $DIAG_STREAM; goto &_diag_fh; } =head2 C note @lines; See L. =cut sub note { unshift @_, $TAP_STREAM; goto &_diag_fh; } =head2 C BAIL_OUT; BAIL_OUT $desc; See L. =cut sub BAIL_OUT { my ($desc) = @_; lock $plan if THREADSAFE; my $bail_out_str = 'Bail out!'; if (defined $desc) { _sanitize_comment($desc); $bail_out_str .= " $desc" if length $desc; # Two spaces } local $\; print $TAP_STREAM "$bail_out_str\n"; exit 255; } END { if ($main_process == $$ and not $?) { lock $plan if THREADSAFE; if (defined $plan) { if ($failed) { $? = $failed <= 254 ? $failed : 254; } elsif ($plan >= 0) { $? = $test == $plan ? 0 : 255; } if ($plan == NO_PLAN) { local $\; print $TAP_STREAM "1..$test\n"; } } } } =pod L also provides some functions of its own, which are never exported. =head2 C my $tap_fh = tap_stream; tap_stream $fh; Read/write accessor for the filehandle to which the tests are outputted. On write, it also turns autoflush on onto C<$fh>. Note that it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub tap_stream (;*) { if (@_) { $TAP_STREAM = $_[0]; my $fh = select $TAP_STREAM; $|++; select $fh; } return $TAP_STREAM; } tap_stream *STDOUT; =head2 C my $diag_fh = diag_stream; diag_stream $fh; Read/write accessor for the filehandle to which the diagnostics are printed. On write, it also turns autoflush on onto C<$fh>. Just like L, it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub diag_stream (;*) { if (@_) { $DIAG_STREAM = $_[0]; my $fh = select $DIAG_STREAM; $|++; select $fh; } return $DIAG_STREAM; } diag_stream *STDERR; =head2 C This constant evaluates to true if and only if L is thread-safe, i.e. when this version of C is at least 5.8, has been compiled with C defined, and L has been loaded B L. In that case, it also needs a working L. =head1 DEPENDENCIES L 5.6. L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Leaner =head1 COPYRIGHT & LICENSE Copyright 2010,2011,2013 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. Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L and is Copyright 1997-2007 Graham Barr, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Leaner indirect-0.36/t/lib/indirect/Test0/000755 000765 000024 00000000000 12552274372 017676 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/Test1/000755 000765 000024 00000000000 12552274372 017677 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/Test2.pm000644 000765 000024 00000000120 12473621134 020221 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[$x->new]} }; } 1; indirect-0.36/t/lib/indirect/Test3.pm000644 000765 000024 00000000117 12473621134 020230 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[new $x]} }; } 1; indirect-0.36/t/lib/indirect/Test4.pm000644 000765 000024 00000000131 12473621134 020225 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[$x ->new]} }; } 1; indirect-0.36/t/lib/indirect/Test5.pm000644 000765 000024 00000000136 12473621134 020233 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[sort $x ->new]} }; } 1; indirect-0.36/t/lib/indirect/TestCompilationError.pm000644 000765 000024 00000000203 12552265234 023355 0ustar00vincentstaff000000 000000 package indirect::TestCompilationError; use strict; use warnings; no indirect 'fatal'; sub foo { $bar } baz $_; sub qux { $ook } 1 indirect-0.36/t/lib/indirect/TestRequired1.pm000644 000765 000024 00000000150 12473621134 021724 0ustar00vincentstaff000000 000000 package indirect::TestRequired1; BEGIN { require strict; } import strict; eval 'import strict;'; 1; indirect-0.36/t/lib/indirect/TestRequired2.pm000644 000765 000024 00000000316 12473621134 021731 0ustar00vincentstaff000000 000000 package indirect::TestRequired2; no indirect; BEGIN { delete $INC{'indirect/TestRequired1.pm'} } use lib 't/lib'; use indirect::TestRequired1; eval { my $y = new Baz; }; eval 'my $z = new Blech'; 1; indirect-0.36/t/lib/indirect/TestRequired3X.pm000644 000765 000024 00000000215 12473621134 022060 0ustar00vincentstaff000000 000000 package indirect::TestRequired3X; sub new { push @main::new, __PACKAGE__ } no indirect hook => \&main::cb3; new indirect::TestRequired3X; indirect-0.36/t/lib/indirect/TestRequired3Y.pm000644 000765 000024 00000000153 12473621134 022062 0ustar00vincentstaff000000 000000 package indirect::TestRequired3Y; sub new { push @main::new, __PACKAGE__ } new indirect::TestRequired3Y; indirect-0.36/t/lib/indirect/TestRequired4/000755 000765 000024 00000000000 12552274372 021403 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/TestRequired5/000755 000765 000024 00000000000 12552274372 021404 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/TestRequired6.pm000644 000765 000024 00000000263 12473621134 021736 0ustar00vincentstaff000000 000000 package indirect::TestRequired6; sub new { bless {} } sub bar { my $foo = new indirect::TestRequired6; } sub baz { eval q{my $foo = new indirect::TestRequired6}; } 1; indirect-0.36/t/lib/indirect/TestRequiredGlobal.pm000644 000765 000024 00000000153 12473621134 022767 0ustar00vincentstaff000000 000000 package indirect::TestRequiredGlobal; sub hurp { new ABC } BEGIN { eval 'new DEF' } eval 'new GHI'; 1; indirect-0.36/t/lib/indirect/TestRequired5/a0.pm000644 000765 000024 00000000247 12473621134 022237 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::a0; no indirect ":fatal"; use indirect::TestRequired5::b0; sub error { local $@; indirect::TestRequired5::b0->get; return $@; } 1; indirect-0.36/t/lib/indirect/TestRequired5/b0.pm000644 000765 000024 00000000141 12473621134 022231 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::b0; sub get { eval 'require indirect::TestRequired5::c0'; } 1; indirect-0.36/t/lib/indirect/TestRequired5/c0.pm000644 000765 000024 00000000115 12473621134 022233 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::c0; require indirect::TestRequired5::d0; 1; indirect-0.36/t/lib/indirect/TestRequired5/d0.pm000644 000765 000024 00000000057 12473621134 022241 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::d0; new X; 1; indirect-0.36/t/lib/indirect/TestRequired4/a0.pm000644 000765 000024 00000000247 12473621134 022236 0ustar00vincentstaff000000 000000 package indirect::TestRequired4::a0; no indirect ":fatal"; use indirect::TestRequired4::b0; sub error { local $@; indirect::TestRequired4::b0->get; return $@; } 1; indirect-0.36/t/lib/indirect/TestRequired4/b0.pm000644 000765 000024 00000000141 12473621134 022230 0ustar00vincentstaff000000 000000 package indirect::TestRequired4::b0; sub get { eval 'require indirect::TestRequired4::c0'; } 1; indirect-0.36/t/lib/indirect/TestRequired4/c0.pm000644 000765 000024 00000000057 12473621134 022237 0ustar00vincentstaff000000 000000 package indirect::TestRequired4::c0; new X; 1; indirect-0.36/t/lib/indirect/Test1/il1.pm000644 000765 000024 00000000032 12473621134 020707 0ustar00vincentstaff000000 000000 no indirect ":fatal"; 1; indirect-0.36/t/lib/indirect/Test1/il2.pm000644 000765 000024 00000000076 12473621134 020720 0ustar00vincentstaff000000 000000 package indirect::Test1::il2; import indirect::Test1::il2; 1; indirect-0.36/t/lib/indirect/Test0/Fffff/000755 000765 000024 00000000000 12552274372 020713 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/Test0/Oooooo/000755 000765 000024 00000000000 12552274372 021147 5ustar00vincentstaff000000 000000 indirect-0.36/t/lib/indirect/Test0/Oooooo/Pppppppp.pm000644 000765 000024 00000000406 12473621134 023316 0ustar00vincentstaff000000 000000 package indirect::Test0::Oooooo::Pppppppp; use strict; no indirect ":fatal"; use indirect::Test0::Fffff::Vvvvvvv z => 0, x => sub { }, y => sub { }; use indirect::Test0::Fffff::Vvvvvvv t => [ xxxx => qw ], x => sub { $_[0]->method }; 1; indirect-0.36/t/lib/indirect/Test0/Fffff/Vvvvvvv.pm000644 000765 000024 00000000257 12473621134 022760 0ustar00vincentstaff000000 000000 package indirect::Test0::Fffff::Vvvvvvv; use warnings; use strict; my $f; sub import { my($class, %args) = @_; $f = bless({ x => $args{x}, y => $args{y} }, $class); } 1; indirect-0.36/samples/indirect.pl000755 000765 000024 00000002260 12473621134 017664 0ustar00vincentstaff000000 000000 #!/usr/bin/env perl #use strict; #use warnings; use lib qw; sub Hlagh::new { my $class = shift; bless { }, ref($class) || $class ; } sub foo { shift; print "foo $_[0]\n" } sub bar { print "wut\n"; } my $bar = bless { }, 'main'; my %h; my $x = 1; no indirect; $x = new Hlagh 1, 2, 3; my $y = slap $x "what", 5; $h{foo} = 12; use indirect; foo 4, 5; no indirect; my $pkg = 'Hlagh'; my $cb = 'new'; foo(6, 7, 8); my $y = new $_ qr/bar/; my $y = Hlagh->new; $y = new Hlagh; my $z = foo meh, 1, 2; $y = meh $x, 7; $y = foo(3, 4); $y = Hlagh->new(); $y = Hlagh->new(1, 2, 3); $y = Hlagh->$cb; $y = new Hlagh; $y = new Hlagh 1, 2, 3; $y = new Hlagh 1 , 2, 3; $y = new $pkg; $y = new $pkg 'what'; $y = $pkg->new; $y = $pkg->new(1, 2, 3); $y = $pkg->$cb; $y = new(Hlagh); $y = new { Hlagh }; $y = new { $y }; $y = Hlagh -> new ( 1 , 2, 3); $y = Hlagh -> $ cb ( 1 , 2, 3); $y = new Hlagh $,; $y = new Hlagh ','; print { $^H{dongs} } 'bleh'; print STDERR 1; print STDERR 'what'; print STDERR q{wat}; my $fh; print $fh 'dongs'; indirect-0.36/lib/indirect.pm000644 000765 000024 00000023431 12552264432 016771 0ustar00vincentstaff000000 000000 package indirect; use 5.008_001; use strict; use warnings; =head1 NAME indirect - Lexically warn about using the indirect method call syntax. =head1 VERSION Version 0.36 =cut our $VERSION; BEGIN { $VERSION = '0.36'; } =head1 SYNOPSIS In a script : no indirect; # lexically enables the pragma my $x = new Apple 1, 2, 3; # warns { use indirect; # lexically disables the pragma my $y = new Pear; # legit, does not warn { # lexically specify an hook called for each indirect construct no indirect hook => sub { die "You really wanted $_[0]\->$_[1] at $_[2]:$_[3]" }; my $z = new Pineapple 'fresh'; # croaks 'You really wanted...' } } try { ... }; # warns if try() hasn't been declared in this package no indirect 'fatal'; # or ':fatal', 'FATAL', ':Fatal' ... if (defied $foo) { ... } # croaks, note the typo Global uses : # Globally enable the pragma from the command-line perl -M-indirect=global -e 'my $x = new Banana;' # warns # Globally enforce the pragma each time perl is executed export PERL5OPT="-M-indirect=global,fatal" perl -e 'my $y = new Coconut;' # croaks =head1 DESCRIPTION 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 has not been declared in the current package, C actually compiles to C<< $x->foo >>, and C<< foo { key => 1 } >> to C<< 'key'->foo(1) >>. Please refer to the L section for a more complete list of reasons for avoiding this construct. This pragma currently does not warn for core functions (C, C, C or C). This may change in the future, or may be added as optional features that would be enabled by passing options to C. This module is B a source filter. =cut BEGIN { if ($ENV{PERL_INDIRECT_PM_DISABLE}) { *_tag = sub ($) { 1 }; *I_THREADSAFE = sub () { 1 }; *I_FORKSAFE = sub () { 1 }; } else { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); } } =head1 METHODS =head2 C no indirect; no indirect 'fatal'; no indirect hook => sub { my ($obj, $name, $file, $line) = @_; ... }; no indirect 'global'; no indirect 'global, 'fatal'; no indirect 'global', hook => sub { ... }; Magically called when C is encountered. Turns the module on. The policy to apply depends on what is first found in C<@opts> : =over 4 =item * If it is a string that matches C, the compilation will croak when the first indirect method call is found. This option is mutually exclusive with the C<'hook'> option. =item * If the key/value pair C<< hook => $hook >> comes first, C<$hook> will be called for each error with a string representation of the object as C<$_[0]>, the method name as C<$_[1]>, the current file as C<$_[2]> and the line number as C<$_[3]>. If and only if the object is actually a block, C<$_[0]> is assured to start by C<'{'>. This option is mutually exclusive with the C<'fatal'> option. =item * If none of C and C are specified, a warning will be emitted for each indirect method call. =item * If C<@opts> contains a string that matches C, the pragma will be globally enabled for B code compiled after the current C statement, except for code that is in the lexical scope of C. This option may come indifferently before or after the C or C options, in the case they are also passed to L. The global policy applied is the one resulting of the C or C options, thus defaults to a warning when none of those are specified : no indirect 'global'; # warn for any indirect call no indirect qw; # die on any indirect call no indirect 'global', hook => \&hook # custom global action Note that if another policy is installed by a C statement further in the code, it will overrule the global policy : no indirect 'global'; # warn globally { no indirect 'fatal'; # throw exceptions for this lexical scope ... require Some::Module; # the global policy will apply for the # compilation phase of this module } =back =cut sub _no_hook_and_fatal { require Carp; Carp::croak("The 'fatal' and 'hook' options are mutually exclusive"); } sub unimport { shift; my ($global, $fatal, $hook); while (@_) { my $arg = shift; if ($arg eq 'hook') { _no_hook_and_fatal() if $fatal; $hook = shift; } elsif ($arg =~ /^:?fatal$/i) { _no_hook_and_fatal() if defined $hook; $fatal = 1; } elsif ($arg =~ /^:?global$/i) { $global = 1; } } unless (defined $hook) { $hook = $fatal ? sub { die msg(@_) } : sub { warn msg(@_) }; } $^H |= 0x00020000; if ($global) { delete $^H{+(__PACKAGE__)}; _global($hook); } else { $^H{+(__PACKAGE__)} = _tag($hook); } return; } =head2 C use indirect; Magically called at each C. Turns the module off. As explained in L's description, an C statement will lexically override a global policy previously installed by C (if there's one). =cut sub import { $^H |= 0x00020000; $^H{+(__PACKAGE__)} = _tag(undef); return; } =head1 FUNCTIONS =head2 C my $msg = msg($object, $method, $file, $line); Returns the default error message that C generates when an indirect method call is reported. =cut sub msg { my $obj = $_[0]; join ' ', "Indirect call of method \"$_[1]\" on", ($obj =~ /^\s*\{/ ? "a block" : "object \"$obj\""), "at $_[2] line $_[3].\n"; }; =head1 CONSTANTS =head2 C True iff the module could have been built with thread-safety features enabled. =head2 C True iff this module could have been built with fork-safety features enabled. This will always be true except on Windows where it's false for perl 5.10.0 and below . =head1 DIAGNOSTICS =head2 C The default warning/exception message thrown when an indirect method call on an object is found. =head2 C The default warning/exception message thrown when an indirect method call on a block is found. =head1 ENVIRONMENT =head2 C If this environment variable is set to true when the pragma is used for the first time, the XS code won't be loaded and, although the C<'indirect'> lexical hint will be set to true in the scope of use, the pragma itself won't do anything. In this case, the pragma will always be considered to be thread-safe, and as such L will be true. This is useful for disabling C in production environments. Note that clearing this variable after C was loaded has no effect. If you want to re-enable the pragma later, you also need to reload it by deleting the C<'indirect.pm'> entry from C<%INC>. =head1 CAVEATS The implementation was tweaked to work around several limitations of vanilla C pragmas : it's thread safe, and does not suffer from a C bug that causes all pragmas to propagate into Cd scopes. Before C 5.12, C (no semicolon) at the end of a file is not seen as an indirect method call, although it is as soon as there is another token before the end (as in C or C). If you use C 5.12 or greater, those constructs are correctly reported. With 5.8 perls, the pragma does not propagate into C. This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. The search for indirect method calls happens before constant folding. Hence C will be caught. =head1 REFERENCES Numerous articles have been written about the quirks of the indirect object construct : =over 4 =item * L : B, Tom Christiansen, 1998-01-28. This historical post to the C mailing list raised awareness about the perils of this syntax. =item * L : B, 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 5.8.1. A C compiler. This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. L (standard since perl 5), L (since perl 5.6.0). =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc indirect Tests code coverage report is available at L. =head1 ACKNOWLEDGEMENTS Bram, for motivation and advices. Andrew Main and Florian Ragwitz, for testing on real-life code and reporting issues. =head1 COPYRIGHT & LICENSE 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. =cut 1; # End of indirect