Hello community, here is the log from the commit of package perl-indirect for openSUSE:Factory checked in at 2015-07-20 11:22:26 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/perl-indirect (Old) and /work/SRC/openSUSE:Factory/.perl-indirect.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-indirect" Changes: -------- --- /work/SRC/openSUSE:Factory/perl-indirect/perl-indirect.changes 2015-04-15 16:22:36.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.perl-indirect.new/perl-indirect.changes 2015-07-20 11:22:39.000000000 +0200 @@ -1,0 +2,12 @@ +Sat Jul 18 09:20:09 UTC 2015 - co...@suse.com + +- updated to 0.36 + see /usr/share/doc/packages/perl-indirect/Changes + + 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. + +------------------------------------------------------------------- Old: ---- indirect-0.35.tar.gz New: ---- cpanspec.yml indirect-0.36.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-indirect.spec ++++++ --- /var/tmp/diff_new_pack.Spicoh/_old 2015-07-20 11:22:41.000000000 +0200 +++ /var/tmp/diff_new_pack.Spicoh/_new 2015-07-20 11:22:41.000000000 +0200 @@ -17,14 +17,15 @@ Name: perl-indirect -Version: 0.35 +Version: 0.36 Release: 0 %define cpan_name indirect -Summary: Lexically warn about using the indirect method call syntax. +Summary: Lexically warn about using the indirect method call syntax License: Artistic-1.0 or GPL-1.0+ Group: Development/Libraries/Perl Url: http://search.cpan.org/dist/indirect/ -Source: http://www.cpan.org/authors/id/V/VP/VPIT/%{cpan_name}-%{version}.tar.gz +Source0: http://www.cpan.org/authors/id/V/VP/VPIT/%{cpan_name}-%{version}.tar.gz +Source1: cpanspec.yml BuildRoot: %{_tmppath}/%{name}-%{version}-build BuildRequires: perl BuildRequires: perl-macros @@ -64,6 +65,6 @@ %files -f %{name}.files %defattr(-,root,root,755) -%doc Changes README +%doc Changes README samples %changelog ++++++ cpanspec.yml ++++++ --- #description_paragraphs: 3 #no_testing: broken upstream #sources: # - source1 # - source2 #patches: # foo.patch: -p1 # bar.patch: #preamble: |- # BuildRequires: gcc-c++ #post_prep: |- # hunspell=`pkg-config --libs hunspell | sed -e 's,-l,,; s, *,,g'` # sed -i -e "s,hunspell-X,$hunspell," t/00-prereq.t Makefile.PL #post_install: |- # sed on %{name}.files #license: SUSE-NonFree #skip_noarch: 1 #custom_build: |- #./Build build flags=%{?_smp_mflags} --myflag #custom_test: |- #startserver && make test #ignore_requires: Bizarre::Module ++++++ indirect-0.35.tar.gz -> indirect-0.36.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/Changes new/indirect-0.36/Changes --- old/indirect-0.35/Changes 2015-04-06 23:56:15.000000000 +0200 +++ new/indirect-0.36/Changes 2015-07-17 23:49:32.000000000 +0200 @@ -1,5 +1,11 @@ Revision history for indirect +0.36 2015-07-17 22:15 UTC + + Fix : [RT #104312] : fatal hides perl errors in modules + no indirect 'fatal' will no longer hide compilation errors + occurring before indirect constructs. + Thanks Lukas Mai for reporting. + 0.35 2015-04-06 22:20 UTC + Fix : The module could end being disabled in one thread if it was first loaded in another thread and that thread was immediately diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/MANIFEST new/indirect-0.36/MANIFEST --- old/indirect-0.35/MANIFEST 2015-03-24 16:34:52.000000000 +0100 +++ new/indirect-0.36/MANIFEST 2015-07-17 23:45:44.000000000 +0200 @@ -20,6 +20,7 @@ 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 @@ -38,6 +39,7 @@ 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/META.json new/indirect-0.36/META.json --- old/indirect-0.35/META.json 2015-04-06 23:57:29.000000000 +0200 +++ new/indirect-0.36/META.json 2015-07-17 23:51:54.000000000 +0200 @@ -4,7 +4,7 @@ "Vincent Pit <p...@profvince.com>" ], "dynamic_config" : 1, - "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001", + "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], @@ -25,9 +25,14 @@ "Carp" : "0", "Config" : "0", "ExtUtils::MakeMaker" : "0", + "IO::Handle" : "0", + "IO::Select" : "0", + "IPC::Open3" : "0", "POSIX" : "0", + "Socket" : "0", "Test::More" : "0", - "XSLoader" : "0" + "XSLoader" : "0", + "lib" : "0" } }, "configure" : { @@ -57,5 +62,6 @@ "url" : "http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git"; } }, - "version" : "0.35" + "version" : "0.36", + "x_serialization_backend" : "JSON::PP version 2.27300" } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/META.yml new/indirect-0.36/META.yml --- old/indirect-0.35/META.yml 2015-04-06 23:57:29.000000000 +0200 +++ new/indirect-0.36/META.yml 2015-07-17 23:51:54.000000000 +0200 @@ -6,14 +6,19 @@ Carp: '0' Config: '0' ExtUtils::MakeMaker: '0' + IO::Handle: '0' + IO::Select: '0' + IPC::Open3: '0' POSIX: '0' + Socket: '0' Test::More: '0' XSLoader: '0' + lib: '0' configure_requires: Config: '0' ExtUtils::MakeMaker: '0' dynamic_config: 1 -generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' +generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -32,4 +37,5 @@ 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.35' +version: '0.36' +x_serialization_backend: 'CPAN::Meta::YAML version 0.016' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/Makefile.PL new/indirect-0.36/Makefile.PL --- old/indirect-0.35/Makefile.PL 2015-03-31 14:35:27.000000000 +0200 +++ new/indirect-0.36/Makefile.PL 2015-07-17 20:53:37.000000000 +0200 @@ -65,8 +65,13 @@ my %BUILD_REQUIRES =( 'Config' => 0, 'ExtUtils::MakeMaker' => 0, + 'IO::Handle' => 0, + 'IO::Select' => 0, + 'IPC::Open3' => 0, 'POSIX' => 0, + 'Socket' => 0, 'Test::More' => 0, + 'lib' => 0, %PREREQ_PM, ); diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/README new/indirect-0.36/README --- old/indirect-0.35/README 2015-04-06 23:57:29.000000000 +0200 +++ new/indirect-0.36/README 2015-07-17 23:51:54.000000000 +0200 @@ -2,7 +2,7 @@ indirect - Lexically warn about using the indirect method call syntax. VERSION - Version 0.35 + Version 0.36 SYNOPSIS In a script : @@ -169,10 +169,6 @@ is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. - Indirect constructs that appear in code "eval"'d during the global - destruction phase of a spawned thread or pseudo-fork (the processes used - internally for the "fork" emulation on Windows) are not reported. - The search for indirect method calls happens before constant folding. Hence "my $x = new Class if 0" will be caught. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/indirect.xs new/indirect-0.36/indirect.xs --- old/indirect-0.35/indirect.xs 2015-04-06 23:57:05.000000000 +0200 +++ new/indirect-0.36/indirect.xs 2015-07-17 19:22:33.000000000 +0200 @@ -219,7 +219,8 @@ #if I_THREADSAFE #define PTABLE_NAME ptable_loaded -#define PTABLE_VAL_FREE(V) NOOP +#define PTABLE_NEED_DELETE 1 +#define PTABLE_NEED_WALK 0 #include "ptable.h" @@ -320,6 +321,8 @@ #define PTABLE_NAME ptable_hints #define PTABLE_VAL_FREE(V) I_HINT_FREE(V) +#define PTABLE_NEED_DELETE 0 +#define PTABLE_NEED_WALK 1 #define pPTBL pTHX #define pPTBL_ pTHX_ @@ -346,6 +349,8 @@ #define PTABLE_NAME ptable #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); } +#define PTABLE_NEED_DELETE 1 +#define PTABLE_NEED_WALK 0 #define pPTBL pTHX #define pPTBL_ pTHX_ @@ -421,49 +426,10 @@ ptable_hints_store(ud->tbl, ent->key, h2); } -static void indirect_thread_cleanup(pTHX_ void *ud) { - int global_teardown; - dMY_CXT; - - global_teardown = indirect_clear_loaded_locked(&MY_CXT); - assert(!global_teardown); - - SvREFCNT_dec(MY_CXT.global_code); - MY_CXT.global_code = NULL; - - ptable_free(MY_CXT.map); - MY_CXT.map = NULL; - - ptable_hints_free(MY_CXT.tbl); - MY_CXT.tbl = NULL; -} - -static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) { - SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL); - - return 0; -} - -static MGVTBL indirect_endav_vtbl = { - 0, - 0, - 0, - 0, - indirect_endav_free -#if MGf_COPY - , 0 -#endif -#if MGf_DUP - , 0 -#endif -#if MGf_LOCAL - , 0 -#endif -}; - #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION + static IV indirect_require_tag(pTHX) { #define indirect_require_tag() indirect_require_tag(aTHX) const CV *cv, *outside; @@ -507,6 +473,7 @@ return PTR2IV(cv); } + #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ static SV *indirect_tag(pTHX_ SV *value) { @@ -671,6 +638,68 @@ ptable_delete(MY_CXT.map, o); } +/* --- Safe version of call_sv() ------------------------------------------- */ + +static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) { +#define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F)) + I32 ret, cxix; + PERL_CONTEXT saved_cx; + SV *saved_errsv = NULL; + + if (SvTRUE(ERRSV)) { + if (IN_PERL_COMPILETIME && PL_errors) + sv_catsv(PL_errors, ERRSV); + else + saved_errsv = newSVsv(ERRSV); + SvCUR_set(ERRSV, 0); + } + + cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); + /* The last popped context will be reused by call_sv(), but our callers may + * still need its previous value. Back it up so that it isn't clobbered. */ + saved_cx = cxstack[cxix]; + + ret = call_sv(sv, flags | G_EVAL); + + cxstack[cxix] = saved_cx; + + if (SvTRUE(ERRSV)) { + /* Discard the old ERRSV, and reuse the variable to temporarily store the + * new one. */ + if (saved_errsv) + sv_setsv(saved_errsv, ERRSV); + else + saved_errsv = newSVsv(ERRSV); + SvCUR_set(ERRSV, 0); + /* Immediately flush all errors. */ + if (IN_PERL_COMPILETIME) { +#if I_HAS_PERL(5, 10, 0) || defined(PL_parser) + if (PL_parser) + ++PL_parser->error_count; +#elif defined(PL_error_count) + ++PL_error_count; +#else + ++PL_Ierror_count; +#endif + if (PL_errors) { + sv_setsv(ERRSV, PL_errors); + SvCUR_set(PL_errors, 0); + } + } + sv_catsv(ERRSV, saved_errsv); + SvREFCNT_dec(saved_errsv); + croak(NULL); + } else if (saved_errsv) { + /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been + * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval + * block has ever been executed. */ + sv_setsv(ERRSV, saved_errsv); + SvREFCNT_dec(saved_errsv); + } + + return ret; +} + /* --- Check functions ----------------------------------------------------- */ static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) { @@ -1028,7 +1057,7 @@ mPUSHu(moi->line); PUTBACK; - call_sv(code, G_VOID); + indirect_call_sv(code, G_VOID); PUTBACK; @@ -1046,11 +1075,6 @@ static void indirect_teardown(pTHX_ void *interp) { dMY_CXT; -#if I_MULTIPLICITY - if (aTHX != interp) - return; -#endif - I_LOADED_LOCK; if (indirect_clear_loaded_locked(&MY_CXT)) { @@ -1122,11 +1146,7 @@ MY_CXT.global_code = NULL; } -#if I_MULTIPLICITY - call_atexit(indirect_teardown, aTHX); -#else call_atexit(indirect_teardown, NULL); -#endif return; } @@ -1150,7 +1170,6 @@ PREINIT: ptable *t; SV *global_code_dup; - GV *gv; PPCODE: { indirect_ptable_clone_ud ud; @@ -1175,26 +1194,9 @@ I_LOADED_UNLOCK; } } - gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV); - if (gv) { - CV *cv = GvCV(gv); - if (!PL_endav) - PL_endav = newAV(); - SvREFCNT_inc(cv); - if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv)) - SvREFCNT_dec(cv); - sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0); - } - XSRETURN(0); - -void -_THREAD_CLEANUP(...) -PROTOTYPE: DISABLE -PPCODE: - indirect_thread_cleanup(aTHX_ NULL); XSRETURN(0); -#endif +#endif /* I_THREADSAFE */ SV * _tag(SV *value) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/lib/indirect.pm new/indirect-0.36/lib/indirect.pm --- old/indirect-0.35/lib/indirect.pm 2015-04-06 23:52:42.000000000 +0200 +++ new/indirect-0.36/lib/indirect.pm 2015-07-17 22:44:10.000000000 +0200 @@ -11,13 +11,13 @@ =head1 VERSION -Version 0.35 +Version 0.36 =cut our $VERSION; BEGIN { - $VERSION = '0.35'; + $VERSION = '0.36'; } =head1 SYNOPSIS @@ -250,8 +250,6 @@ With 5.8 perls, the pragma does not propagate into C<eval STRING>. This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. -Indirect constructs that appear in code C<eval>'d during the global destruction phase of a spawned thread or pseudo-fork (the processes used internally for the C<fork> emulation on Windows) are not reported. - The search for indirect method calls happens before constant folding. Hence C<my $x = new Class if 0> will be caught. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/ptable.h new/indirect-0.36/ptable.h --- old/indirect-0.35/ptable.h 2015-02-26 14:40:44.000000000 +0100 +++ new/indirect-0.36/ptable.h 2015-05-14 18:24:16.000000000 +0200 @@ -52,10 +52,6 @@ # define PTABLE_NAME ptable #endif -#ifndef PTABLE_VAL_FREE -# define PTABLE_VAL_FREE(V) -#endif - #ifndef PTABLE_JOIN # define PTABLE_PASTE(A, B) A ## B # define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) @@ -65,6 +61,14 @@ # define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) #endif +#ifndef PTABLE_NEED_DELETE +# define PTABLE_NEED_DELETE 1 +#endif + +#ifndef PTABLE_NEED_WALK +# define PTABLE_NEED_WALK 1 +#endif + #ifndef ptable_ent typedef struct ptable_ent { struct ptable_ent *next; @@ -84,7 +88,7 @@ #endif /* !ptable */ #ifndef ptable_new -STATIC ptable *ptable_new(pPTBLMS) { +static ptable *ptable_new(pPTBLMS) { #define ptable_new() ptable_new(aPTBLMS) ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t)); t->max = 15; @@ -101,7 +105,7 @@ #endif #ifndef ptable_find -STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) { +static ptable_ent *ptable_find(const ptable * const t, const void * const key) { #define ptable_find ptable_find ptable_ent *ent; const UV hash = PTABLE_HASH(key); @@ -117,7 +121,7 @@ #endif /* !ptable_find */ #ifndef ptable_fetch -STATIC void *ptable_fetch(const ptable * const t, const void * const key) { +static void *ptable_fetch(const ptable * const t, const void * const key) { #define ptable_fetch ptable_fetch const ptable_ent *const ent = ptable_find(t, key); @@ -126,7 +130,7 @@ #endif /* !ptable_fetch */ #ifndef ptable_split -STATIC void ptable_split(pPTBLMS_ ptable * const t) { +static void ptable_split(pPTBLMS_ ptable * const t) { #define ptable_split(T) ptable_split(aPTBLMS_ (T)) ptable_ent **ary = t->ary; const size_t oldsize = t->max + 1; @@ -156,12 +160,14 @@ } #endif /* !ptable_split */ -STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { +static void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { ptable_ent *ent = ptable_find(t, key); if (ent) { +#ifdef PTABLE_VAL_FREE void *oldval = ent->val; PTABLE_VAL_FREE(oldval); +#endif ent->val = val; } else if (val) { const size_t i = PTABLE_HASH(key) & t->max; @@ -176,7 +182,9 @@ } } -STATIC void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) { +#if PTABLE_NEED_DELETE + +static void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) { ptable_ent *prev, *ent; const size_t i = PTABLE_HASH(key) & t->max; @@ -192,13 +200,18 @@ prev->next = ent->next; else t->ary[i] = ent->next; +#ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(ent->val); +#endif PerlMemShared_free(ent); } } -#ifndef ptable_walk -STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { +#endif /* PTABLE_NEED_DELETE */ + +#if PTABLE_NEED_WALK && !defined(ptable_walk) + +static void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { #define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) if (t && t->items) { register ptable_ent ** const array = t->ary; @@ -211,9 +224,10 @@ } while (i--); } } -#endif /* !ptable_walk */ -STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { +#endif /* PTABLE_NEED_WALK && !defined(ptable_walk) */ + +static void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; @@ -221,11 +235,12 @@ do { ptable_ent *entry = array[i]; while (entry) { - ptable_ent * const oentry = entry; - void *val = oentry->val; - entry = entry->next; - PTABLE_VAL_FREE(val); - PerlMemShared_free(oentry); + ptable_ent * const nentry = entry->next; +#ifdef PTABLE_VAL_FREE + PTABLE_VAL_FREE(entry->val); +#endif + PerlMemShared_free(entry); + entry = nentry; } array[i] = NULL; } while (i--); @@ -234,7 +249,7 @@ } } -STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { +static void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); @@ -249,3 +264,6 @@ #undef PTABLE_NAME #undef PTABLE_VAL_FREE + +#undef PTABLE_NEED_DELETE +#undef PTABLE_NEED_WALK diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/09-load-threads.t new/indirect-0.36/t/09-load-threads.t --- old/indirect-0.35/t/09-load-threads.t 2015-04-06 19:10:14.000000000 +0200 +++ new/indirect-0.36/t/09-load-threads.t 2015-05-14 18:04:30.000000000 +0200 @@ -3,9 +3,6 @@ use strict; use warnings; -use lib 't/lib'; -use VPIT::TestHelpers; - BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } my ($module, $thread_safe_var); @@ -32,29 +29,8 @@ # Keep the rest of the file untouched -BEGIN { - my $is_threadsafe; - - if (defined $thread_safe_var) { - my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"; - if (defined $stat) { - require POSIX; - my $res = $stat >> 8; - if ($res == POSIX::EXIT_SUCCESS()) { - $is_threadsafe = 1; - } elsif ($res == POSIX::EXIT_FAILURE()) { - $is_threadsafe = !1; - } - } - if (not defined $is_threadsafe) { - skip_all "Could not detect if $module is thread safe or not"; - } - } - - VPIT::TestHelpers->import( - threads => [ $module => $is_threadsafe ], - ) -} +use lib 't/lib'; +use VPIT::TestHelpers threads => [ $module, $thread_safe_var ]; my $could_not_create_thread = 'Could not create thread'; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/33-compilation-errors.t new/indirect-0.36/t/33-compilation-errors.t --- old/indirect-0.35/t/33-compilation-errors.t 1970-01-01 01:00:00.000000000 +0100 +++ new/indirect-0.36/t/33-compilation-errors.t 2015-07-17 22:54:30.000000000 +0200 @@ -0,0 +1,68 @@ +#!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'; +} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/40-threads.t new/indirect-0.36/t/40-threads.t --- old/indirect-0.35/t/40-threads.t 2015-03-24 16:10:15.000000000 +0100 +++ new/indirect-0.36/t/40-threads.t 2015-04-20 17:49:38.000000000 +0200 @@ -1,14 +1,10 @@ -#!perl -T +#!perl use strict; use warnings; -BEGIN { require indirect; } - use lib 't/lib'; -use VPIT::TestHelpers ( - threads => [ 'indirect' => indirect::I_THREADSAFE ], -); +use VPIT::TestHelpers threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ]; use Test::Leaner; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/41-threads-teardown.t new/indirect-0.36/t/41-threads-teardown.t --- old/indirect-0.35/t/41-threads-teardown.t 2015-03-24 16:19:23.000000000 +0100 +++ new/indirect-0.36/t/41-threads-teardown.t 2015-05-14 18:12:41.000000000 +0200 @@ -3,17 +3,14 @@ use strict; use warnings; -BEGIN { require indirect; } - use lib 't/lib'; use VPIT::TestHelpers ( - threads => [ 'indirect' => indirect::I_THREADSAFE ], + threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ], + 'run_perl', ); use Test::Leaner tests => 3; -my $run_perl_failed = 'Could not execute perl subprocess'; - SKIP: { skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002; @@ -33,7 +30,7 @@ eval q{return; no indirect hook => \&cb; new Z;}; exit $code; RUN - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault'; } @@ -42,15 +39,15 @@ my $status = run_perl <<' RUN'; use threads; BEGIN { require indirect; } - sub X::DESTROY { eval 'no indirect; 1'; exit 1 if $@ } + sub X2::DESTROY { eval 'no indirect; 1'; exit 1 if $@ } threads->create(sub { - my $x = bless { }, 'X'; + my $x = bless { }, 'X2'; $x->{self} = $x; return; })->join; exit $code; RUN - skip $run_perl_failed => 1 unless defined $status; + 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'; } @@ -60,15 +57,16 @@ use threads::shared; my $code : shared; $code = 0; - no indirect cb => sub { lock $code; ++$code }; - sub X::DESTROY { eval $_[0]->{code} } + no indirect hook => sub { lock $code; ++$code }; + sub X3::DESTROY { eval $_[0]->{code} } threads->create(sub { - my $x = bless { code => 'new Z' }, 'X'; + my $x = bless { code => 'new Z3' }, 'X3'; $x->{self} = $x; return; })->join; exit $code; RUN - skip $run_perl_failed => 1 unless defined $status; - is $status, 0, 'indirect does not check eval STRING during global destruction at the end of a thread'; + 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'; } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/42-threads-global.t new/indirect-0.36/t/42-threads-global.t --- old/indirect-0.35/t/42-threads-global.t 2015-04-06 15:40:17.000000000 +0200 +++ new/indirect-0.36/t/42-threads-global.t 2015-04-20 17:52:25.000000000 +0200 @@ -1,14 +1,10 @@ -#!perl -T +#!perl use strict; use warnings; -BEGIN { require indirect; } - use lib 't/lib'; -use VPIT::TestHelpers ( - threads => [ 'indirect' => indirect::I_THREADSAFE ], -); +use VPIT::TestHelpers threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ]; use Test::Leaner; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/50-external.t new/indirect-0.36/t/50-external.t --- old/indirect-0.35/t/50-external.t 2015-03-24 16:22:07.000000000 +0100 +++ new/indirect-0.36/t/50-external.t 2015-04-20 17:56:18.000000000 +0200 @@ -8,15 +8,13 @@ use Test::More tests => 6; use lib 't/lib'; -use VPIT::TestHelpers; +use VPIT::TestHelpers 'run_perl'; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } -my $run_perl_failed = 'Could not execute perl subprocess'; - SKIP: { my $status = run_perl 'no indirect; qq{a\x{100}b} =~ /\A[\x00-\x7f]*\z/;'; - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'RT #47866'; } @@ -24,7 +22,7 @@ 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; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 2 << 8, 'no semicolon at the end of -e'; } @@ -32,7 +30,7 @@ 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; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'indirect is not getting upset by Devel::CallParser'; } @@ -45,7 +43,7 @@ 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; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'indirect does not croak while package empty is in use'; } @@ -62,10 +60,10 @@ => $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; + 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; + 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'; } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/lib/VPIT/TestHelpers.pm new/indirect-0.36/t/lib/VPIT/TestHelpers.pm --- old/indirect-0.35/t/lib/VPIT/TestHelpers.pm 2015-03-24 16:06:42.000000000 +0100 +++ new/indirect-0.36/t/lib/VPIT/TestHelpers.pm 2015-07-17 20:49:08.000000000 +0200 @@ -5,6 +5,19 @@ 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) = @_; @@ -16,16 +29,31 @@ 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, - run_perl => \&run_perl, skip_all => \&skip_all, ); my %features = ( - threads => \&init_threads, - usleep => \&init_usleep, + threads => \&init_threads, + usleep => \&init_usleep, + run_perl => \&init_run_perl, + capture => \&init_capture, ); sub import { @@ -141,12 +169,54 @@ return $loaded; } -sub run_perl { - my $code = shift; +=head1 FEATURES - if ($code =~ /"/) { - die 'Double quotes in evaluated code are not portable'; - } +=head2 C<run_perl> + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers run_perl => [ $p ] + +where : + +=over 8 + +=item - + +C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). + +=back + +=item * + +Dependencies : none + +=item * + +Exports : + +=over 8 + +=item - + +C<run_perl $code> + +=item - + +C<RUN_PERL_FAILED> (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub fresh_perl_env (&) { + my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>}; my $ld_name = $Config::Config{ldlibpthname}; @@ -165,55 +235,423 @@ } } - system { $perl } $perl, '-T', map("-I$_", @INC), '-e', $code; + return $handler->($perl, '-T', map("-I$_", @INC)); } +sub init_run_perl { + my $p = sanitize_prefix(shift); + + return ( + run_perl => \&run_perl, + "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, + ); +} + +sub run_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, '-e', $code; + }; +} + +=head2 C<capture> + +=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<IO::Handle> + +=item - + +L<IO::Select> + +=item - + +L<IPC::Open3> + +=item - + +On MSWin32 : L<Socket> + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C<capture @command> + +=item - + +C<CAPTURE_FAILED $details> (possibly prefixed by C<$p>) + +=item - + +C<capture_perl $code> + +=item - + +C<CAPTURE_PERL_FAILED $details> (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<socketpair reader writer>); + shutdown $_[0], 1 or $fail->(qw<shutdown reader>); + shutdown $_[1], 0 or $fail->(qw<shutdown writer>); + 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<close input>); + $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 output>); + close $err or $fail->(qw<close error>); + 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<threads> + +=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<undef>) ; + +=item - + +C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C<PERL_FORCE_TEST_THREADS>). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +C<perl> 5.13.4 + +=item - + +L<POSIX> + +=item - + +L<threads> 1.67 + +=item - + +L<threads::shared> 1.14 + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C<spawn $coderef> + +=back + +=back + +=cut + sub init_threads { - my ($pkg, $threadsafe, $force_var) = @_; + my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; - $pkg = 'package' unless defined $pkg; - skip_all "This $pkg isn't thread safe" if defined $threadsafe and !$threadsafe; + if (defined $pkg and defined $threadsafe_var) { + my $threadsafe; + my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); + if (defined $stat) { + require POSIX; + my $res = $stat >> 8; + if ($res == POSIX::EXIT_SUCCESS()) { + $threadsafe = 1; + } elsif ($res == POSIX::EXIT_FAILURE()) { + $threadsafe = !1; + } + } + if (not defined $threadsafe) { + skip_all "Could not detect if $pkg is thread safe or not"; + } elsif (not $threadsafe) { + skip_all "This $pkg is not thread safe"; + } + } $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; my $force = $ENV{$force_var} ? 1 : !1; skip_all 'perl 5.13.4 required to test thread safety' unless $force or "$]" >= 5.013_004; - if (($INC{'Test/More.pm'} || $INC{'Test/Leaner.pm'}) && !$INC{'threads.pm'}) { - die 'Test::More/Test::Leaner was loaded too soon'; + unless ($INC{'threads.pm'}) { + my $test_module; + if ($INC{'Test/Leaner.pm'}) { + $test_module = 'Test::Leaner'; + } elsif ($INC{'Test/More.pm'}) { + $test_module = 'Test::More'; + } + die "$test_module was loaded too soon" if defined $test_module; } load_or_skip_all 'threads', $force ? '0' : '1.67', [ ]; load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; - require Test::Leaner; - diag "Threads testing forced by \$ENV{$force_var}" if $force; return spawn => \&spawn; } -sub init_usleep { - my $usleep; - - if (do { local $@; eval { require Time::HiRes; 1 } }) { - defined and diag "Using usleep() from Time::HiRes $_" - for $Time::HiRes::VERSION; - $usleep = \&Time::HiRes::usleep; - } else { - diag 'Using fallback usleep()'; - $usleep = sub { - my $s = int($_[0] / 2.5e5); - sleep $s if $s; - }; - } - - return usleep => $usleep; -} - sub spawn { local $@; my @diag; @@ -226,6 +664,118 @@ return $thread ? $thread : (); } +=head2 C<usleep> + +=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<usleep $microseconds> + +=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<Time::HiRes select sleep> 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<VPIT::TestHelpers::Guard> + +Syntax : + + { + my $guard = VPIT::TestHelpers::Guard->new($coderef); + ... + } # $codref called here + +=cut + package VPIT::TestHelpers::Guard; sub new { @@ -236,4 +786,16 @@ sub DESTROY { $_[0]->{code}->() } +=head1 AUTHOR + +Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>. + +=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; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/indirect-0.35/t/lib/indirect/TestCompilationError.pm new/indirect-0.36/t/lib/indirect/TestCompilationError.pm --- old/indirect-0.35/t/lib/indirect/TestCompilationError.pm 1970-01-01 01:00:00.000000000 +0100 +++ new/indirect-0.36/t/lib/indirect/TestCompilationError.pm 2015-07-17 22:50:36.000000000 +0200 @@ -0,0 +1,8 @@ +package indirect::TestCompilationError; +use strict; +use warnings; +no indirect 'fatal'; +sub foo { $bar } +baz $_; +sub qux { $ook } +1
