indirect-0.37/000755 000765 000024 00000000000 12741213654 014062 5ustar00vincentstaff000000 000000 indirect-0.37/Changes000644 000765 000024 00000036336 12741212744 015367 0ustar00vincentstaff000000 000000 Revision history for indirect 0.37 2016-07-12 16:40 UTC + Chg : A large chunk of boilerplate XS code, which is also used in other XS modules, has been factored out of the main .xs file to a collection of .h files in the xsh subdirectory. + Fix : [RT #115392] : Intermittent segfaults with heredocs Heredocs should now be handled correctly. Thanks Graham Knop for reporting. 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.37/indirect.xs000644 000765 000024 00000043734 12741210705 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" /* --- XS helpers ---------------------------------------------------------- */ #define XSH_PACKAGE "indirect" #include "xsh/caps.h" #include "xsh/util.h" #include "xsh/mem.h" #include "xsh/ops.h" /* ... op => source position map ........................................... */ 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) { indirect_op_info_t *oi = (V); XSH_LOCAL_FREE(oi->buf, oi->size, char); XSH_LOCAL_FREE(oi, 1, indirect_op_info_t); } #define PTABLE_NEED_DELETE 1 #define PTABLE_NEED_WALK 0 #include "xsh/ptable.h" /* XSH_LOCAL_FREE() always need aTHX */ #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)) /* ... Lexical hints ....................................................... */ #define XSH_HINTS_TYPE_SV 1 #include "xsh/hints.h" /* ... Thread-local storage ................................................ */ typedef struct { ptable *map; SV *global_code; } xsh_user_cxt_t; #define XSH_THREADS_USER_CONTEXT 1 #define XSH_THREADS_USER_CLONE_NEEDS_DUP 1 #define XSH_THREADS_COMPILE_TIME_PROTECTION 1 #if XSH_THREADSAFE static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params) { new_cxt->map = ptable_new(32); new_cxt->global_code = xsh_dup_inc(old_cxt->global_code, params); return; } #endif /* XSH_THREADSAFE */ #include "xsh/threads.h" /* ... Lexical hints, continued ............................................ */ static SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) SV *hint; #if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) if (!PL_parser) return NULL; #endif hint = xsh_hints_fetch(); if (hint && SvOK(hint)) { return xsh_hints_detag(hint); } else { dXSH_CXT; if (xsh_is_loaded(&XSH_CXT)) return XSH_CXT.global_code; else return NULL; } } /* --- Compatibility wrappers ---------------------------------------------- */ #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 #if XSH_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 # ifndef PL_multi_close # define PL_multi_close PL_parser->multi_close # 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 # ifndef PL_multi_close # define PL_multi_close PL_Imulti_close # endif #endif /* ... 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 XSH_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 ----------------------------------------------------- */ /* ... op => source position map, continued ................................ */ 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; dXSH_CXT; /* No need to check for XSH_CXT.map != NULL because this code path is always * guarded by indirect_hint(). */ if (!(oi = ptable_fetch(XSH_CXT.map, o))) { XSH_LOCAL_ALLOC(oi, 1, indirect_op_info_t); ptable_store(XSH_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) { XSH_LOCAL_REALLOC(oi->buf, oi->size, 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)) dXSH_CXT; /* No need to check for XSH_CXT.map != NULL because this code path is always * guarded by indirect_hint(). */ return ptable_fetch(XSH_CXT.map, o); } static void indirect_map_delete(pTHX_ const OP *o) { #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) dXSH_CXT; if (xsh_is_loaded(&XSH_CXT) && XSH_CXT.map) ptable_delete(XSH_CXT.map, o); } /* ... Heuristics for finding a string in the source buffer ................ */ 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; const char *bufptr; bufptr = PL_multi_close == '<' ? PL_bufptr : PL_oldbufptr; if (indirect_find(sv, bufptr, &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 xsh_user_global_setup(pTHX) { xsh_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); xsh_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); xsh_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); xsh_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); xsh_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); xsh_ck_replace(OP_METHOD, indirect_ck_method, &indirect_old_ck_method); xsh_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, &indirect_old_ck_method_named); xsh_ck_replace(OP_ENTERSUB, indirect_ck_entersub, &indirect_old_ck_entersub); return; } static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { HV *stash; stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1); newCONSTSUB(stash, "I_THREADSAFE", newSVuv(XSH_THREADSAFE)); newCONSTSUB(stash, "I_FORKSAFE", newSVuv(XSH_FORKSAFE)); cxt->map = ptable_new(32); cxt->global_code = NULL; return; } static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { SvREFCNT_dec(cxt->global_code); cxt->global_code = NULL; ptable_free(cxt->map); cxt->map = NULL; return; } static void xsh_user_global_teardown(pTHX) { xsh_ck_restore(OP_CONST, &indirect_old_ck_const); xsh_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); xsh_ck_restore(OP_PADANY, &indirect_old_ck_padany); xsh_ck_restore(OP_SCOPE, &indirect_old_ck_scope); xsh_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); xsh_ck_restore(OP_METHOD, &indirect_old_ck_method); xsh_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); xsh_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); return; } /* --- XS ------------------------------------------------------------------ */ MODULE = indirect PACKAGE = indirect PROTOTYPES: ENABLE BOOT: { xsh_setup(); } #if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PPCODE: xsh_clone(); XSRETURN(0); #endif /* XSH_THREADSAFE */ SV * _tag(SV *code) PROTOTYPE: $ CODE: if (!SvOK(code)) code = NULL; else if (SvROK(code)) code = SvRV(code); RETVAL = xsh_hints_tag(code); OUTPUT: RETVAL void _global(SV *code) PROTOTYPE: $ PPCODE: if (!SvOK(code)) code = NULL; else if (SvROK(code)) code = SvRV(code); { dXSH_CXT; SvREFCNT_dec(XSH_CXT.global_code); XSH_CXT.global_code = SvREFCNT_inc(code); } XSRETURN(0); indirect-0.37/lib/000755 000765 000024 00000000000 12741213654 014630 5ustar00vincentstaff000000 000000 indirect-0.37/Makefile.PL000644 000765 000024 00000005741 12741210705 016035 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, '-DXSH_MULTIPLICITY=0'; } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' and "$]" < 5.010_001) { push @DEFINES, '-DXSH_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, 'File::Spec' => 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.37/MANIFEST000644 000765 000024 00000002505 12741207633 015215 0ustar00vincentstaff000000 000000 Changes MANIFEST META.json META.yml Makefile.PL README indirect.xs lib/indirect.pm 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 t/testcases/babycart_in_heredoc.pl t/testcases/rt115392.pl xsh/caps.h xsh/debug.h xsh/hints.h xsh/mem.h xsh/ops.h xsh/ptable.h xsh/threads.h xsh/util.h indirect-0.37/META.json000644 000765 000024 00000003310 12741213654 015500 0ustar00vincentstaff000000 000000 { "abstract" : "Lexically warn about using the indirect method call syntax.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.18, 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", "File::Spec" : "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.37", "x_serialization_backend" : "JSON::PP version 2.27400" } indirect-0.37/META.yml000644 000765 000024 00000002013 12741213654 015327 0ustar00vincentstaff000000 000000 --- abstract: 'Lexically warn about using the indirect method call syntax.' author: - 'Vincent Pit ' build_requires: Carp: '0' Config: '0' ExtUtils::MakeMaker: '0' File::Spec: '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.18, 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.37' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' indirect-0.37/README000644 000765 000024 00000021374 12741213654 014751 0ustar00vincentstaff000000 000000 NAME indirect - Lexically warn about using the indirect method call syntax. VERSION Version 0.37 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 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,2016 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.37/samples/000755 000765 000024 00000000000 12741213654 015526 5ustar00vincentstaff000000 000000 indirect-0.37/t/000755 000765 000024 00000000000 12741213654 014325 5ustar00vincentstaff000000 000000 indirect-0.37/xsh/000755 000765 000024 00000000000 12741213654 014664 5ustar00vincentstaff000000 000000 indirect-0.37/xsh/caps.h000644 000765 000024 00000002733 12741210705 015762 0ustar00vincentstaff000000 000000 #ifndef XSH_CAPS_H #define XSH_CAPS_H 1 #ifdef __cplusplus # error C++ compilers are not supported #endif #define XSH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #define XSH_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S)) #define XSH_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S))) #ifndef XSH_PERL_PATCHLEVEL # ifdef PERL_PATCHNUM # define XSH_PERL_PATCHLEVEL PERL_PATCHNUM # else # define XSH_PERL_PATCHLEVEL 0 # endif #endif #define XSH_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (XSH_PERL_PATCHLEVEL >= (P) || (!XSH_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S)))) #ifndef XSH_MULTIPLICITY # if defined(MULTIPLICITY) # define XSH_MULTIPLICITY 1 # else # define XSH_MULTIPLICITY 0 # endif #endif #if XSH_MULTIPLICITY # ifndef PERL_IMPLICIT_CONTEXT # error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT # endif # ifndef tTHX # define tTHX PerlInterpreter* # endif #endif #if XSH_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 XSH_THREADSAFE 1 #else # define XSH_THREADSAFE 0 #endif /* Safe unless stated otherwise in Makefile.PL */ #ifndef XSH_FORKSAFE # define XSH_FORKSAFE 1 #endif #endif /* XSH_CAPS_H */ indirect-0.37/xsh/debug.h000644 000765 000024 00000000733 12741210705 016120 0ustar00vincentstaff000000 000000 #ifndef XSH_DEBUG_H #define XSH_DEBUG_H 1 #include "util.h" /* XSH_PACKAGE, STMT_* */ #ifndef XSH_DEBUG # define XSH_DEBUG 0 #endif #if XSH_DEBUG # define XSH_D(X) STMT_START X STMT_END static void xsh_debug_log(const char *fmt, ...) { va_list va; SV *sv; dTHX; va_start(va, fmt); sv = get_sv(XSH_PACKAGE "::DEBUG", 0); if (sv && SvTRUE(sv)) PerlIO_vprintf(Perl_debug_log, fmt, va); va_end(va); return; } #else # define XSH_D(X) #endif #endif /* XSH_DEBUG_H */ indirect-0.37/xsh/hints.h000644 000765 000024 00000023705 12741210705 016163 0ustar00vincentstaff000000 000000 #ifndef XSH_HINTS_H #define XSH_HINTS_H 1 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE, tTHX */ #include "mem.h" /* XSH_SHARED_*() */ #ifdef XSH_THREADS_H # error threads.h must be loaded at the very end #endif #define XSH_HINTS_KEY XSH_PACKAGE #define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1) #ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION # define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1) #endif #ifndef XSH_HINTS_ONLY_COMPILE_TIME # define XSH_HINTS_ONLY_COMPILE_TIME 1 #endif #ifdef XSH_HINTS_TYPE_UV # ifdef XSH_HINTS_TYPE_VAL # error hint type can only be set once # endif # undef XSH_HINTS_TYPE_UV # define XSH_HINTS_TYPE_UV 1 # define XSH_HINTS_TYPE_STRUCT UV # define XSH_HINTS_TYPE_COMPACT UV # define XSH_HINTS_NEED_STRUCT 0 # define XSH_HINTS_VAL_STRUCT_REF 0 # define XSH_HINTS_VAL_NONE 0 # define XSH_HINTS_VAL_PACK(T, V) INT2PTR(T, (V)) # define XSH_HINTS_VAL_UNPACK(V) ((XSH_HINTS_TYPE_VAL) PTR2UV(V)) # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (V)) # undef XSH_HINTS_VAL_CLONE # undef XSH_HINTS_VAL_DEINIT #endif #ifdef XSH_HINTS_TYPE_SV # ifdef XSH_HINTS_TYPE_VAL # error hint type can only be set once # endif # undef XSH_HINTS_TYPE_SV # define XSH_HINTS_TYPE_SV 1 # define XSH_HINTS_TYPE_STRUCT SV * # define XSH_HINTS_TYPE_COMPACT SV # define XSH_HINTS_NEED_STRUCT 0 # define XSH_HINTS_VAL_STRUCT_REF 0 # define XSH_HINTS_VAL_NONE NULL # define XSH_HINTS_VAL_PACK(T, V) (V) # define XSH_HINTS_VAL_UNPACK(V) (V) # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (((V) != XSH_HINTS_VAL_NONE) ? SvREFCNT_inc(V) : XSH_HINTS_VAL_NONE)) # define XSH_HINTS_VAL_CLONE(N, O) ((N) = xsh_dup_inc((O), ud->params)) # define XSH_HINTS_VAL_DEINIT(V) SvREFCNT_dec(V) #endif #ifdef XSH_HINTS_TYPE_USER # ifdef XSH_HINTS_TYPE_VAL # error hint type can only be set once # endif # undef XSH_HINTS_TYPE_USER # define XSH_HINTS_TYPE_USER 1 # define XSH_HINTS_TYPE_STRUCT xsh_hints_user_t # undef XSH_HINTS_TYPE_COMPACT /* not used */ # define XSH_HINTS_NEED_STRUCT 1 # define XSH_HINTS_VAL_STRUCT_REF 1 # define XSH_HINTS_VAL_NONE NULL # define XSH_HINTS_VAL_PACK(T, V) (V) # define XSH_HINTS_VAL_UNPACK(V) (V) # define XSH_HINTS_VAL_INIT(HV, V) xsh_hints_user_init(aTHX_ (HV), (V)) # define XSH_HINTS_VAL_CLONE(NV, OV) xsh_hints_user_clone(aTHX_ (NV), (OV), ud->params) # define XSH_HINTS_VAL_DEINIT(V) xsh_hints_user_deinit(aTHX_ (V)) #endif #ifndef XSH_HINTS_TYPE_STRUCT # error hint type was not set #endif #if XSH_HINTS_VAL_STRUCT_REF # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT * #else # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT #endif #if XSH_WORKAROUND_REQUIRE_PROPAGATION # undef XSH_HINTS_NEED_STRUCT # define XSH_HINTS_NEED_STRUCT 1 #endif #if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION) # define XSH_HINTS_NEED_CLONE 1 #else # define XSH_HINTS_NEED_CLONE 0 #endif #if XSH_WORKAROUND_REQUIRE_PROPAGATION static UV xsh_require_tag(pTHX) { #define xsh_require_tag() xsh_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 PTR2UV(cv); } #endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */ #if XSH_HINTS_NEED_STRUCT typedef struct { XSH_HINTS_TYPE_STRUCT val; #if XSH_WORKAROUND_REQUIRE_PROPAGATION UV require_tag; #endif } xsh_hints_t; #if XSH_HINTS_VAL_STRUCT_REF # define XSH_HINTS_VAL_GET(H) (&(H)->val) #else # define XSH_HINTS_VAL_GET(H) ((H)->val) #endif #define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V)) #ifdef XSH_HINTS_VAL_DEINIT # define XSH_HINTS_FREE(H) \ if (H) XSH_HINTS_VAL_DEINIT(XSH_HINTS_VAL_GET(((xsh_hints_t *) (H)))); \ XSH_SHARED_FREE((H), 1, xsh_hints_t) #else # define XSH_HINTS_FREE(H) XSH_SHARED_FREE((H), 1, xsh_hints_t) #endif #else /* XSH_HINTS_NEED_STRUCT */ typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t; #define XSH_HINTS_VAL_GET(H) XSH_HINTS_VAL_UNPACK(H) #define XSH_HINTS_VAL_SET(H, V) STMT_START { XSH_HINTS_TYPE_VAL tmp; XSH_HINTS_VAL_INIT(tmp, (V)); (H) = XSH_HINTS_VAL_PACK(xsh_hints_t *, tmp); } STMT_END #undef XSH_HINTS_FREE #endif /* !XSH_HINTS_NEED_STRUCT */ /* ... Thread safety ....................................................... */ #if XSH_HINTS_NEED_CLONE #ifdef XSH_HINTS_FREE # define PTABLE_NAME ptable_hints # define PTABLE_VAL_FREE(V) XSH_HINTS_FREE(V) #else # define PTABLE_USE_DEFAULT 1 #endif #define PTABLE_NEED_WALK 1 #define PTABLE_NEED_DELETE 0 #include "ptable.h" #if PTABLE_WAS_DEFAULT # define ptable_hints_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V)) # define ptable_hints_free(T) ptable_default_free(aPTBL_ (T)) #else # define ptable_hints_store(T, K, V) ptable_hints_store(aPTBL_ (T), (K), (V)) # define ptable_hints_free(T) ptable_hints_free(aPTBL_ (T)) #endif #define XSH_THREADS_HINTS_CONTEXT 1 typedef struct { ptable *tbl; /* It really is a ptable_hints */ tTHX owner; } xsh_hints_cxt_t; static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX); static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) { cxt->tbl = ptable_new(4); cxt->owner = aTHX; } static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) { ptable_hints_free(cxt->tbl); cxt->owner = NULL; } typedef struct { ptable *tbl; /* It really is a ptable_hints */ CLONE_PARAMS *params; } xsh_ptable_clone_ud; static void xsh_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { xsh_ptable_clone_ud *ud = ud_; xsh_hints_t *h1 = ent->val; xsh_hints_t *h2; #if XSH_HINTS_NEED_STRUCT XSH_SHARED_ALLOC(h2, 1, xsh_hints_t); # if XSH_WORKAROUND_REQUIRE_PROPAGATION h2->require_tag = PTR2UV(xsh_dup_inc(INT2PTR(SV *, h1->require_tag), ud->params)); # endif #endif /* XSH_HINTS_NEED_STRUCT */ #ifdef XSH_HINTS_VAL_CLONE XSH_HINTS_VAL_CLONE(XSH_HINTS_VAL_GET(h2), XSH_HINTS_VAL_GET(h1)); #endif /* defined(XSH_HINTS_VAL_CLONE) */ ptable_hints_store(ud->tbl, ent->key, h2); } static void xsh_hints_clone(pTHX_ const xsh_hints_cxt_t *old_cxt, xsh_hints_cxt_t *new_cxt, CLONE_PARAMS *params) { xsh_ptable_clone_ud ud; new_cxt->tbl = ptable_new(4); new_cxt->owner = aTHX; ud.tbl = new_cxt->tbl; ud.params = params; ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud); } #endif /* XSH_HINTS_NEED_CLONE */ /* ... tag hints ........................................................... */ static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) { #define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V)) xsh_hints_t *h; if (val == XSH_HINTS_VAL_NONE) return newSVuv(0); #if XSH_HINTS_NEED_STRUCT XSH_SHARED_ALLOC(h, 1, xsh_hints_t); # if XSH_WORKAROUND_REQUIRE_PROPAGATION h->require_tag = xsh_require_tag(); # endif #endif /* XSH_HINTS_NEED_STRUCT */ XSH_HINTS_VAL_SET(h, val); #if XSH_HINTS_NEED_CLONE /* 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. */ { xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX); XSH_ASSERT(cxt->tbl); ptable_hints_store(cxt->tbl, h, h); } #endif /* !XSH_HINTS_NEED_CLONE */ return newSVuv(PTR2UV(h)); } /* ... detag hints ......................................................... */ #define xsh_hints_2uv(H) \ ((H) \ ? (SvIOK(H) \ ? SvUVX(H) \ : (SvPOK(H) \ ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \ : 0 \ ) \ ) \ : 0) static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) { #define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H)) xsh_hints_t *h; UV hint_uv; hint_uv = xsh_hints_2uv(hint); h = INT2PTR(xsh_hints_t *, hint_uv); if (!h) return XSH_HINTS_VAL_NONE; #if XSH_HINTS_NEED_CLONE { xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX); XSH_ASSERT(cxt->tbl); h = ptable_fetch(cxt->tbl, h); } #endif /* XSH_HINTS_NEED_CLONE */ #if XSH_WORKAROUND_REQUIRE_PROPAGATION if (xsh_require_tag() != h->require_tag) return XSH_HINTS_VAL_NONE; #endif return XSH_HINTS_VAL_GET(h); } /* ... fetch hints ......................................................... */ #if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5) # define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \ Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \ (PKG), (PKGLEN), (FLAGS), (PKGHASH)) #endif #ifdef cop_hints_fetch_pvn static U32 xsh_hints_key_hash = 0; # define xsh_hints_global_setup(my_perl) \ PERL_HASH(xsh_hints_key_hash, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN) #else /* defined(cop_hints_fetch_pvn) */ # define xsh_hints_global_setup(my_perl) #endif /* !defined(cop_hints_fetch_pvn) */ #define xsh_hints_global_teardown(my_perl) static SV *xsh_hints_fetch(pTHX) { #define xsh_hints_fetch() xsh_hints_fetch(aTHX) #if XSH_HINTS_ONLY_COMPILE_TIME if (IN_PERL_RUNTIME) return NULL; #endif #ifdef cop_hints_fetch_pvn return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, xsh_hints_key_hash, 0); #else { SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0); return val ? *val : NULL; } #endif } #endif /* XSH_HINTS_H */ indirect-0.37/xsh/mem.h000644 000765 000024 00000011762 12741210705 015614 0ustar00vincentstaff000000 000000 #ifndef XSH_MEM_H #define XSH_MEM_H 1 #include "util.h" /* XSH_ASSERT() */ #ifdef DEBUGGING # ifdef Poison # define XSH_POISON(D, N, T) Poison((D), (N), T) # endif # ifdef PoisonNew # define XSH_POISON_NEW(D, N, T) PoisonNew((D), (N), T) # define XSH_HAS_POISON_NEW 1 # endif # ifdef PoisonFree # define XSH_POISON_FREE(D, N, T) PoisonFree((D), (N), T) # define XSH_HAS_POISON_FREE 1 # endif #endif #ifdef XSH_POISON # ifndef XSH_POISON_NEW # define XSH_POISON_NEW(D, N, T) XSH_POISON(D, N, T) # define XSH_HAS_POISON_NEW 1 # endif # ifndef XSH_POISON_FREE # define XSH_POISON_FREE(D, N, T) XSH_POISON(D, N, T) # define XSH_HAS_POISON_FREE 1 # endif #endif #ifndef XSH_HAS_POISON_NEW # define XSH_HAS_POISON_NEW 0 #endif #ifndef XSH_HAS_POISON_FREE # define XSH_HAS_POISON_FREE 0 #endif /* --- Shared memory ------------------------------------------------------- */ /* Context for PerlMemShared_*() functions */ #ifdef PERL_IMPLICIT_SYS # define pPMS pTHX # define pPMS_ pTHX_ # define aPMS aTHX # define aPMS_ aTHX_ #else # define pPMS void # define pPMS_ # define aPMS # define aPMS_ #endif /* ... xsh_shared_alloc() .................................................. */ #if XSH_HAS_POISON_NEW static void *xsh_shared_alloc(pPMS_ size_t size) { #define xsh_shared_alloc(S) xsh_shared_alloc(aPMS_ (S)) void *p; p = PerlMemShared_malloc(size); XSH_ASSERT(p); XSH_POISON_NEW(p, size, char); return p; } #else /* XSH_HAS_POISON_NEW */ #define xsh_shared_alloc(S) PerlMemShared_malloc(S) #endif /* !XSH_HAS_POISON_NEW */ #define XSH_SHARED_ALLOC(D, N, T) ((D) = xsh_shared_alloc((N) * sizeof(T))) /* ... xsh_shared_calloc() ................................................. */ #define xsh_shared_calloc(C, S) PerlMemShared_calloc((C), (S)) #define XSH_SHARED_CALLOC(D, N, T) ((D) = xsh_shared_calloc((N), sizeof(T))) /* ... xsh_shared_free() ................................................... */ #if XSH_HAS_POISON_FREE static void xsh_shared_free(pPMS_ void *p, size_t size) { #define xsh_shared_free(P, S) xsh_shared_free(aPMS_ (P), (S)) if (p) XSH_POISON_FREE(p, size, char); PerlMemShared_free(p); return; } #else /* XSH_HAS_POISON_FREE */ #define xsh_shared_free(P, S) PerlMemShared_free(P) #endif /* !XSH_HAS_POISON_FREE */ #define XSH_SHARED_FREE(D, N, T) (xsh_shared_free((D), (N) * sizeof(T)), (D) = NULL) /* ... xsh_shared_realloc() ................................................ */ #if XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE static void *xsh_shared_realloc(pPMS_ void *p, size_t old_size, size_t new_size) { #define xsh_shared_realloc(P, OS, NS) xsh_shared_realloc(aPMS_ (P), (OS), (NS)) void *q; if (!p) return xsh_shared_alloc(new_size); if (!new_size) { xsh_shared_free(p, old_size); return xsh_shared_alloc(1); } if (new_size < old_size) XSH_POISON_FREE(((char *) p) + new_size, old_size - new_size, char); q = PerlMemShared_realloc(p, new_size); XSH_ASSERT(q); if (old_size < new_size) XSH_POISON_NEW(((char *) q) + old_size, new_size - old_size, char); return q; } #else /* XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE */ #define xsh_shared_realloc(P, OS, NS) PerlMemShared_realloc((P), (NS)) #endif /* !XSH_HAS_POISON_NEW || !XSH_HAS_POISON_FREE */ #define XSH_SHARED_REALLOC(D, OL, NL, T) ((D) = xsh_shared_realloc((D), (OL) * sizeof(T), (NL) * sizeof(T))) /* ... xsh_shared_recalloc() ............................................... */ static void *xsh_shared_recalloc(pPMS_ void *p, size_t old_size, size_t new_size) { #define xsh_shared_recalloc(P, OS, NS) xsh_shared_recalloc(aPMS_ (P), (OS), (NS)) void *q; #ifdef XSH_POISON_FREE if (new_size < old_size) XSH_POISON_FREE(((char *) p) + new_size, old_size - new_size, char); #endif /* XSH_POISON_FREE */ q = PerlMemShared_realloc(p, new_size); XSH_ASSERT(q); if (old_size < new_size) Zero(((char *) q) + old_size, new_size - old_size, char); return q; } #define XSH_SHARED_RECALLOC(D, OL, NL, T) ((D) = xsh_shared_recalloc((D), (OL) * sizeof(T), (NL) * sizeof(T))) /* --- Interpreter-local memory -------------------------------------------- */ #ifndef Newx # define Newx(D, N, T) New(0, (D), (N), T) #endif #ifndef PERL_POISON #if XSH_HAS_POISON_NEW # define XSH_LOCAL_ALLOC(D, N, T) (Newx((D), (N), T), XSH_POISON_NEW((D), (N), T)) #endif #if XSH_HAS_POISON_FREE # define XSH_LOCAL_FREE(D, N, T) (XSH_POISON_FREE((D), (N), T), Safefree(D)) #endif #if XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE # define XSH_LOCAL_REALLOC(D, OL, NL, T) ((((D) && ((NL) < (OL))) ? XSH_POISON_FREE(((T *) (D)) + (NL), (OL) - (NL), T) : NOOP), Renew((D), (NL), T), (((OL) < (NL)) ? XSH_POISON_NEW(((T *) (D)) + (OL), (NL) - (OL), T) : NOOP)) #endif #endif /* !PERL_POISON */ #ifndef XSH_LOCAL_ALLOC # define XSH_LOCAL_ALLOC(D, N, T) Newx((D), (N), T) #endif #define XSH_LOCAL_CALLOC(D, N, T) Newxz((D), (N), T) #ifndef XSH_LOCAL_FREE # define XSH_LOCAL_FREE(D, N, T) Safefree(D) #endif #ifndef XSH_LOCAL_REALLOC # define XSH_LOCAL_REALLOC(D, OL, NL, T) Renew((D), (NL), T) #endif #endif /* XSH_MEM_H */ indirect-0.37/xsh/ops.h000644 000765 000024 00000003646 12741210705 015641 0ustar00vincentstaff000000 000000 #ifndef XSH_OPS_H #define XSH_OPS_H 1 #include "caps.h" /* XSH_HAS_PERL() */ #include "util.h" /* NOOP */ #ifdef XSH_THREADS_H # error threads.h must be loaded at the very end #endif #ifndef XSH_THREADS_GLOBAL_SETUP # define XSH_THREADS_GLOBAL_SETUP 1 #endif #ifndef XSH_THREADS_GLOBAL_TEARDOWN # define XSH_THREADS_GLOBAL_TEARDOWN 1 #endif #ifndef OpSIBLING # ifdef OP_SIBLING # define OpSIBLING(O) OP_SIBLING(O) # else # define OpSIBLING(O) ((O)->op_sibling) # endif #endif #ifndef OpMAYBESIB_set # define OpMAYBESIB_set(O, S, P) ((O)->op_sibling = (S)) #endif #ifndef OP_NAME # define OP_NAME(O) (PL_op_name[(O)->op_type]) #endif #ifndef OP_CLASS # define OP_CLASS(O) (PL_opargs[(O)->op_type] & OA_CLASS_MASK) #endif #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) # define XSH_CHECK_LOCK OP_CHECK_MUTEX_LOCK # define XSH_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK #elif XSH_HAS_PERL(5, 9, 3) # define XSH_CHECK_LOCK OP_REFCNT_LOCK # define XSH_CHECK_UNLOCK OP_REFCNT_UNLOCK #else /* Before perl 5.9.3, da_ck_*() calls are already protected by the XSH_LOADED * mutex, which falls back to the OP_REFCNT mutex. Make sure we don't lock it * twice. */ # define XSH_CHECK_LOCK NOOP # define XSH_CHECK_UNLOCK NOOP #endif typedef OP *(*xsh_check_t)(pTHX_ OP *); #ifdef wrap_op_checker # define xsh_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) #else static void xsh_ck_replace(pTHX_ OPCODE type, xsh_check_t new_ck, xsh_check_t *old_ck_p) { #define xsh_ck_replace(T, NC, OCP) xsh_ck_replace(aTHX_ (T), (NC), (OCP)) XSH_CHECK_LOCK; if (!*old_ck_p) { *old_ck_p = PL_check[type]; PL_check[type] = new_ck; } XSH_CHECK_UNLOCK; } #endif static void xsh_ck_restore(pTHX_ OPCODE type, xsh_check_t *old_ck_p) { #define xsh_ck_restore(T, OCP) xsh_ck_restore(aTHX_ (T), (OCP)) XSH_CHECK_LOCK; if (*old_ck_p) { PL_check[type] = *old_ck_p; *old_ck_p = 0; } XSH_CHECK_UNLOCK; } #endif /* XSH_OPS_H */ indirect-0.37/xsh/ptable.h000644 000765 000024 00000025127 12741210705 016305 0ustar00vincentstaff000000 000000 /* 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_ALLOC/FREE(). */ #include "util.h" /* XSH_ASSERT() */ #include "mem.h" /* xPMS, XSH_SHARED_*() */ /* --- Configuration ------------------------------------------------------- */ #ifndef PTABLE_USE_DEFAULT # define PTABLE_USE_DEFAULT 0 #endif #if PTABLE_USE_DEFAULT # if defined(PTABLE_VAL_ALLOC) || defined(PTABLE_VAL_FREE) # error the default ptable is only available when PTABLE_VAL_ALLOC/FREE are unset # endif # undef PTABLE_NAME # define PTABLE_NAME ptable_default # undef PTABLE_VAL_NEED_CONTEXT # define PTABLE_VAL_NEED_CONTEXT 0 #else # ifndef PTABLE_NAME # error PTABLE_NAME must be defined # endif # ifndef PTABLE_VAL_NEED_CONTEXT # define PTABLE_VAL_NEED_CONTEXT 1 # endif #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_SPLICE # define PTABLE_NEED_SPLICE 0 #endif #ifndef PTABLE_NEED_WALK # define PTABLE_NEED_WALK 0 #endif #ifndef PTABLE_NEED_STORE # define PTABLE_NEED_STORE 1 #endif #ifndef PTABLE_NEED_VIVIFY # define PTABLE_NEED_VIVIFY 0 #elif PTABLE_NEED_VIVIFY # undef PTABLE_NEED_VIVIFY # ifndef PTABLE_VAL_ALLOC # error need to define PTABLE_VAL_ALLOC() to use ptable_vivify() # endif # define PTABLE_NEED_VIVIFY 1 #endif #ifndef PTABLE_NEED_DELETE # define PTABLE_NEED_DELETE 1 #endif #ifndef PTABLE_NEED_CLEAR # define PTABLE_NEED_CLEAR 1 #endif #undef PTABLE_NEED_ENT_VIVIFY #if PTABLE_NEED_SPLICE || PTABLE_NEED_STORE || PTABLE_NEED_VIVIFY # define PTABLE_NEED_ENT_VIVIFY 1 #else # define PTABLE_NEED_ENT_VIVIFY 0 #endif #undef PTABLE_NEED_ENT_DETACH #if PTABLE_NEED_SPLICE || PTABLE_NEED_DELETE # define PTABLE_NEED_ENT_DETACH 1 #else # define PTABLE_NEED_ENT_DETACH 0 #endif /* ... Context for ptable_*() functions calling PTABLE_VAL_ALLOC/FREE() .... */ #undef pPTBL #undef pPTBL_ #undef aPTBL #undef aPTBL_ #if PTABLE_VAL_NEED_CONTEXT # define pPTBL pTHX # define pPTBL_ pTHX_ # define aPTBL aTHX # define aPTBL_ aTHX_ #else # define pPTBL pPMS # define pPTBL_ pPMS_ # define aPTBL aPMS # define aPTBL_ aPMS_ #endif /* --- struct ----------------------------------------------------- */ #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 */ /* --- Private interface --------------------------------------------------- */ #ifndef PTABLE_HASH # define PTABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) #endif #ifndef ptable_bucket # define ptable_bucket(T, K) (PTABLE_HASH(K) & (T)->max) #endif #ifndef ptable_ent_find static ptable_ent *ptable_ent_find(const ptable *t, const void *key) { #define ptable_ent_find ptable_ent_find ptable_ent *ent; const size_t idx = ptable_bucket(t, key); ent = t->ary[idx]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } return NULL; } #endif /* !ptable_ent_find */ #if PTABLE_NEED_ENT_VIVIFY #ifndef ptable_split static void ptable_split(pPMS_ ptable *t) { #define ptable_split(T) ptable_split(aPMS_ (T)) ptable_ent **ary = t->ary; const size_t old_size = t->max + 1; size_t new_size = old_size * 2; size_t i; XSH_SHARED_RECALLOC(ary, old_size, new_size, ptable_ent *); t->max = --new_size; t->ary = ary; for (i = 0; i < old_size; i++, ary++) { ptable_ent **curentp, **entp, *ent; ent = *ary; if (!ent) continue; entp = ary; curentp = ary + old_size; do { if ((new_size & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; } else { entp = &ent->next; } ent = *entp; } while (ent); } } #endif /* !ptable_split */ #ifndef ptable_ent_vivify static ptable_ent *ptable_ent_vivify(pPMS_ ptable *t, const void *key) { #define ptable_ent_vivify(T, K) ptable_ent_vivify(aPMS_ (T), (K)) ptable_ent *ent; const size_t idx = ptable_bucket(t, key); ent = t->ary[idx]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } XSH_SHARED_ALLOC(ent, 1, ptable_ent); ent->key = key; ent->val = NULL; ent->next = t->ary[idx]; t->ary[idx] = ent; t->items++; if (ent->next && t->items > t->max) ptable_split(t); return ent; } #endif /* !ptable_ent_vivify */ #endif /* PTABLE_NEED_ENT_VIVIFY */ #if PTABLE_NEED_ENT_DETACH #ifndef ptable_ent_detach static ptable_ent *ptable_ent_detach(ptable *t, const void *key) { #define ptable_ent_detach ptable_ent_detach ptable_ent *prev, *ent; const size_t idx = ptable_bucket(t, key); prev = NULL; ent = t->ary[idx]; for (; ent; prev = ent, ent = ent->next) { if (ent->key == key) { if (prev) prev->next = ent->next; else t->ary[idx] = ent->next; break; } } return ent; } #endif /* !ptable_ent_detach */ #endif /* PTABLE_NEED_ENT_DETACH */ /* --- Public interface ---------------------------------------------------- */ /* ... Common symbols ...................................................... */ #ifndef ptable_new static ptable *ptable_new(pPMS_ size_t init_buckets) { #define ptable_new(B) ptable_new(aPMS_ (B)) ptable *t; if (init_buckets < 4) { init_buckets = 4; } else { init_buckets--; init_buckets |= init_buckets >> 1; init_buckets |= init_buckets >> 2; init_buckets |= init_buckets >> 4; init_buckets |= init_buckets >> 8; init_buckets |= init_buckets >> 16; if (sizeof(init_buckets) > 4) init_buckets |= init_buckets >> 32; init_buckets++; } XSH_ASSERT(init_buckets >= 4 && ((init_buckets & (init_buckets - 1)) == 0)); XSH_SHARED_ALLOC(t, 1, ptable); t->max = init_buckets - 1; t->items = 0; XSH_SHARED_CALLOC(t->ary, t->max + 1, ptable_ent *); return t; } #endif /* !ptable_new */ #ifndef ptable_fetch static void *ptable_fetch(const ptable *t, const void *key) { #define ptable_fetch ptable_fetch const ptable_ent *ent = ptable_ent_find(t, key); return ent ? ent->val : NULL; } #endif /* !ptable_fetch */ #if PTABLE_NEED_SPLICE #ifndef ptable_splice static void *ptable_splice(pPMS_ ptable *t, const void *key, void *new_val) { #define ptable_splice(T, K, V) ptable_splice(aPMS_ (T), (K), (V)) ptable_ent *ent; void *old_val = NULL; if (new_val) { ent = ptable_ent_vivify(t, key); old_val = ent->val; ent->val = new_val; } else { ent = ptable_ent_detach(t, key); if (ent) { old_val = ent->val; XSH_SHARED_FREE(ent, 1, ptable_ent); } } return old_val; } #endif /* !ptable_splice */ #endif /* PTABLE_NEED_SPLICE */ #if PTABLE_NEED_WALK #ifndef ptable_walk static void ptable_walk(pTHX_ ptable *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 **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_walk */ #endif /* PTABLE_NEED_WALK */ /* ... Specialized symbols ................................................. */ #if PTABLE_NEED_STORE #if !PTABLE_USE_DEFAULT || !defined(ptable_default_store) static void PTABLE_PREFIX(_store)(pPTBL_ ptable *t, const void *key, void *val){ ptable_ent *ent = ptable_ent_vivify(t, key); #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(ent->val); #endif ent->val = val; return; } # if PTABLE_USE_DEFAULT # define ptable_default_store ptable_default_store # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_store) */ #endif /* PTABLE_NEED_STORE */ #if PTABLE_NEED_VIVIFY #if !PTABLE_USE_DEFAULT || !defined(ptable_default_vivify) static void *PTABLE_PREFIX(_vivify)(pPTBL_ ptable *t, const void *key) { ptable_ent *ent = ptable_ent_vivify(t, key); if (!ent->val) { PTABLE_VAL_ALLOC(ent->val); } return ent->val; } # if PTABLE_USE_DEFAULT # define ptable_default_vivify ptable_default_vivify # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_vivify) */ #endif /* PTABLE_NEED_VIVIFY */ #if PTABLE_NEED_DELETE #if !PTABLE_USE_DEFAULT || !defined(ptable_default_delete) static void PTABLE_PREFIX(_delete)(pPTBL_ ptable *t, const void *key) { ptable_ent *ent = ptable_ent_detach(t, key); #ifdef PTABLE_VAL_FREE if (ent) { PTABLE_VAL_FREE(ent->val); } #endif XSH_SHARED_FREE(ent, 1, ptable_ent); } # if PTABLE_USE_DEFAULT # define ptable_default_delete ptable_default_delete # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_delete) */ #endif /* PTABLE_NEED_DELETE */ #if PTABLE_NEED_CLEAR #if !PTABLE_USE_DEFAULT || !defined(ptable_default_clear) static void PTABLE_PREFIX(_clear)(pPTBL_ ptable *t) { if (t && t->items) { register ptable_ent **array = t->ary; size_t idx = t->max; do { ptable_ent *entry = array[idx]; while (entry) { ptable_ent *nentry = entry->next; #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(entry->val); #endif XSH_SHARED_FREE(entry, 1, ptable_ent); entry = nentry; } array[idx] = NULL; } while (idx--); t->items = 0; } } # if PTABLE_USE_DEFAULT # define ptable_default_clear ptable_default_clear # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_clear) */ #endif /* PTABLE_NEED_CLEAR */ #if !PTABLE_USE_DEFAULT || !defined(ptable_default_free) static void PTABLE_PREFIX(_free)(pPTBL_ ptable *t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); XSH_SHARED_FREE(t->ary, t->max + 1, ptable_ent *); XSH_SHARED_FREE(t, 1, ptable); } # if PTABLE_USE_DEFAULT # define ptable_default_free ptable_default_free # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_free) */ /* --- Cleanup ------------------------------------------------------------- */ #undef PTABLE_WAS_DEFAULT #if PTABLE_USE_DEFAULT # define PTABLE_WAS_DEFAULT 1 #else # define PTABLE_WAS_DEFAULT 0 #endif #undef PTABLE_NAME #undef PTABLE_VAL_ALLOC #undef PTABLE_VAL_FREE #undef PTABLE_VAL_NEED_CONTEXT #undef PTABLE_USE_DEFAULT #undef PTABLE_NEED_SPLICE #undef PTABLE_NEED_WALK #undef PTABLE_NEED_STORE #undef PTABLE_NEED_VIVIFY #undef PTABLE_NEED_DELETE #undef PTABLE_NEED_CLEAR #undef PTABLE_NEED_ENT_VIVIFY #undef PTABLE_NEED_ENT_DETACH indirect-0.37/xsh/threads.h000644 000765 000024 00000025162 12741210705 016467 0ustar00vincentstaff000000 000000 #ifndef XSH_THREADS_H #define XSH_THREADS_H 1 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE */ #include "util.h" /* XSH_PACKAGE, dNOOP, NOOP */ #include "mem.h" /* XSH_SHARED_*() */ #ifndef XSH_THREADS_COMPILE_TIME_PROTECTION # define XSH_THREADS_COMPILE_TIME_PROTECTION 0 #endif #ifndef XSH_THREADS_USER_CONTEXT # define XSH_THREADS_USER_CONTEXT 1 #endif #ifndef XSH_THREADS_USER_GLOBAL_SETUP # define XSH_THREADS_USER_GLOBAL_SETUP 1 #endif #ifndef XSH_THREADS_USER_LOCAL_SETUP # define XSH_THREADS_USER_LOCAL_SETUP 1 #endif #ifndef XSH_THREADS_USER_LOCAL_TEARDOWN # define XSH_THREADS_USER_LOCAL_TEARDOWN 1 #endif #ifndef XSH_THREADS_USER_GLOBAL_TEARDOWN # define XSH_THREADS_USER_GLOBAL_TEARDOWN 1 #endif #ifndef XSH_THREADS_PEEP_CONTEXT # define XSH_THREADS_PEEP_CONTEXT 0 #endif #ifndef XSH_THREADS_HINTS_CONTEXT # define XSH_THREADS_HINTS_CONTEXT 0 #endif #ifndef XSH_THREADS_USER_CLONE_NEEDS_DUP # define XSH_THREADS_USER_CLONE_NEEDS_DUP 0 #endif #if XSH_THREADSAFE && (XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_USER_CLONE_NEEDS_DUP) # define XSH_THREADS_CLONE_NEEDS_DUP 1 #else # define XSH_THREADS_CLONE_NEEDS_DUP 0 #endif #if defined(XSH_OPS_H) && (!XSH_THREADS_GLOBAL_SETUP || !XSH_THREADS_GLOBAL_TEARDOWN) # error settting up hook check functions require global setup/teardown #endif #ifndef XSH_THREADS_NEED_TEARDOWN_LATE # define XSH_THREADS_NEED_TEARDOWN_LATE 0 #endif #if XSH_THREADS_NEED_TEARDOWN_LATE && (!XSH_THREADS_USER_LOCAL_TEARDOWN || !XSH_THREADS_USER_GLOBAL_TEARDOWN) # error you need to declare local or global teardown handlers to use the late teardown feature #endif #if XSH_THREADSAFE # 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 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT xsh_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 XSH_THREADSAFE /* We must use preexistent global mutexes or we will never be able to destroy * them. */ # if XSH_HAS_PERL(5, 9, 3) # define XSH_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) # define XSH_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) # else # define XSH_LOADED_LOCK OP_REFCNT_LOCK # define XSH_LOADED_UNLOCK OP_REFCNT_UNLOCK # endif #else # define XSH_LOADED_LOCK NOOP # define XSH_LOADED_UNLOCK NOOP #endif static I32 xsh_loaded = 0; #if XSH_THREADSAFE && XSH_THREADS_COMPILE_TIME_PROTECTION #define PTABLE_USE_DEFAULT 1 #include "ptable.h" #define ptable_loaded_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V)) #define ptable_loaded_delete(T, K) ptable_default_delete(aPTBL_ (T), (K)) #define ptable_loaded_free(T) ptable_default_free(aPTBL_ (T)) static ptable *xsh_loaded_cxts = NULL; static int xsh_is_loaded(pTHX_ void *cxt) { #define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C)) int res = 0; XSH_LOADED_LOCK; if (xsh_loaded_cxts && ptable_fetch(xsh_loaded_cxts, cxt)) res = 1; XSH_LOADED_UNLOCK; return res; } static int xsh_set_loaded_locked(pTHX_ void *cxt) { #define xsh_set_loaded_locked(C) xsh_set_loaded_locked(aTHX_ (C)) int global_setup = 0; if (xsh_loaded <= 0) { XSH_ASSERT(xsh_loaded == 0); XSH_ASSERT(!xsh_loaded_cxts); xsh_loaded_cxts = ptable_new(4); global_setup = 1; } ++xsh_loaded; XSH_ASSERT(xsh_loaded_cxts); ptable_loaded_store(xsh_loaded_cxts, cxt, cxt); return global_setup; } static int xsh_clear_loaded_locked(pTHX_ void *cxt) { #define xsh_clear_loaded_locked(C) xsh_clear_loaded_locked(aTHX_ (C)) int global_teardown = 0; if (xsh_loaded > 1) { XSH_ASSERT(xsh_loaded_cxts); ptable_loaded_delete(xsh_loaded_cxts, cxt); --xsh_loaded; } else if (xsh_loaded_cxts) { XSH_ASSERT(xsh_loaded == 1); ptable_loaded_free(xsh_loaded_cxts); xsh_loaded_cxts = NULL; xsh_loaded = 0; global_teardown = 1; } return global_teardown; } #else /* XSH_THREADS_COMPILE_TIME_PROTECTION */ #define xsh_is_loaded_locked(C) (xsh_loaded > 0) #define xsh_set_loaded_locked(C) ((xsh_loaded++ <= 0) ? 1 : 0) #define xsh_clear_loaded_locked(C) ((--xsh_loaded <= 0) ? 1 : 0) #if XSH_THREADSAFE static int xsh_is_loaded(pTHX_ void *cxt) { #define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C)) int res = 0; XSH_LOADED_LOCK; res = xsh_is_loaded_locked(cxt); XSH_LOADED_UNLOCK; return res; } #else #define xsh_is_loaded(C) xsh_is_loaded_locked(C) #endif #endif /* !XSH_THREADS_COMPILE_TIME_PROTECTION */ #define MY_CXT_KEY XSH_PACKAGE "::_guts" XS_VERSION typedef struct { #if XSH_THREADS_USER_CONTEXT xsh_user_cxt_t cxt_user; #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_cxt_t cxt_peep; #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_cxt_t cxt_hints; #endif #if XSH_THREADS_CLONE_NEEDS_DUP tTHX owner; #endif #if !(XSH_THREADS_USER_CONTEXT || XSH_THREADS_PEEP_CONTEXT || XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_CLONE_NEEDS_DUP) int dummy; #endif } my_cxt_t; START_MY_CXT #if XSH_THREADS_USER_CONTEXT # define dXSH_CXT dMY_CXT # define XSH_CXT (MY_CXT.cxt_user) #endif #if XSH_THREADS_USER_GLOBAL_SETUP static void xsh_user_global_setup(pTHX); #endif #if XSH_THREADS_USER_LOCAL_SETUP # if XSH_THREADS_USER_CONTEXT static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt); # else static void xsh_user_local_setup(pTHX); # endif #endif #if XSH_THREADS_USER_LOCAL_TEARDOWN # if XSH_THREADS_USER_CONTEXT static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt); # else static void xsh_user_local_teardown(pTHX); # endif #endif #if XSH_THREADS_USER_GLOBAL_TEARDOWN static void xsh_user_global_teardown(pTHX); #endif #if XSH_THREADSAFE && XSH_THREADS_USER_CONTEXT # if XSH_THREADS_USER_CLONE_NEEDS_DUP static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params); # else static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt); # endif #endif #if XSH_THREADS_PEEP_CONTEXT static xsh_peep_cxt_t *xsh_peep_get_cxt(pTHX) { dMY_CXT; XSH_ASSERT(xsh_is_loaded(&MY_CXT)); return &MY_CXT.cxt_peep; } #endif #if XSH_THREADS_HINTS_CONTEXT static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX) { dMY_CXT; XSH_ASSERT(xsh_is_loaded(&MY_CXT)); return &MY_CXT.cxt_hints; } #endif #if XSH_THREADS_NEED_TEARDOWN_LATE typedef void (*xsh_teardown_late_cb)(pTHX_ void *ud); static int xsh_teardown_late_simple_free(pTHX_ SV *sv, MAGIC *mg) { xsh_teardown_late_cb cb; cb = DPTR2FPTR(xsh_teardown_late_cb, mg->mg_ptr); XSH_LOADED_LOCK; if (xsh_loaded == 0) cb(aTHX_ NULL); XSH_LOADED_UNLOCK; return 0; } static MGVTBL xsh_teardown_late_simple_vtbl = { 0, 0, 0, 0, xsh_teardown_late_simple_free #if MGf_COPY , 0 #endif #if MGf_DUP , 0 #endif #if MGf_LOCAL , 0 #endif }; typedef struct { xsh_teardown_late_cb cb; void *ud; } xsh_teardown_late_token; static int xsh_teardown_late_arg_free(pTHX_ SV *sv, MAGIC *mg) { xsh_teardown_late_token *tok; tok = (xsh_teardown_late_token *) mg->mg_ptr; XSH_LOADED_LOCK; if (xsh_loaded == 0) tok->cb(aTHX_ tok->ud); XSH_LOADED_UNLOCK; XSH_SHARED_FREE(tok, 1, xsh_teardown_late_token); return 0; } static MGVTBL xsh_teardown_late_arg_vtbl = { 0, 0, 0, 0, xsh_teardown_late_arg_free #if MGf_COPY , 0 #endif #if MGf_DUP , 0 #endif #if MGf_LOCAL , 0 #endif }; static void xsh_teardown_late_register(pTHX_ xsh_teardown_late_cb cb, void *ud){ #define xsh_teardown_late_register(CB, UD) xsh_teardown_late_register(aTHX_ (CB), (UD)) void *ptr; if (!ud) { ptr = FPTR2DPTR(void *, cb); } else { xsh_teardown_late_token *tok; XSH_SHARED_ALLOC(tok, 1, xsh_teardown_late_token); tok->cb = cb; tok->ud = ud; ptr = tok; } if (!PL_strtab) PL_strtab = newHV(); sv_magicext((SV *) PL_strtab, NULL, PERL_MAGIC_ext, ud ? &xsh_teardown_late_arg_vtbl : &xsh_teardown_late_simple_vtbl, ptr, 0); return; } #endif /* XSH_THREADS_NEED_TEARDOWN_LATE */ static void xsh_teardown(pTHX_ void *root) { dMY_CXT; #if XSH_THREADS_USER_LOCAL_TEARDOWN # if XSH_THREADS_USER_CONTEXT xsh_user_local_teardown(aTHX_ &XSH_CXT); # else xsh_user_local_teardown(aTHX); # endif #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_local_teardown(aTHX_ &MY_CXT.cxt_peep); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_local_teardown(aTHX_ &MY_CXT.cxt_hints); #endif XSH_LOADED_LOCK; if (xsh_clear_loaded_locked(&MY_CXT)) { #if XSH_THREADS_USER_GLOBAL_TEARDOWN xsh_user_global_teardown(aTHX); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_global_teardown(aTHX); #endif } XSH_LOADED_UNLOCK; return; } static void xsh_setup(pTHX) { #define xsh_setup() xsh_setup(aTHX) MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */ XSH_LOADED_LOCK; if (xsh_set_loaded_locked(&MY_CXT)) { #if XSH_THREADS_HINTS_CONTEXT xsh_hints_global_setup(aTHX); #endif #if XSH_THREADS_USER_GLOBAL_SETUP xsh_user_global_setup(aTHX); #endif } XSH_LOADED_UNLOCK; #if XSH_THREADS_CLONE_NEEDS_DUP MY_CXT.owner = aTHX; #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_local_setup(aTHX_ &MY_CXT.cxt_hints); #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_local_setup(aTHX_ &MY_CXT.cxt_peep); #endif #if XSH_THREADS_USER_LOCAL_SETUP # if XSH_THREADS_USER_CONTEXT xsh_user_local_setup(aTHX_ &XSH_CXT); # else xsh_user_local_setup(aTHX); # endif #endif call_atexit(xsh_teardown, NULL); return; } #if XSH_THREADSAFE static void xsh_clone(pTHX) { #define xsh_clone() xsh_clone(aTHX) const my_cxt_t *old_cxt; my_cxt_t *new_cxt; { dMY_CXT; old_cxt = &MY_CXT; } { int global_setup; MY_CXT_CLONE; new_cxt = &MY_CXT; XSH_LOADED_LOCK; global_setup = xsh_set_loaded_locked(new_cxt); XSH_ASSERT(!global_setup); XSH_LOADED_UNLOCK; #if XSH_THREADS_CLONE_NEEDS_DUP new_cxt->owner = aTHX; #endif } { #if XSH_THREADS_CLONE_NEEDS_DUP XSH_DUP_PARAMS_TYPE params; xsh_dup_params_init(params, old_cxt->owner); #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_clone(aTHX_ &old_cxt->cxt_peep, &new_cxt->cxt_peep); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_clone(aTHX_ &old_cxt->cxt_hints, &new_cxt->cxt_hints, xsh_dup_params_ptr(params)); #endif #if XSH_THREADS_USER_CONTEXT # if XSH_THREADS_USER_CLONE_NEEDS_DUP xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user, xsh_dup_params_ptr(params)); # else xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user); # endif #endif #if XSH_THREADS_CLONE_NEEDS_DUP xsh_dup_params_deinit(params); #endif } return; } #endif /* XSH_THREADSAFE */ #endif /* XSH_THREADS_H */ indirect-0.37/xsh/util.h000644 000765 000024 00000003502 12741210705 016004 0ustar00vincentstaff000000 000000 #ifndef XSH_UTIL_H #define XSH_UTIL_H 1 #include "caps.h" /* XSH_HAS_PERL() */ #ifndef XSH_PACKAGE # error XSH_PACKAGE must be defined #endif #define XSH_PACKAGE_LEN (sizeof(XSH_PACKAGE)-1) #ifdef DEBUGGING # if XSH_HAS_PERL(5, 8, 9) || XSH_HAS_PERL(5, 9, 3) # define XSH_ASSERT(C) assert(C) # else # ifdef PERL_DEB # define XSH_DEB(X) PERL_DEB(X) # else # define XSH_DEB(X) (X) # endif # define XSH_ASSERT(C) XSH_DEB( \ ((C) ? ((void) 0) \ : (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ "\", line %d", STRINGIFY(C), __LINE__), \ (void) 0))) # endif #else # define XSH_ASSERT(C) #endif #ifndef STMT_START # define STMT_START do #endif #ifndef STMT_END # define STMT_END while (0) #endif #ifndef dNOOP # define dNOOP #endif #ifndef NOOP # define NOOP #endif #if XSH_HAS_PERL(5, 13, 2) # define XSH_DUP_PARAMS_TYPE CLONE_PARAMS * # define xsh_dup_params_init(P, O) ((P) = Perl_clone_params_new((O), aTHX)) # define xsh_dup_params_deinit(P) Perl_clone_params_del(P) # define xsh_dup_params_ptr(P) (P) #else # define XSH_DUP_PARAMS_TYPE CLONE_PARAMS # define xsh_dup_params_init(P, O) \ ((P).stashes = newAV()); (P).flags = 0; ((P).proto_perl = (O)) # define xsh_dup_params_deinit(P) SvREFCNT_dec((P).stashes) # define xsh_dup_params_ptr(P) &(P) #endif #define xsh_dup(S, P) sv_dup((S), (P)) #define xsh_dup_inc(S, P) SvREFCNT_inc(xsh_dup((S), (P))) #ifdef USE_ITHREADS # define XSH_LOCK(M) MUTEX_LOCK(M) # define XSH_UNLOCK(M) MUTEX_UNLOCK(M) #else # define XSH_LOCK(M) NOOP # define XSH_UNLOCK(M) NOOP #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef DPTR2FPTR # define DPTR2FPTR(t,p) ((t)PTR2nat(p)) #endif #ifndef FPTR2DPTR # define FPTR2DPTR(t,p) ((t)PTR2nat(p)) #endif #endif /* XSH_UTIL_H */ indirect-0.37/t/00-load.t000644 000765 000024 00000000240 12741210705 015634 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.37/t/09-load-threads.t000644 000765 000024 00000017172 12741210705 017311 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; 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 $parent = 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 $parent; $parent->join; if (my $err = $parent->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: { lock $locks_up[$id]; my $timeout = time() + 10; until ($locks_up[$id] == $peers) { if (cond_timedwait $locks_up[$id], $timeout) { last LOCK; } else { return 0; } } } return 1; } 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]; } return 1; } 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 1; }); 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 1; }); 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'; } # Test simple clone SKIP: { my $parent = spawn(sub { my $here = 'simple clone, parent thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; SKIP: { my $kid = spawn(sub { my $here = 'simple clone, child thread'; is_loaded 1, "$here, beginning"; return; }); skip "$could_not_create_thread (simple clone child)" => 1 unless defined $kid; $kid->join; if (my $err = $kid->error) { die "in child thread: $err\n"; } } is_loaded 1, "$here, after child terminated"; return; }); skip "$could_not_create_thread (simple clone parent)" => (3 + 1) unless defined $parent; $parent->join; if (my $err = $parent->error) { die $err; } } is_loaded 0, 'main body, after simple clone'; # Test clone outliving its parent SKIP: { my $kid_done; share($kid_done); my $parent = spawn(sub { my $here = 'outliving clone, parent thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; my $kid_tid; SKIP: { my $kid = spawn(sub { my $here = 'outliving clone, child thread'; is_loaded 1, "$here, beginning"; { lock $kid_done; cond_wait $kid_done until $kid_done; } is_loaded 1, "$here, end"; return 1; }); if (defined $kid) { $kid_tid = $kid->tid; } else { $kid_tid = 0; skip "$could_not_create_thread (outliving clone child)" => 2; } } is_loaded 1, "$here, end"; return $kid_tid; }); skip "$could_not_create_thread (outliving clone parent)" => (3 + 2) unless defined $parent; my $kid_tid = $parent->join; if (my $err = $parent->error) { die $err; } if ($kid_tid) { my $kid = threads->object($kid_tid); if (defined $kid) { if ($kid->is_running) { lock $kid_done; $kid_done = 1; cond_signal $kid_done; } $kid->join; } } } is_loaded 0, 'main body, after outliving clone'; do_load; is_loaded 1, 'main body, loaded at end'; done_testing(); indirect-0.37/t/10-args.t000644 000765 000024 00000003723 12741210705 015663 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.37/t/11-line.t000644 000765 000024 00000001747 12741210705 015663 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.37/t/12-env.t000644 000765 000024 00000000720 12741210705 015513 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.37/t/20-good.t000644 000765 000024 00000017571 12741210705 015666 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.37/t/21-bad.t000644 000765 000024 00000021327 12741210705 015457 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.37/t/22-bad-mixed.t000644 000765 000024 00000002634 12741210705 016564 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.37/t/23-bad-notaint.t000644 000765 000024 00000000427 12741210705 017131 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.37/t/30-scope.t000644 000765 000024 00000015202 12741210705 016035 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.37/t/31-hints.t000644 000765 000024 00000001044 12741210705 016051 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.37/t/32-global.t000644 000765 000024 00000006251 12741210705 016172 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.37/t/33-compilation-errors.t000644 000765 000024 00000004031 12741210705 020555 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.37/t/40-threads.t000644 000765 000024 00000003115 12741210705 016357 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; indirect-0.37/t/41-threads-teardown.t000644 000765 000024 00000003303 12741210705 020200 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.37/t/42-threads-global.t000644 000765 000024 00000001574 12741210705 017626 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; pass 'done'; done_testing; indirect-0.37/t/45-memory.t000644 000765 000024 00000000326 12741210705 016243 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.37/t/46-stress.t000644 000765 000024 00000001000 12741210705 016245 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.37/t/47-stress-use.t000644 000765 000024 00000001351 12741210705 017051 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.37/t/50-external.t000644 000765 000024 00000005712 12741210705 016555 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Config; use Test::More tests => 8; 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'; } SKIP: { my $status; for my $run (1 .. 10) { $status = run_perl_file 't/testcases/rt115392.pl'; skip RUN_PERL_FAILED() => 1 unless defined $status; last if $status; } is $status, 0, 'RT #115392'; } SKIP: { my $status = run_perl_file 't/testcases/babycart_in_heredoc.pl'; skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'babycart in heredoc'; } indirect-0.37/t/51-dd-newlines.t000644 000765 000024 00000001030 12741210705 017132 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.37/t/lib/000755 000765 000024 00000000000 12741213654 015073 5ustar00vincentstaff000000 000000 indirect-0.37/t/testcases/000755 000765 000024 00000000000 12741213654 016323 5ustar00vincentstaff000000 000000 indirect-0.37/t/testcases/babycart_in_heredoc.pl000644 000765 000024 00000000167 12741210705 022624 0ustar00vincentstaff000000 000000 no indirect hook => sub { exit("$_[0] $_[1]" eq "X new" ? 0 : 1) }; <<"FOO"; abc @{[ new X ]} def FOO BEGIN { exit 2 } indirect-0.37/t/testcases/rt115392.pl000644 000765 000024 00000002001 12741210705 017755 0ustar00vincentstaff000000 000000 no indirect; <<'END_CODE1'; xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx END_CODE1 <<'END_CODE2'; xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx END_CODE2 indirect-0.37/t/lib/indirect/000755 000765 000024 00000000000 12741213654 016674 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/Test/000755 000765 000024 00000000000 12741213654 016012 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/VPIT/000755 000765 000024 00000000000 12741213654 015655 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000035526 12741210705 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 : =over 8 =item - L =back =item * Exports : =over 8 =item - C =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); # This is only required for run_perl_file(), so it is not needed for the # threads feature which only calls run_perl() - don't forget to update its # requirements if this ever changes. require File::Spec; return ( run_perl => \&run_perl, run_perl_file => \&run_perl_file, "${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; }; } sub run_perl_file { my $file = shift; $file = File::Spec->rel2abs($file); unless (-e $file and -r _) { die 'Could not run perl file'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, $file; }; } =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 =item * Notes : =over 8 =item - C<< exit => 'threads_only' >> is passed to C<< threads->import >>. =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; # run_perl() doesn't actually require anything 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', [ exit => 'threads_only', ]; 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.37/t/lib/Test/Leaner.pm000644 000765 000024 00000045374 12741210705 017565 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.37/t/lib/indirect/Test0/000755 000765 000024 00000000000 12741213654 017673 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/indirect/Test1/000755 000765 000024 00000000000 12741213654 017674 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/indirect/Test2.pm000644 000765 000024 00000000120 12741210705 020216 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[$x->new]} }; } 1; indirect-0.37/t/lib/indirect/Test3.pm000644 000765 000024 00000000117 12741210705 020225 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[new $x]} }; } 1; indirect-0.37/t/lib/indirect/Test4.pm000644 000765 000024 00000000131 12741210705 020222 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[$x ->new]} }; } 1; indirect-0.37/t/lib/indirect/Test5.pm000644 000765 000024 00000000136 12741210705 020230 0ustar00vincentstaff000000 000000 no indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[sort $x ->new]} }; } 1; indirect-0.37/t/lib/indirect/TestCompilationError.pm000644 000765 000024 00000000203 12741210705 023347 0ustar00vincentstaff000000 000000 package indirect::TestCompilationError; use strict; use warnings; no indirect 'fatal'; sub foo { $bar } baz $_; sub qux { $ook } 1 indirect-0.37/t/lib/indirect/TestRequired1.pm000644 000765 000024 00000000150 12741210705 021721 0ustar00vincentstaff000000 000000 package indirect::TestRequired1; BEGIN { require strict; } import strict; eval 'import strict;'; 1; indirect-0.37/t/lib/indirect/TestRequired2.pm000644 000765 000024 00000000316 12741210705 021726 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.37/t/lib/indirect/TestRequired3X.pm000644 000765 000024 00000000215 12741210705 022055 0ustar00vincentstaff000000 000000 package indirect::TestRequired3X; sub new { push @main::new, __PACKAGE__ } no indirect hook => \&main::cb3; new indirect::TestRequired3X; indirect-0.37/t/lib/indirect/TestRequired3Y.pm000644 000765 000024 00000000153 12741210705 022057 0ustar00vincentstaff000000 000000 package indirect::TestRequired3Y; sub new { push @main::new, __PACKAGE__ } new indirect::TestRequired3Y; indirect-0.37/t/lib/indirect/TestRequired4/000755 000765 000024 00000000000 12741213654 021400 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/indirect/TestRequired5/000755 000765 000024 00000000000 12741213654 021401 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/indirect/TestRequired6.pm000644 000765 000024 00000000263 12741210705 021733 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.37/t/lib/indirect/TestRequiredGlobal.pm000644 000765 000024 00000000153 12741210705 022764 0ustar00vincentstaff000000 000000 package indirect::TestRequiredGlobal; sub hurp { new ABC } BEGIN { eval 'new DEF' } eval 'new GHI'; 1; indirect-0.37/t/lib/indirect/TestRequired5/a0.pm000644 000765 000024 00000000247 12741210705 022234 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::a0; no indirect ":fatal"; use indirect::TestRequired5::b0; sub error { local $@; indirect::TestRequired5::b0->get; return $@; } 1; indirect-0.37/t/lib/indirect/TestRequired5/b0.pm000644 000765 000024 00000000141 12741210705 022226 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::b0; sub get { eval 'require indirect::TestRequired5::c0'; } 1; indirect-0.37/t/lib/indirect/TestRequired5/c0.pm000644 000765 000024 00000000115 12741210705 022230 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::c0; require indirect::TestRequired5::d0; 1; indirect-0.37/t/lib/indirect/TestRequired5/d0.pm000644 000765 000024 00000000057 12741210705 022236 0ustar00vincentstaff000000 000000 package indirect::TestRequired5::d0; new X; 1; indirect-0.37/t/lib/indirect/TestRequired4/a0.pm000644 000765 000024 00000000247 12741210705 022233 0ustar00vincentstaff000000 000000 package indirect::TestRequired4::a0; no indirect ":fatal"; use indirect::TestRequired4::b0; sub error { local $@; indirect::TestRequired4::b0->get; return $@; } 1; indirect-0.37/t/lib/indirect/TestRequired4/b0.pm000644 000765 000024 00000000141 12741210705 022225 0ustar00vincentstaff000000 000000 package indirect::TestRequired4::b0; sub get { eval 'require indirect::TestRequired4::c0'; } 1; indirect-0.37/t/lib/indirect/TestRequired4/c0.pm000644 000765 000024 00000000057 12741210705 022234 0ustar00vincentstaff000000 000000 package indirect::TestRequired4::c0; new X; 1; indirect-0.37/t/lib/indirect/Test1/il1.pm000644 000765 000024 00000000032 12741210705 020704 0ustar00vincentstaff000000 000000 no indirect ":fatal"; 1; indirect-0.37/t/lib/indirect/Test1/il2.pm000644 000765 000024 00000000076 12741210705 020715 0ustar00vincentstaff000000 000000 package indirect::Test1::il2; import indirect::Test1::il2; 1; indirect-0.37/t/lib/indirect/Test0/Fffff/000755 000765 000024 00000000000 12741213654 020710 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/indirect/Test0/Oooooo/000755 000765 000024 00000000000 12741213654 021144 5ustar00vincentstaff000000 000000 indirect-0.37/t/lib/indirect/Test0/Oooooo/Pppppppp.pm000644 000765 000024 00000000406 12741210705 023313 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.37/t/lib/indirect/Test0/Fffff/Vvvvvvv.pm000644 000765 000024 00000000257 12741210705 022755 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.37/samples/indirect.pl000755 000765 000024 00000002260 12741210705 017661 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.37/lib/indirect.pm000644 000765 000024 00000023301 12741212760 016763 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.37 =cut our $VERSION; BEGIN { $VERSION = '0.37'; } =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 =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,2016 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