Hello community, here is the log from the commit of package perl-Scope-Upper for openSUSE:Factory checked in at 2015-04-15 16:26:49 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/perl-Scope-Upper (Old) and /work/SRC/openSUSE:Factory/.perl-Scope-Upper.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-Scope-Upper" Changes: -------- --- /work/SRC/openSUSE:Factory/perl-Scope-Upper/perl-Scope-Upper.changes 2013-10-06 14:31:48.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.perl-Scope-Upper.new/perl-Scope-Upper.changes 2015-04-15 16:26:51.000000000 +0200 @@ -1,0 +2,32 @@ +Tue Apr 14 19:22:47 UTC 2015 - [email protected] + +- updated to 0.27 + see /usr/share/doc/packages/perl-Scope-Upper/Changes + + 0.27 2015-03-27 22:10 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 : Segfaults when the module is loaded by several threads (or + Windows emulated processes) ran in parallel. + + Fix : Memory leak with the uid() feature. + + 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 : reap(), localize(), localize_elem() and localize_delete() + will again work correctly on perl 5.19.4+ when the debugger + is enabled. + + Fix : Silence some compiler warnings. + + 0.26 2015-03-12 23:30 UTC + + Fix : [RT #100264] : Don't use CvPADLIST on XSUBs + Thanks Father Chrysostomos for reporting and contributing a + patch. + + Fix : Be really compatible with the optional OP_PARENT feature. + + 0.25 2014-09-21 17:10 UTC + + Add : Support for the PERL_OP_PARENT optional feature introduced in + perl 5.21.2. + + Fix : Work around an assertion failure in perl 5.21.4. + +------------------------------------------------------------------- Old: ---- Scope-Upper-0.24.tar.gz New: ---- Scope-Upper-0.27.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-Scope-Upper.spec ++++++ --- /var/tmp/diff_new_pack.gHeWe9/_old 2015-04-15 16:26:51.000000000 +0200 +++ /var/tmp/diff_new_pack.gHeWe9/_new 2015-04-15 16:26:51.000000000 +0200 @@ -1,7 +1,7 @@ # # spec file for package perl-Scope-Upper # -# Copyright (c) 2013 SUSE LINUX Products GmbH, Nuernberg, Germany. +# Copyright (c) 2015 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -17,10 +17,10 @@ Name: perl-Scope-Upper -Version: 0.24 +Version: 0.27 Release: 0 %define cpan_name Scope-Upper -Summary: Act on upper scopes. +Summary: Act on upper scopes License: Artistic-1.0 or GPL-1.0+ Group: Development/Libraries/Perl Url: http://search.cpan.org/dist/Scope-Upper/ @@ -28,13 +28,6 @@ BuildRoot: %{_tmppath}/%{name}-%{version}-build BuildRequires: perl BuildRequires: perl-macros -#BuildRequires: perl(feature) -#BuildRequires: perl(Scope::Upper) -#BuildRequires: perl(Scope::Upper::TestGenerator) -#BuildRequires: perl(Scope::Upper::TestThreads) -#BuildRequires: perl(Sub::Uplevel) -#BuildRequires: perl(Test::Leaner) -#BuildRequires: perl(VPIT::TestHelpers) %{perl_requires} %description ++++++ Scope-Upper-0.24.tar.gz -> Scope-Upper-0.27.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/Changes new/Scope-Upper-0.27/Changes --- old/Scope-Upper-0.24/Changes 2013-09-10 12:46:59.000000000 +0200 +++ new/Scope-Upper-0.27/Changes 2015-03-27 22:38:16.000000000 +0100 @@ -1,5 +1,31 @@ Revision history for Scope-Upper +0.27 2015-03-27 22:10 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 : Segfaults when the module is loaded by several threads (or + Windows emulated processes) ran in parallel. + + Fix : Memory leak with the uid() feature. + + 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 : reap(), localize(), localize_elem() and localize_delete() + will again work correctly on perl 5.19.4+ when the debugger + is enabled. + + Fix : Silence some compiler warnings. + +0.26 2015-03-12 23:30 UTC + + Fix : [RT #100264] : Don't use CvPADLIST on XSUBs + Thanks Father Chrysostomos for reporting and contributing a + patch. + + Fix : Be really compatible with the optional OP_PARENT feature. + +0.25 2014-09-21 17:10 UTC + + Add : Support for the PERL_OP_PARENT optional feature introduced in + perl 5.21.2. + + Fix : Work around an assertion failure in perl 5.21.4. + 0.24 2013-09-10 11:10 UTC + Fix : Lexicals returned with unwind(), yield() and leave() will no longer be lost on perl 5.19.4 and above. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/MANIFEST new/Scope-Upper-0.27/MANIFEST --- old/Scope-Upper-0.24/MANIFEST 2013-09-09 18:43:19.000000000 +0200 +++ new/Scope-Upper-0.27/MANIFEST 2015-03-23 20:15:17.000000000 +0100 @@ -14,6 +14,7 @@ t/05-words.t t/06-want_at.t t/07-context_info.t +t/09-load-threads.t t/11-reap-level.t t/12-reap-block.t t/13-reap-ctl.t @@ -63,6 +64,5 @@ t/86-stress-uplevel.t t/87-stress-uid.t t/lib/Scope/Upper/TestGenerator.pm -t/lib/Scope/Upper/TestThreads.pm t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/META.json new/Scope-Upper-0.27/META.json --- old/Scope-Upper-0.24/META.json 2013-09-10 12:47:55.000000000 +0200 +++ new/Scope-Upper-0.27/META.json 2015-03-27 22:38:59.000000000 +0100 @@ -4,7 +4,7 @@ "Vincent Pit <[email protected]>" ], "dynamic_config" : 1, - "generated_by" : "ExtUtils::MakeMaker version 6.76, CPAN::Meta::Converter version 2.132510", + "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], @@ -25,6 +25,7 @@ "Config" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", + "POSIX" : "0", "Test::More" : "0", "XSLoader" : "0", "base" : "0" @@ -58,5 +59,5 @@ "url" : "http://git.profvince.com/?p=perl%2Fmodules%2FScope-Upper.git"; } }, - "version" : "0.24" + "version" : "0.27" } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/META.yml new/Scope-Upper-0.27/META.yml --- old/Scope-Upper-0.24/META.yml 2013-09-10 12:47:55.000000000 +0200 +++ new/Scope-Upper-0.27/META.yml 2015-03-27 22:38:59.000000000 +0100 @@ -3,34 +3,35 @@ author: - 'Vincent Pit <[email protected]>' build_requires: - Config: 0 - Exporter: 0 - ExtUtils::MakeMaker: 0 - Test::More: 0 - XSLoader: 0 - base: 0 + Config: '0' + Exporter: '0' + ExtUtils::MakeMaker: '0' + POSIX: '0' + Test::More: '0' + XSLoader: '0' + base: '0' configure_requires: - Config: 0 - ExtUtils::MakeMaker: 0 + Config: '0' + ExtUtils::MakeMaker: '0' dynamic_config: 1 -generated_by: 'ExtUtils::MakeMaker version 6.76, CPAN::Meta::Converter version 2.132510' +generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html - version: 1.4 + version: '1.4' name: Scope-Upper no_index: directory: - t - inc requires: - Exporter: 0 - XSLoader: 0 - base: 0 - perl: 5.006001 + Exporter: '0' + XSLoader: '0' + base: '0' + perl: '5.006001' resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=Scope-Upper homepage: http://search.cpan.org/dist/Scope-Upper/ license: http://dev.perl.org/licenses/ repository: http://git.profvince.com/?p=perl%2Fmodules%2FScope-Upper.git -version: 0.24 +version: '0.27' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/Makefile.PL new/Scope-Upper-0.27/Makefile.PL --- old/Scope-Upper-0.24/Makefile.PL 2013-08-29 01:17:08.000000000 +0200 +++ new/Scope-Upper-0.27/Makefile.PL 2015-03-27 20:07:42.000000000 +0100 @@ -35,7 +35,16 @@ @Config{qw<bin sitebin>}; $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl"; $macro{LDFLAGS} = "$ldflags $libdirs $libperl"; - $macro{PERL_ARCHIVE} = '', + eval <<' MY_SECTION'; + package MY; + sub dynamic_lib { + my $self = shift; + my $inherited = $self->SUPER::dynamic_lib(@_); + $inherited =~ s/"?\$\(PERL_ARCHIVE\)"?//g; + return $inherited; + } + MY_SECTION + die $@ if $@; } } print $is_gcc_34 ? "yes\n" : "no\n"; @@ -64,6 +73,7 @@ my %BUILD_REQUIRES = ( 'ExtUtils::MakeMaker' => 0, 'Config' => 0, + 'POSIX' => 0, 'Test::More' => 0, %PREREQ_PM, ); @@ -112,6 +122,6 @@ sub postamble { return <<'POSTAMBLE'; testdeb: all - PERL_DL_NONLAZY=1 PERLDB_OPTS="NonStop=1" $(FULLPERLRUN) -MTAP::Harness -e 'TAP::Harness->new({verbosity => q{$(VERBOSE)}, lib => [ q{$(INST_LIB)}, q{$(INST_ARCHLIB)} ], switches => [ q{-d} ]})->runtests(@ARGV)' $(TEST_FILES) + PERL_DL_NONLAZY=1 PERLDB_OPTS="NonStop=1" $(FULLPERLRUN) -MTAP::Harness -e 'TAP::Harness->new({verbosity => q{$(TEST_VERBOSE)}, lib => [ q{$(INST_LIB)}, q{$(INST_ARCHLIB)} ], switches => [ q{-d} ]})->runtests(@ARGV)' $(TEST_FILES) POSTAMBLE } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/README new/Scope-Upper-0.27/README --- old/Scope-Upper-0.24/README 2013-09-10 12:47:55.000000000 +0200 +++ new/Scope-Upper-0.27/README 2015-03-27 22:38:59.000000000 +0100 @@ -2,7 +2,7 @@ Scope::Upper - Act on upper scopes. VERSION - Version 0.24 + Version 0.27 SYNOPSIS "reap", "localize", "localize_elem", "localize_delete" and "WORDS" : @@ -737,6 +737,11 @@ version of "uplevel" should still run way faster than the pure-Perl version from Sub::Uplevel. + Starting from "perl" 5.19.4, it is unfortunately no longer possible to + reliably throw exceptions from "uplevel"'d code while the debugger is in + use. This may be solved in a future version depending on how the core + evolves. + DEPENDENCIES perl 5.6.1. @@ -785,8 +790,8 @@ Thanks to Shawn M. Moore for motivation. COPYRIGHT & LICENSE - Copyright 2008,2009,2010,2011,2012,2013 Vincent Pit, all rights - reserved. + Copyright 2008,2009,2010,2011,2012,2013,2014,2015 Vincent Pit, all + rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/Upper.xs new/Scope-Upper-0.27/Upper.xs --- old/Scope-Upper-0.24/Upper.xs 2013-09-09 18:41:51.000000000 +0200 +++ new/Scope-Upper-0.27/Upper.xs 2015-03-27 20:44:54.000000000 +0100 @@ -72,7 +72,7 @@ #endif #ifndef newSV_type -STATIC SV *su_newSV_type(pTHX_ svtype t) { +static SV *su_newSV_type(pTHX_ svtype t) { SV *sv = newSV(0); SvUPGRADE(sv, t); return sv; @@ -182,7 +182,7 @@ #endif #ifndef OP_GIMME_REVERSE -STATIC U8 su_op_gimme_reverse(U8 gimme) { +static U8 su_op_gimme_reverse(U8 gimme) { switch (gimme) { case G_VOID: return OPf_WANT_VOID; @@ -197,6 +197,14 @@ #define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) #endif +#ifndef OpSIBLING +# ifdef OP_SIBLING +# define OpSIBLING(O) OP_SIBLING(O) +# else +# define OpSIBLING(O) ((O)->op_sibling) +# endif +#endif + #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif @@ -241,7 +249,7 @@ # undef MY_CXT # define MY_CXT su_globaldata # undef START_MY_CXT -# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# define START_MY_CXT static my_cxt_t MY_CXT; # undef MY_CXT_INIT # define MY_CXT_INIT NOOP # undef MY_CXT_CLONE @@ -257,11 +265,11 @@ STRLEN size; } su_uv_array; -STATIC su_uv_array su_uid_seq_counter; +static su_uv_array su_uid_seq_counter; #ifdef USE_ITHREADS -STATIC perl_mutex su_uid_seq_counter_mutex; +static perl_mutex su_uid_seq_counter_mutex; #define SU_LOCK(M) MUTEX_LOCK(M) #define SU_UNLOCK(M) MUTEX_UNLOCK(M) @@ -273,7 +281,7 @@ #endif /* !USE_ITHREADS */ -STATIC UV su_uid_seq_next(pTHX_ UV depth) { +static UV su_uid_seq_next(pTHX_ UV depth) { #define su_uid_seq_next(D) su_uid_seq_next(aTHX_ (D)) UV seq; UV *seqs; @@ -309,7 +317,7 @@ #define SU_UID_ACTIVE 1 -STATIC UV su_uid_depth(pTHX_ I32 cxix) { +static UV su_uid_depth(pTHX_ I32 cxix) { #define su_uid_depth(I) su_uid_depth(aTHX_ (I)) const PERL_SI *si; UV depth; @@ -327,7 +335,7 @@ STRLEN alloc; } su_uid_storage; -STATIC void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) { +static void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_storage *old_cxt, UV max_depth) { #define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D)) su_uid **old_map = old_cxt->map; @@ -428,7 +436,7 @@ bool died; } su_uplevel_ud; -STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) { +static su_uplevel_ud *su_uplevel_ud_new(pTHX) { #define su_uplevel_ud_new() su_uplevel_ud_new(aTHX) su_uplevel_ud *sud; PERL_SI *si; @@ -451,7 +459,7 @@ return sud; } -STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { +static void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S)) PERL_SI *si = sud->si; @@ -555,7 +563,7 @@ /* ... Saving array elements ............................................... */ -STATIC I32 su_av_key2idx(pTHX_ AV *av, I32 key) { +static I32 su_av_key2idx(pTHX_ AV *av, I32 key) { #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K)) I32 idx; @@ -590,7 +598,7 @@ I32 idx; } su_ud_adelete; -STATIC void su_adelete(pTHX_ void *ud_) { +static void su_adelete(pTHX_ void *ud_) { su_ud_adelete *ud = (su_ud_adelete *) ud_; av_delete(ud->av, ud->idx, G_DISCARD); @@ -599,7 +607,7 @@ Safefree(ud); } -STATIC void su_save_adelete(pTHX_ AV *av, I32 idx) { +static void su_save_adelete(pTHX_ AV *av, I32 idx) { #define su_save_adelete(A, K) su_save_adelete(aTHX_ (A), (K)) su_ud_adelete *ud; @@ -615,7 +623,7 @@ #endif /* SAVEADELETE */ -STATIC void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) { +static void su_save_aelem(pTHX_ AV *av, SV *key, SV *val) { #define su_save_aelem(A, K, V) su_save_aelem(aTHX_ (A), (K), (V)) I32 idx; I32 preeminent = 1; @@ -645,7 +653,7 @@ /* ... Saving hash elements ................................................ */ -STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) { +static void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) { #define su_save_helem(H, K, V) su_save_helem(aTHX_ (H), (K), (V)) I32 preeminent = 1; HE *he; @@ -692,7 +700,7 @@ CV *old_cv; } su_save_gvcv_ud; -STATIC void su_restore_gvcv(pTHX_ void *ud_) { +static void su_restore_gvcv(pTHX_ void *ud_) { su_save_gvcv_ud *ud = ud_; GV *gv = ud->gv; @@ -703,7 +711,7 @@ Safefree(ud); } -STATIC void su_save_gvcv(pTHX_ GV *gv) { +static void su_save_gvcv(pTHX_ GV *gv) { #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G)) su_save_gvcv_ud *ud; @@ -746,7 +754,7 @@ SV *cb; } su_ud_reap; -STATIC void su_call(pTHX_ void *ud_) { +static void su_call(pTHX_ void *ud_) { su_ud_reap *ud = (su_ud_reap *) ud_; #if SU_SAVE_LAST_CX I32 cxix; @@ -789,7 +797,7 @@ SU_UD_FREE(ud); } -STATIC void su_reap(pTHX_ void *ud) { +static void su_reap(pTHX_ void *ud) { #define su_reap(U) su_reap(aTHX_ (U)) SU_D({ PerlIO_printf(Perl_debug_log, @@ -817,7 +825,7 @@ SU_UD_FREE(U); \ } STMT_END -STATIC I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) { +static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) { #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E)) UV deref = 0; svtype t = SVt_NULL; @@ -898,7 +906,7 @@ return size; } -STATIC void su_localize(pTHX_ void *ud_) { +static void su_localize(pTHX_ void *ud_) { #define su_localize(U) su_localize(aTHX_ (U)) su_ud_localize *ud = (su_ud_localize *) ud_; SV *sv = ud->sv; @@ -971,7 +979,7 @@ # define SU_CXNAME(C) "XXX" #endif -STATIC void su_pop(pTHX_ void *ud) { +static void su_pop(pTHX_ void *ud) { #define su_pop(U) su_pop(aTHX_ (U)) I32 depth, base, mark, *origin; depth = SU_UD_DEPTH(ud); @@ -993,9 +1001,26 @@ ud, 24, ' ', mark, base)); if (base < mark) { +#if SU_HAS_PERL(5, 19, 4) + I32 save = -1; + PERL_CONTEXT *cx; +#endif + SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud)); + +#if SU_HAS_PERL(5, 19, 4) + cx = cxstack + cxstack_ix; + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) + save = PL_scopestack[cx->blk_oldscopesp - 1]; +#endif + PL_savestack_ix = mark; leave_scope(base); + +#if SU_HAS_PERL(5, 19, 4) + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) + PL_scopestack[cx->blk_oldscopesp - 1] = save; +#endif } PL_savestack_ix = base; @@ -1029,7 +1054,7 @@ /* --- Initialize the stack and the action userdata ------------------------ */ -STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { +static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S)) I32 i, depth = 1, pad, offset, *origin; @@ -1117,7 +1142,7 @@ /* --- Unwind stack -------------------------------------------------------- */ -STATIC void su_unwind(pTHX_ void *ud_) { +static void su_unwind(pTHX_ void *ud_) { dMY_CXT; I32 cxix = MY_CXT.unwind_storage.cxix; I32 items = MY_CXT.unwind_storage.items; @@ -1173,7 +1198,7 @@ # define SU_RETOP_LOOP(C) ((C)->blk_loop.last_op->op_next) #endif -STATIC void su_yield(pTHX_ void *ud_) { +static void su_yield(pTHX_ void *ud_) { dMY_CXT; PERL_CONTEXT *cx; const char *which = ud_; @@ -1348,7 +1373,7 @@ #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END -STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { +static su_uplevel_ud *su_uplevel_storage_new(pTHX_ I32 cxix) { #define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I)) su_uplevel_ud *sud; UV depth; @@ -1373,7 +1398,9 @@ return sud; } -STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { +#if SU_HAS_PERL(5, 13, 7) + +static void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S)) dMY_CXT; @@ -1400,8 +1427,10 @@ } } -STATIC int su_uplevel_goto_static(const OP *o) { - for (; o; o = o->op_sibling) { +#endif + +static int su_uplevel_goto_static(const OP *o) { + for (; o; o = OpSIBLING(o)) { /* goto ops are unops with kids. */ if (!(o->op_flags & OPf_KIDS)) continue; @@ -1425,7 +1454,7 @@ #if SU_UPLEVEL_HIJACKS_RUNOPS -STATIC int su_uplevel_goto_runops(pTHX) { +static int su_uplevel_goto_runops(pTHX) { #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX) register OP *op; dVAR; @@ -1485,7 +1514,7 @@ #define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] -STATIC void su_uplevel_restore(pTHX_ void *sus_) { +static void su_uplevel_restore(pTHX_ void *sus_) { su_uplevel_ud *sud = sus_; PERL_SI *cur = sud->old_curstackinfo; PERL_SI *si = sud->si; @@ -1529,8 +1558,10 @@ * depth to be 0, or perl would complain about it being "still in use". * But we *know* that it cannot be so. */ if (sud->renamed) { - CvDEPTH(sud->renamed) = 0; - CvPADLIST(sud->renamed) = NULL; + if (!CvISXSUB(sud->renamed)) { + CvDEPTH(sud->renamed) = 0; + CvPADLIST(sud->renamed) = NULL; + } SvREFCNT_dec(sud->renamed); } @@ -1645,7 +1676,7 @@ return; } -STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { +static CV *su_cv_clone(pTHX_ CV *proto, GV *gv) { #define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G)) dVAR; CV *cv; @@ -1664,6 +1695,9 @@ #endif CvGV_set(cv, gv); +#if SU_RELEASE && SU_HAS_PERL_EXACT(5, 21, 4) + CvNAMED_off(cv); +#endif CvSTASH_set(cv, CvSTASH(proto)); /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to * stashes. CvSTASH_set() started to do it as well with commit c68d95645 @@ -1681,13 +1715,13 @@ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); OP_REFCNT_UNLOCK; CvSTART(cv) = CvSTART(proto); + CvPADLIST(cv) = CvPADLIST(proto); } CvOUTSIDE(cv) = CvOUTSIDE(proto); #ifdef CVf_WEAKOUTSIDE if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE)) #endif SvREFCNT_inc_simple_void(CvOUTSIDE(cv)); - CvPADLIST(cv) = CvPADLIST(proto); #ifdef CvOUTSIDE_SEQ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); #endif @@ -1703,7 +1737,7 @@ return cv; } -STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { +static I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A)) su_uplevel_ud *sud; const PERL_CONTEXT *cx = cxstack + cxix; @@ -1884,7 +1918,7 @@ /* --- Unique context ID --------------------------------------------------- */ -STATIC su_uid *su_uid_storage_fetch(pTHX_ UV depth) { +static su_uid *su_uid_storage_fetch(pTHX_ UV depth) { #define su_uid_storage_fetch(D) su_uid_storage_fetch(aTHX_ (D)) su_uid **map, *uid; STRLEN alloc; @@ -1919,7 +1953,7 @@ return uid; } -STATIC int su_uid_storage_check(pTHX_ UV depth, UV seq) { +static int su_uid_storage_check(pTHX_ UV depth, UV seq) { #define su_uid_storage_check(D, S) su_uid_storage_check(aTHX_ (D), (S)) su_uid *uid; dMY_CXT; @@ -1932,19 +1966,21 @@ return uid && (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); } -STATIC void su_uid_drop(pTHX_ void *ud_) { +static void su_uid_drop(pTHX_ void *ud_) { su_uid *uid = ud_; uid->flags &= ~SU_UID_ACTIVE; } -STATIC void su_uid_bump(pTHX_ void *ud_) { +static void su_uid_bump(pTHX_ void *ud_) { su_ud_reap *ud = ud_; SAVEDESTRUCTOR_X(su_uid_drop, ud->cb); + + SU_UD_FREE(ud); } -STATIC SV *su_uid_get(pTHX_ I32 cxix) { +static SV *su_uid_get(pTHX_ I32 cxix) { #define su_uid_get(I) su_uid_get(aTHX_ (I)) su_uid *uid; SV *uid_sv; @@ -1979,7 +2015,7 @@ #define IS_NUMBER_IN_UV 0x1 -STATIC int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { +static int su_grok_number(pTHX_ const char *s, STRLEN len, UV *valuep) { #define su_grok_number(S, L, VP) su_grok_number(aTHX_ (S), (L), (VP)) STRLEN i; SV *tmpsv; @@ -2000,7 +2036,7 @@ #endif /* !grok_number */ -STATIC int su_uid_validate(pTHX_ SV *uid) { +static int su_uid_validate(pTHX_ SV *uid) { #define su_uid_validate(U) su_uid_validate(aTHX_ (U)) const char *s; STRLEN len, p = 0; @@ -2032,7 +2068,7 @@ /* Remove sequences of BLOCKs having DB for stash, followed by a SUB context * for the debugger callback. */ -STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { +static I32 su_context_skip_db(pTHX_ I32 cxix) { #define su_context_skip_db(C) su_context_skip_db(aTHX_ (C)) I32 i; @@ -2067,7 +2103,7 @@ } -STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) { +static I32 su_context_normalize_up(pTHX_ I32 cxix) { #define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C)) PERL_CONTEXT *cx; @@ -2093,8 +2129,8 @@ return cxix - 1; break; case CXt_SUBST: - if (cx->blk_oldcop && cx->blk_oldcop->op_sibling - && cx->blk_oldcop->op_sibling->op_type == OP_SUBST) + if (cx->blk_oldcop && OpSIBLING(cx->blk_oldcop) + && OpSIBLING(cx->blk_oldcop)->op_type == OP_SUBST) return cxix - 1; break; } @@ -2103,7 +2139,7 @@ return cxix; } -STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { +static I32 su_context_normalize_down(pTHX_ I32 cxix) { #define su_context_normalize_down(C) su_context_normalize_down(aTHX_ (C)) PERL_CONTEXT *next; @@ -2129,8 +2165,8 @@ return cxix + 1; break; case CXt_SUBST: - if (next->blk_oldcop && next->blk_oldcop->op_sibling - && next->blk_oldcop->op_sibling->op_type == OP_SUBST) + if (next->blk_oldcop && OpSIBLING(next->blk_oldcop) + && OpSIBLING(next->blk_oldcop)->op_type == OP_SUBST) return cxix + 1; break; } @@ -2141,7 +2177,7 @@ #define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix)) -STATIC I32 su_context_gimme(pTHX_ I32 cxix) { +static I32 su_context_gimme(pTHX_ I32 cxix) { #define su_context_gimme(C) su_context_gimme(aTHX_ (C)) I32 i; @@ -2160,8 +2196,8 @@ #endif case CXt_SUBST: { const COP *cop = cx->blk_oldcop; - if (cop && cop->op_sibling) { - switch (cop->op_sibling->op_flags & OPf_WANT) { + if (cop && OpSIBLING(cop)) { + switch (OpSIBLING(cop)->op_flags & OPf_WANT) { case OPf_WANT_VOID: return G_VOID; case OPf_WANT_SCALAR: @@ -2183,9 +2219,77 @@ return G_VOID; } +/* --- Global setup/teardown ----------------------------------------------- */ + +static U32 su_initialized = 0; + +static void su_global_teardown(pTHX_ void *root) { + if (!su_initialized) + return; + +#if SU_MULTIPLICITY + if (aTHX != root) + return; +#endif + + SU_LOCK(&su_uid_seq_counter_mutex); + PerlMemShared_free(su_uid_seq_counter.seqs); + su_uid_seq_counter.size = 0; + SU_UNLOCK(&su_uid_seq_counter_mutex); + + MUTEX_DESTROY(&su_uid_seq_counter_mutex); + + su_initialized = 0; + + return; +} + +XS(XS_Scope__Upper_unwind); +XS(XS_Scope__Upper_yield); +XS(XS_Scope__Upper_leave); + +#if SU_HAS_PERL(5, 9, 0) +# define SU_XS_FILE_TYPE const char +#else +# define SU_XS_FILE_TYPE char +#endif + +static void su_global_setup(pTHX_ SU_XS_FILE_TYPE *file) { +#define su_global_setup(F) su_global_setup(aTHX_ (F)) + HV *stash; + + if (su_initialized) + return; + + MUTEX_INIT(&su_uid_seq_counter_mutex); + + SU_LOCK(&su_uid_seq_counter_mutex); + su_uid_seq_counter.seqs = NULL; + su_uid_seq_counter.size = 0; + SU_UNLOCK(&su_uid_seq_counter_mutex); + + stash = gv_stashpv(__PACKAGE__, 1); + newCONSTSUB(stash, "TOP", newSViv(0)); + newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); + + newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL); + newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); + newXSproto("Scope::Upper::leave", XS_Scope__Upper_leave, file, NULL); + +#if SU_MULTIPLICITY + call_atexit(su_global_teardown, aTHX); +#else + call_atexit(su_global_teardown, NULL); +#endif + + su_initialized = 1; + + return; +} + /* --- Interpreter setup/teardown ------------------------------------------ */ -STATIC void su_teardown(pTHX_ void *param) { +static void su_local_teardown(pTHX_ void *param) { su_uplevel_ud *cur; su_uid **map; dMY_CXT; @@ -2211,8 +2315,8 @@ return; } -STATIC void su_setup(pTHX) { -#define su_setup() su_setup(aTHX) +static void su_local_setup(pTHX) { +#define su_local_setup() su_local_setup(aTHX) MY_CXT_INIT; MY_CXT.stack_placeholder = NULL; @@ -2242,7 +2346,7 @@ MY_CXT.uid_storage.used = 0; MY_CXT.uid_storage.alloc = 0; - call_atexit(su_teardown, NULL); + call_atexit(su_local_teardown, NULL); return; } @@ -2285,8 +2389,6 @@ # define SU_INFO_COUNT 10 #endif -XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */ - XS(XS_Scope__Upper_unwind) { #ifdef dVAR dVAR; dXSARGS; @@ -2329,9 +2431,7 @@ croak("Can't return outside a subroutine"); } -STATIC const char su_yield_name[] = "yield"; - -XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */ +static const char su_yield_name[] = "yield"; XS(XS_Scope__Upper_yield) { #ifdef dVAR @@ -2360,9 +2460,7 @@ return; } -STATIC const char su_leave_name[] = "leave"; - -XS(XS_Scope__Upper_leave); /* prototype to pass -Wmissing-prototypes */ +static const char su_leave_name[] = "leave"; XS(XS_Scope__Upper_leave) { #ifdef dVAR @@ -2371,7 +2469,6 @@ dXSARGS; #endif dMY_CXT; - I32 cxix; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ @@ -2392,22 +2489,8 @@ BOOT: { - HV *stash; - - MUTEX_INIT(&su_uid_seq_counter_mutex); - - su_uid_seq_counter.seqs = NULL; - su_uid_seq_counter.size = 0; - - stash = gv_stashpv(__PACKAGE__, 1); - newCONSTSUB(stash, "TOP", newSViv(0)); - newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE)); - - newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL); - newXSproto("Scope::Upper::yield", XS_Scope__Upper_yield, file, NULL); - newXSproto("Scope::Upper::leave", XS_Scope__Upper_leave, file, NULL); - - su_setup(); + su_global_setup(file); + su_local_setup(); } #if SU_THREADSAFE @@ -2693,7 +2776,9 @@ goto context_info_warnings_off; #endif } else if (old_warnings == pWARN_NONE) { +#if !SU_HAS_PERL(5, 17, 4) context_info_warnings_off: +#endif mask = su_newmortal_pvn(WARN_NONEstring, WARNsize); } else if (old_warnings == pWARN_ALL) { HV *bits; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/lib/Scope/Upper.pm new/Scope-Upper-0.27/lib/Scope/Upper.pm --- old/Scope-Upper-0.24/lib/Scope/Upper.pm 2013-09-10 12:45:53.000000000 +0200 +++ new/Scope-Upper-0.27/lib/Scope/Upper.pm 2015-03-27 22:35:12.000000000 +0100 @@ -11,13 +11,13 @@ =head1 VERSION -Version 0.24 +Version 0.27 =cut our $VERSION; BEGIN { - $VERSION = '0.24'; + $VERSION = '0.27'; } =head1 SYNOPSIS @@ -792,6 +792,9 @@ Moreover, in order to handle C<goto> statements properly, L</uplevel> currently has to suffer a run-time overhead proportional to the size of the callback in every case (with a small ratio), and proportional to the size of B<all> the code executed as the result of the L</uplevel> call (including subroutine calls inside the callback) when a C<goto> statement is found in the L</uplevel> callback. Despite this shortcoming, this XS version of L</uplevel> should still run way faster than the pure-Perl version from L<Sub::Uplevel>. +Starting from C<perl> 5.19.4, it is unfortunately no longer possible to reliably throw exceptions from L</uplevel>'d code while the debugger is in use. +This may be solved in a future version depending on how the core evolves. + =head1 DEPENDENCIES L<perl> 5.6.1. @@ -841,7 +844,7 @@ =head1 COPYRIGHT & LICENSE -Copyright 2008,2009,2010,2011,2012,2013 Vincent Pit, all rights reserved. +Copyright 2008,2009,2010,2011,2012,2013,2014,2015 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/09-load-threads.t new/Scope-Upper-0.27/t/09-load-threads.t --- old/Scope-Upper-0.24/t/09-load-threads.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Scope-Upper-0.27/t/09-load-threads.t 2015-03-24 03:24:56.000000000 +0100 @@ -0,0 +1,259 @@ +#!perl + +use strict; +use warnings; + +use lib 't/lib'; +use VPIT::TestHelpers; + +my ($module, $thread_safe_var); +BEGIN { + $module = 'Scope::Upper'; + $thread_safe_var = 'Scope::Upper::SU_THREADSAFE()'; +} + +sub load_test { + my $res; + { + my $var = 0; + if (defined &Scope::Upper::reap) { + &Scope::Upper::reap(sub { $var *= 2 }); + $var = 1; + } + $res = $var; + } + if ($res == 2) { + return 1; + } elsif ($res == 1) { + return 2; + } else { + return $res; + } +} + +# Keep the rest of the file untouched + +BEGIN { + my $is_threadsafe; + + if (defined $thread_safe_var) { + my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"; + if (defined $stat) { + require POSIX; + my $res = $stat >> 8; + if ($res == POSIX::EXIT_SUCCESS()) { + $is_threadsafe = 1; + } elsif ($res == POSIX::EXIT_FAILURE()) { + $is_threadsafe = !1; + } + } + if (not defined $is_threadsafe) { + skip_all "Could not detect if $module is thread safe or not"; + } + } + + VPIT::TestHelpers->import( + threads => [ $module => $is_threadsafe ], + ) +} + +my $could_not_create_thread = 'Could not create thread'; + +use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (2 * 4) + 2; + +sub is_loaded { + my ($affirmative, $desc) = @_; + + my $res = load_test(); + + if ($affirmative) { + is $res, 1, "$desc: module loaded"; + } else { + is $res, 0, "$desc: module not loaded"; + } +} + +BEGIN { + local $@; + my $code = eval "sub { require $module }"; + die $@ if $@; + *do_load = $code; +} + +is_loaded 0, 'main body, beginning'; + +# Test serial loadings + +SKIP: { + my $thr = spawn(sub { + my $here = "first serial thread"; + is_loaded 0, "$here, beginning"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr; + + $thr->join; + if (my $err = $thr->error) { + die $err; + } +} + +is_loaded 0, 'main body, in between serial loadings'; + +SKIP: { + my $thr = spawn(sub { + my $here = "second serial thread"; + is_loaded 0, "$here, beginning"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr; + + $thr->join; + if (my $err = $thr->error) { + die $err; + } +} + +is_loaded 0, 'main body, after serial loadings'; + +# Test nested loadings + +SKIP: { + my $thr = spawn(sub { + my $here = 'parent thread'; + is_loaded 0, "$here, beginning"; + + SKIP: { + my $kid = spawn(sub { + my $here = 'child thread'; + is_loaded 0, "$here, beginning"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (nested child)" => 2 unless defined $kid; + + $kid->join; + if (my $err = $kid->error) { + die "in child thread: $err\n"; + } + } + + is_loaded 0, "$here, after child terminated"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $thr; + + $thr->join; + if (my $err = $thr->error) { + die $err; + } +} + +is_loaded 0, 'main body, after nested loadings'; + +# Test parallel loadings + +use threads; +use threads::shared; + +my @locks = (1) x 5; +share($_) for @locks; + +sub sync_master { + my ($id) = @_; + + { + lock $locks[$id]; + $locks[$id] = 0; + cond_broadcast $locks[$id]; + } +} + +sub sync_slave { + my ($id) = @_; + + { + lock $locks[$id]; + cond_wait $locks[$id] until $locks[$id] == 0; + } +} + +SKIP: { + my $thr1 = spawn(sub { + my $here = 'first simultaneous thread'; + is_loaded 0, "$here, beginning"; + sync_slave 0; + + do_load; + is_loaded 1, "$here, after loading"; + sync_slave 1; + sync_slave 2; + + sync_slave 3; + is_loaded 1, "$here, still loaded while also loaded in the other thread"; + sync_slave 4; + + is_loaded 1, "$here, end"; + + return; + }); + + skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1; + + my $thr2 = spawn(sub { + my $here = 'second simultaneous thread'; + is_loaded 0, "$here, beginning"; + sync_slave 0; + + sync_slave 1; + is_loaded 0, "$here, loaded in other thread but not here"; + sync_slave 2; + + do_load; + is_loaded 1, "$here, after loading"; + sync_slave 3; + sync_slave 4; + + is_loaded 1, "$here, end"; + + return; + }); + + sync_master($_) for 0 .. $#locks; + + $thr1->join; + if (my $err = $thr1->error) { + die $err; + } + + skip "$could_not_create_thread (parallel 2)" => (4 * 1) unless defined $thr2; + + $thr2->join; + if (my $err = $thr2->error) { + die $err; + } +} + +is_loaded 0, 'main body, after simultaneous threads'; + +do_load; +is_loaded 1, 'main body, loaded at end'; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/54-unwind-threads.t new/Scope-Upper-0.27/t/54-unwind-threads.t --- old/Scope-Upper-0.24/t/54-unwind-threads.t 2011-10-22 19:36:05.000000000 +0200 +++ new/Scope-Upper-0.27/t/54-unwind-threads.t 2015-03-19 19:35:42.000000000 +0100 @@ -3,13 +3,16 @@ use strict; use warnings; +use Scope::Upper qw<unwind UP>; + use lib 't/lib'; -use Scope::Upper::TestThreads; +use VPIT::TestHelpers ( + threads => [ 'Scope::Upper' => Scope::Upper::SU_THREADSAFE ], + 'usleep', +); use Test::Leaner; -use Scope::Upper qw<unwind UP>; - our $z; sub up1 { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/59-yield-threads.t new/Scope-Upper-0.27/t/59-yield-threads.t --- old/Scope-Upper-0.24/t/59-yield-threads.t 2012-09-13 22:50:39.000000000 +0200 +++ new/Scope-Upper-0.27/t/59-yield-threads.t 2015-03-19 19:36:00.000000000 +0100 @@ -3,13 +3,16 @@ use strict; use warnings; +use Scope::Upper qw<yield UP>; + use lib 't/lib'; -use Scope::Upper::TestThreads; +use VPIT::TestHelpers ( + threads => [ 'Scope::Upper' => Scope::Upper::SU_THREADSAFE ], + 'usleep', +); use Test::Leaner; -use Scope::Upper qw<yield UP>; - our $z; sub up1 { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/69-uplevel-threads.t new/Scope-Upper-0.27/t/69-uplevel-threads.t --- old/Scope-Upper-0.24/t/69-uplevel-threads.t 2011-10-22 18:46:59.000000000 +0200 +++ new/Scope-Upper-0.27/t/69-uplevel-threads.t 2015-03-19 19:36:15.000000000 +0100 @@ -3,13 +3,16 @@ use strict; use warnings; +use Scope::Upper qw<uplevel UP>; + use lib 't/lib'; -use Scope::Upper::TestThreads; +use VPIT::TestHelpers ( + threads => [ 'Scope::Upper' => Scope::Upper::SU_THREADSAFE ], + 'usleep', +); use Test::Leaner; -use Scope::Upper qw<uplevel UP>; - sub depth { my $depth = 0; while (1) { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/79-uid-threads.t new/Scope-Upper-0.27/t/79-uid-threads.t --- old/Scope-Upper-0.24/t/79-uid-threads.t 2011-10-22 18:49:03.000000000 +0200 +++ new/Scope-Upper-0.27/t/79-uid-threads.t 2015-03-19 19:36:20.000000000 +0100 @@ -3,13 +3,16 @@ use strict; use warnings; +use Scope::Upper qw<uid validate_uid UP HERE>; + use lib 't/lib'; -use Scope::Upper::TestThreads; +use VPIT::TestHelpers ( + threads => [ 'Scope::Upper' => Scope::Upper::SU_THREADSAFE ], + 'usleep', +); use Test::Leaner; -use Scope::Upper qw<uid validate_uid UP HERE>; - my $top = uid; sub cb { diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/lib/Scope/Upper/TestThreads.pm new/Scope-Upper-0.27/t/lib/Scope/Upper/TestThreads.pm --- old/Scope-Upper-0.24/t/lib/Scope/Upper/TestThreads.pm 2013-06-03 14:30:04.000000000 +0200 +++ new/Scope-Upper-0.27/t/lib/Scope/Upper/TestThreads.pm 1970-01-01 01:00:00.000000000 +0100 @@ -1,68 +0,0 @@ -package Scope::Upper::TestThreads; - -use strict; -use warnings; - -use Config qw<%Config>; - -use Scope::Upper qw<SU_THREADSAFE>; - -use VPIT::TestHelpers; - -sub diag { - require Test::Leaner; - Test::Leaner::diag(@_); -} - -sub import { - shift; - - skip_all 'This Scope::Upper isn\'t thread safe' unless SU_THREADSAFE; - - my $force = $ENV{PERL_SCOPE_UPPER_TEST_THREADS} ? 1 : !1; - skip_all 'This perl wasn\'t built to support threads' - unless $Config{useithreads}; - skip_all 'perl 5.13.4 required to test thread safety' - unless $force or "$]" >= 5.013_004; - - load_or_skip_all('threads', $force ? '0' : '1.67', [ ]); - - my %exports = ( - spawn => \&spawn, - ); - - my $usleep; - if (do { local $@; eval { require Time::HiRes; 1 } }) { - defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION; - $exports{usleep} = \&Time::HiRes::usleep; - } else { - diag 'Using fallback usleep'; - $exports{usleep} = sub { - my $s = int($_[0] / 2.5e5); - sleep $s if $s; - }; - } - - my $pkg = caller; - while (my ($name, $code) = each %exports) { - no strict 'refs'; - *{$pkg.'::'.$name} = $code; - } -} - -sub spawn { - local $@; - my @diag; - my $thread = eval { - local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; - threads->create(@_); - }; - push @diag, "Thread creation error: $@" if $@; - if (@diag) { - require Test::Leaner; - Test::Leaner::diag($_) for @diag; - } - return $thread ? $thread : (); -} - -1; diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Scope-Upper-0.24/t/lib/VPIT/TestHelpers.pm new/Scope-Upper-0.27/t/lib/VPIT/TestHelpers.pm --- old/Scope-Upper-0.24/t/lib/VPIT/TestHelpers.pm 2013-06-03 14:30:04.000000000 +0200 +++ new/Scope-Upper-0.27/t/lib/VPIT/TestHelpers.pm 2015-03-24 03:23:19.000000000 +0100 @@ -3,19 +3,58 @@ use strict; use warnings; -my %exports = ( +use Config (); + +sub export_to_pkg { + my ($subs, $pkg) = @_; + + while (my ($name, $code) = each %$subs) { + no strict 'refs'; + *{$pkg.'::'.$name} = $code; + } + + return 1; +} + +my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, + run_perl => \&run_perl, skip_all => \&skip_all, ); +my %features = ( + threads => \&init_threads, + usleep => \&init_usleep, +); + sub import { - my $pkg = caller; + shift; + my @opts = @_; - while (my ($name, $code) = each %exports) { - no strict 'refs'; - *{$pkg.'::'.$name} = $code; + my %exports = %default_exports; + + for (my $i = 0; $i <= $#opts; ++$i) { + my $feature = $opts[$i]; + next unless defined $feature; + + my $args; + if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { + ++$i; + $args = $opts[$i]; + } else { + $args = [ ]; + } + + my $handler = $features{$feature}; + die "Unknown feature '$feature'" unless defined $handler; + + my %syms = $handler->(@$args); + + $exports{$_} = $syms{$_} for sort keys %syms; } + + export_to_pkg \%exports => scalar caller; } my $test_sub = sub { @@ -102,6 +141,91 @@ return $loaded; } +sub run_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>}; + my $ld_name = $Config::Config{ldlibpthname}; + my $ldlibpth = $ENV{$ld_name}; + + local %ENV; + $ENV{$ld_name} = $ldlibpth if defined $ldlibpth; + $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; + $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; + + my $perl = $^X; + unless (-e $perl and -x $perl) { + $perl = $Config::Config{perlpath}; + unless (-e $perl and -x $perl) { + return undef; + } + } + + system { $perl } $perl, '-T', map("-I$_", @INC), '-e', $code; +} + +sub init_threads { + my ($pkg, $threadsafe, $force_var) = @_; + + skip_all 'This perl wasn\'t built to support threads' + unless $Config::Config{useithreads}; + + $pkg = 'package' unless defined $pkg; + skip_all "This $pkg isn't thread safe" if defined $threadsafe and !$threadsafe; + + $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; + my $force = $ENV{$force_var} ? 1 : !1; + skip_all 'perl 5.13.4 required to test thread safety' + unless $force or "$]" >= 5.013_004; + + if (($INC{'Test/More.pm'} || $INC{'Test/Leaner.pm'}) && !$INC{'threads.pm'}) { + die 'Test::More/Test::Leaner was loaded too soon'; + } + + load_or_skip_all 'threads', $force ? '0' : '1.67', [ ]; + load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; + + require Test::Leaner; + + diag "Threads testing forced by \$ENV{$force_var}" if $force; + + return spawn => \&spawn; +} + +sub init_usleep { + my $usleep; + + if (do { local $@; eval { require Time::HiRes; 1 } }) { + defined and diag "Using usleep() from Time::HiRes $_" + for $Time::HiRes::VERSION; + $usleep = \&Time::HiRes::usleep; + } else { + diag 'Using fallback usleep()'; + $usleep = sub { + my $s = int($_[0] / 2.5e5); + sleep $s if $s; + }; + } + + return usleep => $usleep; +} + +sub spawn { + local $@; + my @diag; + my $thread = eval { + local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; + threads->create(@_); + }; + push @diag, "Thread creation error: $@" if $@; + diag @diag; + return $thread ? $thread : (); +} + package VPIT::TestHelpers::Guard; sub new {
