Scope-Upper-0.29/000755 000765 000024 00000000000 12725253620 014423 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/Changes000644 000765 000024 00000036452 12725253446 015736 0ustar00vincentstaff000000 000000 Revision history for Scope-Upper 0.29 2016-06-06 12:00 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 #112246] : Blead breaks Scope::Upper Dave Mitchell provided a new implementation of reap(), localize_*() and uplevel() to match the new context stack handling in perl 5.24. Many thanks to him. 0.28 2015-08-18 15:00 UTC + Chg : SUB() and EVAL() will now warn if they cannot find an appropriate context in the current stack. They will still return undef in this case, which is interpreted as the current context when combined with other words. + Fix : [RT #104751] : Scope::Upper does not handle exotic stack types Trying to target a scope above the current perl scope will now result in a warning. In that case, the topmost context in the current stack will still be returned. Thanks Rafaël Garcia-Suarez for the report. + Fix : Test failures of threads tests on systems with harsh resource constraints causing the threads to exit() during run. + Opt : Some internal structures were shrunk, resulting in memory savings and small speedups. 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. 0.23 2013-09-02 11:30 UTC This is a maintenance release. The code contains no functional change. Satisfied users of version 0.22 can skip this update. + Fix : [RT #87178] : typo fixes. Thanks dsteinbrunner@pobox.com for the patch. + Fix : [RT #88177] : 5.19.3 block hint test breakage t/07-context_info.t has been taught about perl 5.19.3. Thanks Andrew Main for the patch. + Tst : Author tests are no longer bundled with this distribution. They are only made available to authors in the git repository. + Tst : "given is experimental" warnings when running tests on perl 5.18 and above have been silenced. 0.22 2013-01-30 23:35 UTC + Chg : perl 5.6.1 is required. + Fix : context_info() now ignores %warnings::Bits for perl 5.8.6 and below, just like caller(). + Fix : [RT #82220] : Scope-Upper-0.21 test stuck on Windows perl 5.12.3 t/93-pod-spelling.t will not crash anymore on perl 5.12 and below. Thanks Gabor Szabo for reporting and Slaven Rezic for debugging this issue. + Tst : Rare test failures of t/07-context_info.t on perl 5.6, t/55-yield-target.t on perl 5.[68], and t/63-uplevel-ctl.t on perl 5.8.[345] have been addressed. 0.21 2012-09-21 15:10 UTC + Fix : context_info() has been taught about perl 5.17.4. + Fix : t/07-context_info.t will no longer fail with perls that have sitecustomize enabled (like many perl builds for Windows). Thanks Steve Hay and Nicholas Clark for debugging help. + Fix : Broken linkage on Windows with gcc 3.4, which appears in particular when using ActivePerl's default compiler suite. For those setups, the Scope::Upper shared library will now be linked against the perl dll directly (instead of the import library). 0.20 2012-09-17 11:00 UTC + Add : The new yield(@values, $context) function can be used to return values to any upper scope, including do or map blocks. The new leave(@values) function is an alias for yield(@values, HERE). + Add : The new context_info($context) function return information about context $context, similarly to what caller() provides but for any upper scope. + Chg : Contexts are now normalized. In previous versions, it was possible for different contexts to refer to the same scope : for example, "for (my $i = 0; $i < 10; ++$i) { ... }" was reachable through two contexts, while "for (@array) { ... }" only by one. Starting from this version, contexts are normalized so that they always represent an actual scope. + Doc : C++ compilers are officially NOT supported. + Fix : Building with a more recent version of perl 5.17.4. + Fix : Debugger compatibility with perl 5.17.1 and above. 0.19 2012-09-01 13:25 UTC + Doc : POD headings have been made linkable. + Fix : Building with perl 5.17.4. + Fix : BUILD_PREREQS are now set for ExtUtils::MakeMaker. + Opt : uplevel() private data structure is 7% smaller on 64 bits architectures. + Tst : Author tests overhaul. 0.18 2011-10-10 20:50 UTC + Add : The uid() function returns an unique identifier for each dynamic scope. The validate_uid() function can be used to check whether one such identifier is valid (i.e. that the scope it refers to is still alive). + Chg : It is no longer possible on perl 5.6 to call goto() in an uplevel callback to replace the uplevel call. This change was needed in order to ensure consistency between platforms regarding to the following fix just below. + Fix : The uplevel() tests now pass on Windows. Thanks C.H. Kang for bringing this to my attention. 0.17 2011-10-03 21:45 UTC + Fix : uplevel() will now use the correct pad when executing its callback. This fixes at least two issues : - closures defined inside the uplevel callback can now correctly access lexicals from inside and outside the callback. - state variables in the uplevel callback now work properly. + Fix : It is now generally possible to call goto() in the uplevel'd code to replace the uplevel stack frame. There are two cases for which it is still not possible : - if -D flags were set when running perl (as in "perl -Dt ..."). - if the perl runloop has been replaced with a custom one by another module. If uplevel() detects that the replacement code contains a goto statement, and is in one of those two cases, then it will refuse to execute the callback and throw an exception. Note that this fix implies a run-time overhead of uplevel() proportional to the size of the the callback in every case (with a small ratio), and proportional to the size of ALL the code executed as the result of the uplevel call (including subroutine calls inside the callback) when a goto statement is found in the uplevel callback. + Fix : uplevel() has been taught how to handle XS callbacks properly. + Fix : The cause of "Attempt to free unreferenced scalar" warnings when using uplevel() has been addressed. + Fix : [RT #71212] : build failure on Windows. The module does no longer rely on calling Perl_cv_clone, which isn't exported. Thanks C.H. Kang for reporting. 0.16 2011-09-03 23:00 UTC + Add : uplevel($code, @args, $cxt) executes $code with arguments @args in the upper context pointed by $cxt. This is an XS version of the well-known uplevel() routine from Sub::Uplevel. There are a few differences between both implmentations that are listed in the documentation. The XS version is roughly 10 times faster than the pure-Perl version. 0.15 2011-08-24 14:20 UTC + Fix : Localizing subroutines in an higher scope will now correctly update the method cache. 0.14 2011-02-27 00:00 UTC + Fix : [RT #64997] : Compatibility with perl 5.13.10. Thanks Dave Mitchell for the notice. + Tst : Lengthy tests have been ported to Test::Leaner, making the whole test suite about 50% faster. 0.13 2010-12-20 01:00 UTC + Fix : [RT #61904] : Stack corruption when using unwind() under Devel::NYTProf. Thanks Sergey Aleynikov for contributing a fix. + Fix : [RT #63378] : Compatibility with perl 5.13.8. Thanks Andreas J. König for bisecting the issue. + 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.12 2010-05-19 00:45 UTC + Fix : Compatibility with perl 5.13. + Fix : Test failures with perl 5.8.0. + Fix : A minor leak of SVs when a non array/hash was passed to localize_elem(). 0.11 2010-04-16 23:20 UTC + Chg : It's now forbiddent to pass a reference to a non-glob variable as the localization target of localize(), localize_elem() and localize_delete(). + Chg : localize_elem() now only accepts localization of arrays or hashs elements. For other types, it used to be a synonym of localize. + Chg : localize_elem() no longer accepts a glob as the target. You now have to specify the variable as a string. This is because it was impossible in this case to handle meaningfully the array or the hash reference passed as the assigned value. + Doc : The synopsys was revamped, and the rest of the documentation was reviewed. + Fix : [RT #55593] : Segfault when localizing hash or array element to different package in different file. Thanks Dagfinn Ilmari Mannsåker for reporting. + Fix : [RT #56301] : reap loses eval context when dying naturally. Thanks Andrew Main for reporting. + Fix : Scope inconsistencies and segfaults when saving several localizations into the same target scope. + Fix : Stop skipping frames as a pop optimization. This caused breakage under the debugger (and most likely outside as well). 0.10 2010-01-18 23:50 UTC + Fix : Properly handle given/when on 5.10. + Fix : Some stack inconsistencies were fixed, though they were unlikely to have an impact on your real-life code. + Fix : Work around Kwalitee test misfailures. 0.09 2009-05-17 20:20 UTC + Add : The new SU_THREADSAFE constant can be used to know whether the module could have been built with thread safety enabled. + Chg : Thread safety is disabled for perl 5.8 on Win32. + Chg : A saner workaround for the "call_sv() during LEAVE clobbers the still used last popped stack element" issue on 5.10. 0.08 2009-04-16 22:50 UTC + Fix : [RT #44204] : Stack corruption with reap(). Thanks Torsten Foertsch for reporting. + Fix : Building with Solaris CC. + Tst : unwind() in threads. 0.07 2009-02-20 00:20 UTC + Chg : The CLONE method will no longer be defined for non-threaded perls. + Doc : Some examples on how to build the target context from the words. + Fix : Some unlikely possible uninitialized reads, indirectly pointed out in a Redhat review request. + Fix : "localize *x, 'y' => $cxt" now matches Perl's behaviour for "local *x = 'y'". + Fix : Miscellanous code cleanups, courtesy of Florian Ragwitz. + Upd : Resources in META.yml. 0.06 2009-01-17 00:05 UTC + Chg : INCOMPATIBLE CHANGE: The level is now absolute and no longer relative to the current frame - we'll call it "context" from now on. You should replace all your raw levels by combinations of words. The old behaviour of "=> $n" can be easily reobtained by using "=> SCOPE($n)". + Fix : As a result of this change, the module now plays nicely with the debugger. 0.05 2009-01-12 18:15 UTC + Fix : Stack mess when using unwind() in scalar context. + Fix : Returning an automatic variable isn't wise, so let's use a context instead. + Doc : Clarifications. + Tst : Stress tests for unwind(). 0.04 2009-01-11 18:40 UTC + Add : unwind(@things, $level), that returns to an upper context. + Add : want_at($level), that gives the wantarray for $level. + Add : Control words, to reliably get the level of the n-th upper subroutine or eval scope. TOPLEVEL was renamed to TOP. + Fix : Tests with 5.6. + Tst : Reordering and factoring some of the stress tests so that they aren't needlessly ran several times. 0.03 2009-01-04 15:55 UTC + Add : localize_delete(), that localize array/hash elements in upper scopes. + Fix : Segfault when localizing array elements with an invalid negative index. 0.02 2008-12-28 18:40 UTC + Doc : Clarifications and improvements. + Fix : Missing compatibility macros. + Fix : Localized nonexistant array elements should be deleted when their time comes so that the array recovers its original length. 0.01 2008-12-26 16:05 UTC First version, released on an unsuspecting world. Scope-Upper-0.29/lib/000755 000765 000024 00000000000 12725253617 015177 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/Makefile.PL000644 000765 000024 00000006655 12616172256 016415 0ustar00vincentstaff000000 000000 use 5.006_001; use strict; use warnings; use ExtUtils::MakeMaker; use Config; my $pl = $Config{perl_patchlevel}; my $desc = $Config{git_describe}; for ($pl, $desc) { $_ = undef unless defined and length; } my @DEFINES; my %macro; print "Checking if this is an official release of perl... "; my $is_release = ("$]" < 5.011) ? (defined($pl) || defined($desc) ? 0 : 1) : (defined($desc) ? 0 : 1); push @DEFINES, "-DSU_RELEASE=$is_release"; print $is_release ? "yes\n" : "no\n"; 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' && "$]" < 5.009) { push @DEFINES, '-DXSH_MULTIPLICITY=0'; } @DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES; %macro = (macro => { %macro }) if %macro; # Beware of the cycle my $dist = 'Scope-Upper'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'Exporter' => 0, 'XSLoader' => 0, 'base' => 0, ); my %BUILD_REQUIRES = ( 'ExtUtils::MakeMaker' => 0, 'Config' => 0, 'POSIX' => 0, 'Test::More' => 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.006001', 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, ); package MY; sub postamble { return <<'POSTAMBLE'; testdeb: all 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 } Scope-Upper-0.29/MANIFEST000644 000765 000024 00000002616 12723034216 015555 0ustar00vincentstaff000000 000000 Changes MANIFEST META.json META.yml Makefile.PL README Upper.xs lib/Scope/Upper.pm samples/bench_uplevel.pl samples/tag.pl samples/try.pl t/00-load.t t/01-import.t 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 t/15-reap-multi.t t/16-reap-numerous.t t/20-localize-target.t t/21-localize-level.t t/22-localize-block.t t/23-localize-ctl.t t/24-localize-magic.t t/25-localize-multi.t t/26-localize-numerous.t t/30-localize_elem-target.t t/31-localize_elem-level.t t/32-localize_elem-block.t t/34-localize_elem-magic.t t/36-localize_elem-numerous.t t/40-localize_delete-target.t t/41-localize_delete-level.t t/44-localize_delete-magic.t t/46-localize_delete-numerous.t t/50-unwind-target.t t/51-unwind-multi.t t/52-unwind-context.t t/53-unwind-misc.t t/54-unwind-threads.t t/55-yield-target.t t/57-yield-context.t t/58-yield-misc.t t/59-yield-threads.t t/60-uplevel-target.t t/61-uplevel-args.t t/62-uplevel-return.t t/63-uplevel-ctl.t t/64-uplevel-caller.t t/65-uplevel-multi.t t/66-uplevel-context.t t/67-uplevel-scope.t t/69-uplevel-threads.t t/70-uid-target.t t/74-uid-validate.t t/75-uid-uplevel.t t/79-uid-threads.t t/81-stress-level.t t/84-stress-unwind.t t/85-stress-yield.t t/86-stress-uplevel.t t/87-stress-uid.t t/lib/Scope/Upper/TestGenerator.pm t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm xsh/caps.h xsh/debug.h xsh/threads.h xsh/util.h Scope-Upper-0.29/META.json000644 000765 000024 00000003064 12725253620 016047 0ustar00vincentstaff000000 000000 { "abstract" : "Act on upper scopes.", "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" : "Scope-Upper", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Config" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", "POSIX" : "0", "Test::More" : "0", "XSLoader" : "0", "base" : "0" } }, "configure" : { "requires" : { "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Exporter" : "0", "XSLoader" : "0", "base" : "0", "perl" : "5.006001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "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" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2FScope-Upper.git" } }, "version" : "0.29", "x_serialization_backend" : "JSON::PP version 2.27400" } Scope-Upper-0.29/META.yml000644 000765 000024 00000001657 12725253617 015713 0ustar00vincentstaff000000 000000 --- abstract: 'Act on upper scopes.' author: - 'Vincent Pit ' build_requires: Config: '0' Exporter: '0' ExtUtils::MakeMaker: '0' POSIX: '0' Test::More: '0' XSLoader: '0' base: '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: Scope-Upper no_index: directory: - t - inc requires: 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.29' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Scope-Upper-0.29/README000644 000765 000024 00000065210 12725253620 015307 0ustar00vincentstaff000000 000000 NAME Scope::Upper - Act on upper scopes. VERSION Version 0.29 SYNOPSIS "reap", "localize", "localize_elem", "localize_delete" and "WORDS" : package Scope; use Scope::Upper qw< reap localize localize_elem localize_delete :words >; sub new { my ($class, $name) = @_; localize '$tag' => bless({ name => $name }, $class) => UP; reap { print Scope->tag->name, ": end\n" } UP; } # Get the tag stored in the caller namespace sub tag { my $l = 0; my $pkg = __PACKAGE__; $pkg = caller $l++ while $pkg eq __PACKAGE__; no strict 'refs'; ${$pkg . '::tag'}; } sub name { shift->{name} } # Locally capture warnings and reprint them with the name prefixed sub catch { localize_elem '%SIG', '__WARN__' => sub { print Scope->tag->name, ': ', @_; } => UP; } # Locally clear @INC sub private { for (reverse 0 .. $#INC) { # First UP is the for loop, second is the sub boundary localize_delete '@INC', $_ => UP UP; } } ... package UserLand; { Scope->new("top"); # initializes $UserLand::tag { Scope->catch; my $one = 1 + undef; # prints "top: Use of uninitialized value..." { Scope->private; eval { require Cwd }; print $@; # prints "Can't locate Cwd.pm in @INC } # (@INC contains:) at..." require Cwd; # loads Cwd.pm } } # prints "top: done" "unwind" and "want_at" : package Try; use Scope::Upper qw; sub try (&) { my @result = shift->(); my $cx = SUB UP; # Point to the sub above this one unwind +(want_at($cx) ? @result : scalar @result) => $cx; } ... sub zap { try { my @things = qw; return @things; # returns to try() and then outside zap() # not reached }; # not reached } my @stuff = zap(); # @stuff contains qw my $stuff = zap(); # $stuff contains 3 "uplevel" : package Uplevel; use Scope::Upper qw; sub target { faker(@_); } sub faker { uplevel { my $sub = (caller 0)[3]; print "$_[0] from $sub()"; } @_ => CALLER(1); } target('hello'); # "hello from Uplevel::target()" "uid" and "validate_uid" : use Scope::Upper qw; my $uid; { $uid = uid(); { if ($uid eq uid(UP)) { # yes ... } if (validate_uid($uid)) { # yes ... } } } if (validate_uid($uid)) { # no ... } DESCRIPTION This module lets you defer actions *at run-time* that will take place when the control flow returns into an upper scope. Currently, you can: * hook an upper scope end with "reap" ; * localize variables, array/hash values or deletions of elements in higher contexts with respectively "localize", "localize_elem" and "localize_delete" ; * return values immediately to an upper level with "unwind", "yield" and "leave" ; * gather information about an upper context with "want_at" and "context_info" ; * execute a subroutine in the setting of an upper subroutine stack frame with "uplevel" ; * uniquely identify contexts with "uid" and "validate_uid". FUNCTIONS In all those functions, $context refers to the target scope. You have to use one or a combination of "WORDS" to build the $context passed to these functions. This is needed in order to ensure that the module still works when your program is ran in the debugger. The only thing you can assume is that it is an *absolute* indicator of the frame, which means that you can safely store it at some point and use it when needed, and it will still denote the original scope. "reap" reap { ... }; reap { ... } $context; &reap($callback, $context); Adds a destructor that calls $callback (in void context) when the upper scope represented by $context ends. "localize" localize $what, $value; localize $what, $value, $context; Introduces a "local" delayed to the time of first return into the upper scope denoted by $context. $what can be : * A glob, in which case $value can either be a glob or a reference. "localize" follows then the same syntax as "local *x = $value". For example, if $value is a scalar reference, then the "SCALAR" slot of the glob will be set to $$value - just like "local *x = \1" sets $x to 1. * A string beginning with a sigil, representing the symbol to localize and to assign to. If the sigil is '$', "localize" follows the same syntax as "local $x = $value", i.e. $value isn't dereferenced. For example, localize '$x', \'foo' => HERE; will set $x to a reference to the string 'foo'. Other sigils ('@', '%', '&' and '*') require $value to be a reference of the corresponding type. When the symbol is given by a string, it is resolved when the actual localization takes place and not when "localize" is called. Thus, if the symbol name is not qualified, it will refer to the variable in the package where the localization actually takes place and not in the one where the "localize" call was compiled. For example, { package Scope; sub new { localize '$tag', $_[0] => UP } } { package Tool; { Scope->new; ... } } will localize $Tool::tag and not $Scope::tag. If you want the other behaviour, you just have to specify $what as a glob or a qualified name. Note that if $what is a string denoting a variable that wasn't declared beforehand, the relevant slot will be vivified as needed and won't be deleted from the glob when the localization ends. This situation never arises with "local" because it only compiles when the localized variable is already declared. Although I believe it shouldn't be a problem as glob slots definedness is pretty much an implementation detail, this behaviour may change in the future if proved harmful. "localize_elem" localize_elem $what, $key, $value; localize_elem $what, $key, $value, $context; Introduces a "local $what[$key] = $value" or "local $what{$key} = $value" delayed to the time of first return into the upper scope denoted by $context. Unlike "localize", $what must be a string and the type of localization is inferred from its sigil. The two only valid types are array and hash ; for anything besides those, "localize_elem" will throw an exception. $key is either an array index or a hash key, depending of which kind of variable you localize. If $what is a string pointing to an undeclared variable, the variable will be vivified as soon as the localization occurs and emptied when it ends, although it will still exist in its glob. "localize_delete" localize_delete $what, $key; localize_delete $what, $key, $context; Introduces the deletion of a variable or an array/hash element delayed to the time of first return into the upper scope denoted by $context. $what can be: * A glob, in which case $key is ignored and the call is equivalent to "local *x". * A string beginning with '@' or '%', for which the call is equivalent to respectively "local $a[$key]; delete $a[$key]" and "local $h{$key}; delete $h{$key}". * A string beginning with '&', which more or less does "undef &func" in the upper scope. It's actually more powerful, as &func won't even "exists" anymore. $key is ignored. "unwind" unwind; unwind @values, $context; Returns @values *from* the subroutine, eval or format context pointed by or just above $context, and immediately restarts the program flow at this point - thus effectively returning @values to an upper scope. If @values is empty, then the $context parameter is optional and defaults to the current context (making the call equivalent to a bare "return;") ; otherwise it is mandatory. The upper context isn't coerced onto @values, which is hence always evaluated in list context. This means that my $num = sub { my @a = ('a' .. 'z'); unwind @a => HERE; # not reached }->(); will set $num to 'z'. You can use "want_at" to handle these cases. "yield" yield; yield @values, $context; Returns @values *from* the context pointed by or just above $context, and immediately restarts the program flow at this point. If @values is empty, then the $context parameter is optional and defaults to the current context ; otherwise it is mandatory. "yield" differs from "unwind" in that it can target *any* upper scope (besides a "s///e" substitution context) and not necessarily a sub, an eval or a format. Hence you can use it to return values from a "do" or a "map" block : my $now = do { local $@; eval { require Time::HiRes } or yield time() => HERE; Time::HiRes::time(); }; my @uniq = map { yield if $seen{$_}++; # returns the empty list from the block ... } @things; Like for "unwind", the upper context isn't coerced onto @values. You can use the fifth value returned by "context_info" to handle context coercion. "leave" leave; leave @values; Immediately returns @values from the current block, whatever it may be (besides a "s///e" substitution context). "leave" is actually a synonym for "yield HERE", while "leave @values" is a synonym for "yield @values, HERE". Like for "yield", you can use the fifth value returned by "context_info" to handle context coercion. "want_at" my $want = want_at; my $want = want_at $context; Like "wantarray" in perlfunc, but for the subroutine, eval or format context located at or just above $context. It can be used to revise the example showed in "unwind" : my $num = sub { my @a = ('a' .. 'z'); unwind +(want_at(HERE) ? @a : scalar @a) => HERE; # not reached }->(); will rightfully set $num to 26. "context_info" my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = context_info $context; Gives information about the context denoted by $context, akin to what "caller" in perlfunc provides but not limited only to subroutine, eval and format contexts. When $context is omitted, it defaults to the current context. The returned values are, in order : * *(index 0)* : the namespace in use when the context was created ; * *(index 1)* : the name of the file at the point where the context was created ; * *(index 2)* : the line number at the point where the context was created ; * *(index 3)* : the name of the subroutine called for this context, or "undef" if this is not a subroutine context ; * *(index 4)* : a boolean indicating whether a new instance of @_ was set up for this context, or "undef" if this is not a subroutine context ; * *(index 5)* : the context (in the sense of "wantarray" in perlfunc) in which the context (in our sense) is executed ; * *(index 6)* : the contents of the string being compiled for this context, or "undef" if this is not an eval context ; * *(index 7)* : a boolean indicating whether this eval context was created by "require", or "undef" if this is not an eval context ; * *(index 8)* : the value of the lexical hints in use when the context was created ; * *(index 9)* : a bit string representing the warnings in use when the context was created ; * *(index 10)* : a reference to the lexical hints hash in use when the context was created (only on perl 5.10 or greater). "uplevel" my @ret = uplevel { ...; return @ret }; my @ret = uplevel { my @args = @_; ...; return @ret } @args, $context; my @ret = &uplevel($callback, @args, $context); Executes the code reference $callback with arguments @args as if it were located at the subroutine stack frame pointed by $context, effectively fooling "caller" and "die" into believing that the call actually happened higher in the stack. The code is executed in the context of the "uplevel" call, and what it returns is returned as-is by "uplevel". sub target { faker(@_); } sub faker { uplevel { map { 1 / $_ } @_; } @_ => CALLER(1); } my @inverses = target(1, 2, 4); # @inverses contains (0, 0.5, 0.25) my $count = target(1, 2, 4); # $count is 3 Note that if @args is empty, then the $context parameter is optional and defaults to the current context ; otherwise it is mandatory. Sub::Uplevel also implements a pure-Perl version of "uplevel". Both are identical, with the following caveats : * The Sub::Uplevel implementation of "uplevel" may execute a code reference in the context of any upper stack frame. The Scope::Upper version can only uplevel to a subroutine stack frame, and will croak if you try to target an "eval" or a format. * Exceptions thrown from the code called by this version of "uplevel" will not be caught by "eval" blocks between the target frame and the uplevel call, while they will for Sub::Uplevel's version. This means that : eval { sub { local $@; eval { sub { uplevel { die 'wut' } CALLER(2); # for Scope::Upper # uplevel(3, sub { die 'wut' }) # for Sub::Uplevel }->(); }; print "inner block: $@"; $@ and exit; }->(); }; print "outer block: $@"; will print "inner block: wut..." with Sub::Uplevel and "outer block: wut..." with Scope::Upper. * Sub::Uplevel globally overrides the Perl keyword "caller", while Scope::Upper does not. A simple wrapper lets you mimic the interface of "uplevel" in Sub::Uplevel : use Scope::Upper; sub uplevel { my $frame = shift; my $code = shift; my $cxt = Scope::Upper::CALLER($frame); &Scope::Upper::uplevel($code => @_ => $cxt); } Albeit the three exceptions listed above, it passes all the tests of Sub::Uplevel. "uid" my $uid = uid; my $uid = uid $context; Returns an unique identifier (UID) for the context (or dynamic scope) pointed by $context, or for the current context if $context is omitted. This UID will only be valid for the life time of the context it represents, and another UID will be generated next time the same scope is executed. my $uid; { $uid = uid; if ($uid eq uid()) { # yes, this is the same context ... } { if ($uid eq uid()) { # no, we are one scope below ... } if ($uid eq uid(UP)) { # yes, UP points to the same scope as $uid ... } } } # $uid is now invalid { if ($uid eq uid()) { # no, this is another block ... } } For example, each loop iteration gets its own UID : my %uids; for (1 .. 5) { my $uid = uid; $uids{$uid} = $_; } # %uids has 5 entries The UIDs are not guaranteed to be numbers, so you must use the "eq" operator to compare them. To check whether a given UID is valid, you can use the "validate_uid" function. "validate_uid" my $is_valid = validate_uid $uid; Returns true if and only if $uid is the UID of a currently valid context (that is, it designates a scope that is higher than the current one in the call stack). my $uid; { $uid = uid(); if (validate_uid($uid)) { # yes ... } { if (validate_uid($uid)) { # yes ... } } } if (validate_uid($uid)) { # no ... } CONSTANTS "SU_THREADSAFE" True iff the module could have been built when thread-safety features. WORDS Constants "TOP" my $top_context = TOP; Returns the context that currently represents the highest scope. "HERE" my $current_context = HERE; The context of the current scope. Getting a context from a context For any of those functions, $from is expected to be a context. When omitted, it defaults to the current context. "UP" my $upper_context = UP; my $upper_context = UP $from; The context of the scope just above $from. If $from points to the top-level scope in the current stack, then a warning is emitted and $from is returned (see "DIAGNOSTICS" for details). "SUB" my $sub_context = SUB; my $sub_context = SUB $from; The context of the closest subroutine above $from. If $from already designates a subroutine context, then it is returned as-is ; hence "SUB SUB == SUB". If no subroutine context is present in the call stack, then a warning is emitted and the current context is returned (see "DIAGNOSTICS" for details). "EVAL" my $eval_context = EVAL; my $eval_context = EVAL $from; The context of the closest eval above $from. If $from already designates an eval context, then it is returned as-is ; hence "EVAL EVAL == EVAL". If no eval context is present in the call stack, then a warning is emitted and the current context is returned (see "DIAGNOSTICS" for details). Getting a context from a level Here, $level should denote a number of scopes above the current one. When omitted, it defaults to 0 and those functions return the same context as "HERE". "SCOPE" my $context = SCOPE; my $context = SCOPE $level; The $level-th upper context, regardless of its type. If $level points above the top-level scope in the current stack, then a warning is emitted and the top-level context is returned (see "DIAGNOSTICS" for details). "CALLER" my $context = CALLER; my $context = CALLER $level; The context of the $level-th upper subroutine/eval/format. It kind of corresponds to the context represented by "caller $level", but while e.g. "caller 0" refers to the caller context, "CALLER 0" will refer to the top scope in the current context. If $level points above the top-level scope in the current stack, then a warning is emitted and the top-level context is returned (see "DIAGNOSTICS" for details). Examples Where "reap" fires depending on the $cxt : sub { eval { sub { { reap \&cleanup => $cxt; ... } # $cxt = SCOPE(0) = HERE ... }->(); # $cxt = SCOPE(1) = UP = SUB = CALLER(0) ... }; # $cxt = SCOPE(2) = UP UP = UP SUB = EVAL = CALLER(1) ... }->(); # $cxt = SCOPE(3) = SUB UP SUB = SUB EVAL = CALLER(2) ... Where "localize", "localize_elem" and "localize_delete" act depending on the $cxt : sub { eval { sub { { localize '$x' => 1 => $cxt; # $cxt = SCOPE(0) = HERE ... } # $cxt = SCOPE(1) = UP = SUB = CALLER(0) ... }->(); # $cxt = SCOPE(2) = UP UP = UP SUB = EVAL = CALLER(1) ... }; # $cxt = SCOPE(3) = SUB UP SUB = SUB EVAL = CALLER(2) ... }->(); # $cxt = SCOPE(4), UP SUB UP SUB = UP SUB EVAL = UP CALLER(2) = TOP ... Where "unwind", "yield", "want_at", "context_info" and "uplevel" point to depending on the $cxt: sub { eval { sub { { unwind @things => $cxt; # or yield @things => $cxt # or uplevel { ... } $cxt ... } ... }->(); # $cxt = SCOPE(0) = SCOPE(1) = HERE = UP = SUB = CALLER(0) ... }; # $cxt = SCOPE(2) = UP UP = UP SUB = EVAL = CALLER(1) (*) ... }->(); # $cxt = SCOPE(3) = SUB UP SUB = SUB EVAL = CALLER(2) ... # (*) Note that uplevel() will croak if you pass that scope frame, # because it cannot target eval scopes. DIAGNOSTICS "Cannot target a scope outside of the current stack" This warning is emitted when "UP", "SCOPE" or "CALLER" end up pointing to a context that is above the top-level context of the current stack. It indicates that you tried to go higher than the main scope, or to point across a "DESTROY" method, a signal handler, an overloaded or tied method call, a "require" statement or a "sort" callback. In this case, the resulting context is the highest reachable one. "No targetable %s scope in the current stack" This warning is emitted when you ask for an "EVAL" or "SUB" context and no such scope can be found in the call stack. The resulting context is the current one. EXPORT The functions "reap", "localize", "localize_elem", "localize_delete", "unwind", "yield", "leave", "want_at", "context_info" and "uplevel" are only exported on request, either individually or by the tags ':funcs' and ':all'. The constant "SU_THREADSAFE" is also only exported on request, individually or by the tags ':consts' and ':all'. Same goes for the words "TOP", "HERE", "UP", "SUB", "EVAL", "SCOPE" and "CALLER" that are only exported on request, individually or by the tags ':words' and ':all'. CAVEATS It is not possible to act upon a scope that belongs to another perl 'stack', i.e. to target a scope across a "DESTROY" method, a signal handler, an overloaded or tied method call, a "require" statement or a "sort" callback. Be careful that local variables are restored in the reverse order in which they were localized. Consider those examples: local $x = 0; { reap sub { print $x } => HERE; local $x = 1; ... } # prints '0' ... { local $x = 1; reap sub { $x = 2 } => HERE; ... } # $x is 0 The first case is "solved" by moving the "local" before the "reap", and the second by using "localize" instead of "reap". The effects of "reap", "localize" and "localize_elem" can't cross "BEGIN" blocks, hence calling those functions in "import" is deemed to be useless. This is an hopeless case because "BEGIN" blocks are executed once while localizing constructs should do their job at each run. However, it's possible to hook the end of the current scope compilation with B::Hooks::EndOfScope. Some rare oddities may still happen when running inside the debugger. It may help to use a perl higher than 5.8.9 or 5.10.0, as they contain some context-related fixes. Calling "goto" to replace an "uplevel"'d code frame does not work : * for a "perl" older than the 5.8 series ; * for a "DEBUGGING" "perl" run with debugging flags set (as in "perl -D ...") ; * when the runloop callback is replaced by another module. In those three cases, "uplevel" will look for a "goto &sub" statement in its callback and, if there is one, throw an exception before executing the code. Moreover, in order to handle "goto" statements properly, "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 all the code executed as the result of the "uplevel" call (including subroutine calls inside the callback) when a "goto" statement is found in the "uplevel" callback. Despite this shortcoming, this XS 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. 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. XSLoader (core since perl 5.6.0). SEE ALSO "local" in perlfunc, "Temporary Values via local()" in perlsub. Alias, Hook::Scope, Scope::Guard, Guard. Sub::Uplevel. Continuation::Escape is a thin wrapper around Scope::Upper that gives you a continuation passing style interface to "unwind". It's easier to use, but it requires you to have control over the scope where you want to return. Scope::Escape. 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-scope-upper 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 Scope::Upper ACKNOWLEDGEMENTS Inspired by Ricardo Signes. The reimplementation of a large part of this module for perl 5.24 was provided by David Mitchell. His work was sponsored by the Perl 5 Core Maintenance Grant from The Perl Foundation. Thanks to Shawn M. Moore for motivation. 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. Scope-Upper-0.29/samples/000755 000765 000024 00000000000 12725253617 016075 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/t/000755 000765 000024 00000000000 12725253617 014674 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/Upper.xs000644 000765 000024 00000241434 12725251420 016076 0ustar00vincentstaff000000 000000 /* This file is part of the Scope::Upper Perl module. * See http://search.cpan.org/dist/Scope-Upper/ */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* --- XS helpers ---------------------------------------------------------- */ #define XSH_PACKAGE "Scope::Upper" #include "xsh/caps.h" #include "xsh/util.h" #include "xsh/debug.h" /* --- Compatibility ------------------------------------------------------- */ /* perl 5.23.8 onwards has a revamped context system */ #define SU_HAS_NEW_CXT XSH_HAS_PERL(5, 23, 8) #ifndef dVAR # define dVAR dNOOP #endif #ifndef MUTABLE_SV # define MUTABLE_SV(S) ((SV *) (S)) #endif #ifndef MUTABLE_AV # define MUTABLE_AV(A) ((AV *) (A)) #endif #ifndef MUTABLE_CV # define MUTABLE_CV(C) ((CV *) (C)) #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(V) #endif #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif #ifdef DEBUGGING # ifdef PoisonNew # define SU_POISON(D, N, T) PoisonNew((D), (N), T) # elif defined(Poison) # define SU_POISON(D, N, T) Poison((D), (N), T) # endif #endif #ifndef SU_POISON # define SU_POISON(D, N, T) NOOP #endif #ifndef newSV_type static SV *su_newSV_type(pTHX_ svtype t) { SV *sv = newSV(0); SvUPGRADE(sv, t); return sv; } # define newSV_type(T) su_newSV_type(aTHX_ (T)) #endif #ifdef newSVpvn_flags # define su_newmortal_pvn(S, L) newSVpvn_flags((S), (L), SVs_TEMP) #else # define su_newmortal_pvn(S, L) sv_2mortal(newSVpvn((S), (L))) #endif #define su_newmortal_pvs(S) su_newmortal_pvn((S), sizeof(S)-1) #ifndef SvPV_const # define SvPV_const(S, L) SvPV(S, L) #endif #ifndef SvPVX_const # define SvPVX_const(S) SvPVX(S) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(S) SvPV_nolen(S) #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv)) #endif #ifndef mPUSHi # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I))) #endif #ifndef GvCV_set # define GvCV_set(G, C) (GvCV(G) = (C)) #endif #ifndef CvGV_set # define CvGV_set(C, G) (CvGV(C) = (G)) #endif #ifndef CvSTASH_set # define CvSTASH_set(C, S) (CvSTASH(C) = (S)) #endif #ifndef CvISXSUB # define CvISXSUB(C) CvXSUB(C) #endif #ifndef PadlistARRAY # define PadlistARRAY(P) AvARRAY(P) # define PadARRAY(P) AvARRAY(P) #endif #ifndef CxHASARGS # define CxHASARGS(C) ((C)->blk_sub.hasargs) #endif #ifndef CxGIMME # ifdef G_WANT # define CxGIMME(C) ((C)->blk_gimme & G_WANT) # else # define CxGIMME(C) ((C)->blk_gimme) # endif #endif #ifndef CxOLD_OP_TYPE # define CxOLD_OP_TYPE(C) (C)->blk_eval.old_op_type #endif #ifndef OutCopFILE # define OutCopFILE(C) CopFILE(C) #endif #ifndef OutCopFILE_len # define OutCopFILE_len(C) strlen(OutCopFILE(C)) #endif #ifndef CopHINTS_get # define CopHINTS_get(C) ((I32) (C)->op_private & HINT_PRIVATE_MASK) #endif #ifndef CopHINTHASH_get # define CopHINTHASH_get(C) (C)->cop_hints_hash #endif #ifndef cophh_2hv # define COPHH struct refcounted_he # define cophh_2hv(H, F) Perl_refcounted_he_chain_2hv(aTHX_ (H)) #endif #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif #ifndef HvNAMELEN # define HvNAMELEN(H) strlen(HvNAME(H)) #endif #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D)) #endif #ifndef hv_fetchs # define hv_fetchs(H, K, L) hv_fetch((H), (K), sizeof(K)-1, (L)) #endif #ifndef OP_GIMME_REVERSE static U8 su_op_gimme_reverse(U8 gimme) { switch (gimme) { case G_VOID: return OPf_WANT_VOID; case G_ARRAY: return OPf_WANT_LIST; default: break; } return OPf_WANT_SCALAR; } #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 #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef NEGATIVE_INDICES_VAR # define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES" #endif /* --- Error messages ------------------------------------------------------ */ static const char su_stack_smash[] = "Cannot target a scope outside of the current stack"; static const char su_no_such_target[] = "No targetable %s scope in the current stack"; /* --- Unique context ID global storage ------------------------------------ */ /* ... Sequence ID counter ................................................. */ typedef struct { UV *seqs; STRLEN size; } su_uv_array; static su_uv_array su_uid_seq_counter; #ifdef USE_ITHREADS static perl_mutex su_uid_seq_counter_mutex; #endif /* USE_ITHREADS */ 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; XSH_LOCK(&su_uid_seq_counter_mutex); seqs = su_uid_seq_counter.seqs; if (depth >= su_uid_seq_counter.size) { UV i; seqs = PerlMemShared_realloc(seqs, (depth + 1) * sizeof(UV)); for (i = su_uid_seq_counter.size; i <= depth; ++i) seqs[i] = 0; su_uid_seq_counter.seqs = seqs; su_uid_seq_counter.size = depth + 1; } seq = ++seqs[depth]; XSH_UNLOCK(&su_uid_seq_counter_mutex); return seq; } /* ... UID storage ......................................................... */ typedef struct { UV seq; U32 flags; } su_uid; #define SU_UID_ACTIVE 1 static UV su_uid_depth(pTHX_ I32 cxix) { #define su_uid_depth(I) su_uid_depth(aTHX_ (I)) const PERL_SI *si; UV depth; depth = cxix; for (si = PL_curstackinfo->si_prev; si; si = si->si_prev) depth += si->si_cxix + 1; return depth; } typedef struct { su_uid *map; STRLEN used; 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) { #define su_uid_storage_dup(N, O, D) su_uid_storage_dup(aTHX_ (N), (O), (D)) su_uid *old_map = old_cxt->map; if (old_map) { su_uid *new_map = new_cxt->map; STRLEN old_used = old_cxt->used; STRLEN new_used, new_alloc; STRLEN i; new_used = max_depth < old_used ? max_depth : old_used; new_cxt->used = new_used; if (new_used <= new_cxt->alloc) { new_alloc = new_cxt->alloc; } else { new_alloc = new_used; Renew(new_map, new_alloc, su_uid); new_cxt->map = new_map; new_cxt->alloc = new_alloc; } for (i = 0; i < new_alloc; ++i) { su_uid *new_uid = new_map + i; if (i < new_used) { /* => i < max_depth && i < old_used */ su_uid *old_uid = old_map + i; if (old_uid && (old_uid->flags & SU_UID_ACTIVE)) { *new_uid = *old_uid; continue; } } new_uid->seq = 0; new_uid->flags = 0; } } return; } /* --- unwind() global storage --------------------------------------------- */ typedef struct { I32 cxix; I32 items; SV **savesp; LISTOP return_op; OP proxy_op; } su_unwind_storage; /* --- yield() global storage ---------------------------------------------- */ typedef struct { I32 cxix; I32 items; SV **savesp; UNOP leave_op; OP proxy_op; } su_yield_storage; /* --- uplevel() data tokens and global storage ---------------------------- */ #define SU_UPLEVEL_HIJACKS_RUNOPS XSH_HAS_PERL(5, 8, 0) typedef struct { void *next; su_uid_storage tmp_uid_storage; su_uid_storage old_uid_storage; I32 cxix; CV *callback; CV *renamed; #if SU_HAS_NEW_CXT U8 *cxtypes; /* array of saved context types */ I32 gap; /* how many contexts have temporarily CXt_NULLed out*/ AV* argarray; /* the PL_curpad[0] of the uplevel sub */ #else I32 target_depth; CV *target; PERL_SI *si; PERL_SI *old_curstackinfo; AV *old_mainstack; OP *old_op; bool old_catch; bool died; #endif COP *old_curcop; #if SU_UPLEVEL_HIJACKS_RUNOPS runops_proc_t old_runops; #endif } su_uplevel_ud; #if SU_HAS_NEW_CXT /* used to flag a context stack entry whose type has been temporarily * set to CXt_NULL. It relies on perl not using this value for real * CXt_NULL entries. */ # define CXp_SU_UPLEVEL_NULLED 0x20 #endif 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; Newx(sud, 1, su_uplevel_ud); sud->next = NULL; sud->tmp_uid_storage.map = NULL; sud->tmp_uid_storage.used = 0; sud->tmp_uid_storage.alloc = 0; #if !SU_HAS_NEW_CXT Newx(si, 1, PERL_SI); si->si_stack = newAV(); AvREAL_off(si->si_stack); si->si_cxstack = NULL; si->si_cxmax = -1; sud->si = si; #endif return sud; } static void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) { #define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S)) #if !SU_HAS_NEW_CXT PERL_SI *si = sud->si; Safefree(si->si_cxstack); SvREFCNT_dec(si->si_stack); Safefree(si); #endif Safefree(sud->tmp_uid_storage.map); Safefree(sud); return; } typedef struct { su_uplevel_ud *top; su_uplevel_ud *root; I32 count; } su_uplevel_storage; #ifndef SU_UPLEVEL_STORAGE_SIZE # define SU_UPLEVEL_STORAGE_SIZE 4 #endif /* --- Global data --------------------------------------------------------- */ typedef struct { su_unwind_storage unwind_storage; su_yield_storage yield_storage; su_uplevel_storage uplevel_storage; su_uid_storage uid_storage; } xsh_user_cxt_t; #define XSH_THREADS_USER_CONTEXT 1 #define XSH_THREADS_USER_CLONE_NEEDS_DUP 0 #define XSH_THREADS_COMPILE_TIME_PROTECTION 0 #if XSH_THREADSAFE static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt) { new_cxt->uplevel_storage.top = NULL; new_cxt->uplevel_storage.root = NULL; new_cxt->uplevel_storage.count = 0; new_cxt->uid_storage.map = NULL; new_cxt->uid_storage.used = 0; new_cxt->uid_storage.alloc = 0; su_uid_storage_dup(&new_cxt->uid_storage, &old_cxt->uid_storage, old_cxt->uid_storage.used); return; } #endif /* XSH_THREADSAFE */ #include "xsh/threads.h" /* --- Stack manipulations ------------------------------------------------- */ /* how many slots on the save stack various save types take up */ #define SU_SAVE_DESTRUCTOR_SIZE 3 /* SAVEt_DESTRUCTOR_X */ #define SU_SAVE_SCALAR_SIZE 3 /* SAVEt_SV */ #define SU_SAVE_ARY_SIZE 3 /* SAVEt_AV */ #define SU_SAVE_AELEM_SIZE 4 /* SAVEt_AELEM */ #define SU_SAVE_HASH_SIZE 3 /* SAVEt_HV */ #define SU_SAVE_HELEM_SIZE 4 /* SAVEt_HELEM */ #define SU_SAVE_HDELETE_SIZE 4 /* SAVEt_DELETE */ #define SU_SAVE_GVCV_SIZE SU_SAVE_DESTRUCTOR_SIZE /* the overhead of save_alloc() but not including any elements, * of which there must be at least 1 */ #if XSH_HAS_PERL(5, 14, 0) # define SU_SAVE_ALLOC_SIZE 1 /* SAVEt_ALLOC */ #else # define SU_SAVE_ALLOC_SIZE 2 /* SAVEt_ALLOC */ #endif #ifdef SAVEADELETE # define SU_SAVE_ADELETE_SIZE 3 /* SAVEt_ADELETE */ #else # define SU_SAVE_ADELETE_SIZE SU_SAVE_DESTRUCTOR_SIZE #endif /* (NB: it was 4 between 5.13.1 and 5.13.7) */ #if XSH_HAS_PERL(5, 8, 9) # define SU_SAVE_GP_SIZE 3 /* SAVEt_GP */ # else # define SU_SAVE_GP_SIZE 6 /* SAVEt_GP */ #endif /* sometimes we don't know in advance whether we're saving or deleting * an array/hash element. So include enough room for a variable-sized * save_alloc() to pad it to a fixed size. */ #if SU_SAVE_AELEM_SIZE < SU_SAVE_ADELETE_SIZE # define SU_SAVE_AELEM_OR_ADELETE_SIZE \ (SU_SAVE_ADELETE_SIZE + SU_SAVE_ALLOC_SIZE + 1) #elif SU_SAVE_AELEM_SIZE > SU_SAVE_ADELETE_SIZE # define SU_SAVE_AELEM_OR_ADELETE_SIZE \ (SU_SAVE_AELEM_SIZE + SU_SAVE_ALLOC_SIZE + 1) #else # define SU_SAVE_AELEM_OR_ADELETE_SIZE SU_SAVE_AELEM_SIZE #endif #if SU_SAVE_HELEM_SIZE < SU_SAVE_HDELETE_SIZE # define SU_SAVE_HELEM_OR_HDELETE_SIZE \ (SU_SAVE_HDELETE_SIZE + SU_SAVE_ALLOC_SIZE + 1) #elif SU_SAVE_HELEM_SIZE > SU_SAVE_HDELETE_SIZE # define SU_SAVE_HELEM_OR_HDELETE_SIZE \ (SU_SAVE_HELEM_SIZE + SU_SAVE_ALLOC_SIZE + 1) #else # define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE #endif #ifndef SvCANEXISTDELETE # define SvCANEXISTDELETE(sv) \ (!SvRMAGICAL(sv) \ || ((mg = mg_find((SV *) sv, PERL_MAGIC_tied)) \ && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) sv, mg)))) \ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) \ && gv_fetchmethod_autoload(stash, "DELETE", TRUE) \ ) \ ) #endif /* ... Saving array elements ............................................... */ static I32 su_av_key2idx(pTHX_ AV *av, I32 key) { #define su_av_key2idx(A, K) su_av_key2idx(aTHX_ (A), (K)) I32 idx; if (key >= 0) return key; /* Added by MJD in perl-5.8.1 with 6f12eb6d2a1dfaf441504d869b27d2e40ef4966a */ #if XSH_HAS_PERL(5, 8, 1) if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((SV *) av, PERL_MAGIC_tied); if (tied_magic) { SV * const * const negative_indices_glob = hv_fetch( SvSTASH(SvRV(SvTIED_obj((SV *) (av), tied_magic))), NEGATIVE_INDICES_VAR, sizeof(NEGATIVE_INDICES_VAR)-1, 0 ); if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) return key; } } #endif idx = key + av_len(av) + 1; if (idx < 0) return key; return idx; } #ifndef SAVEADELETE typedef struct { AV *av; I32 idx; } su_ud_adelete; static void su_adelete(pTHX_ void *ud_) { su_ud_adelete *ud = (su_ud_adelete *) ud_; av_delete(ud->av, ud->idx, G_DISCARD); SvREFCNT_dec(ud->av); Safefree(ud); } 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; Newx(ud, 1, su_ud_adelete); ud->av = av; ud->idx = idx; SvREFCNT_inc_simple_void(av); SAVEDESTRUCTOR_X(su_adelete, ud); } #define SAVEADELETE(A, K) su_save_adelete((A), (K)) #endif /* SAVEADELETE */ 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; SV **svp; HV *stash; MAGIC *mg; idx = su_av_key2idx(av, SvIV(key)); if (SvCANEXISTDELETE(av)) preeminent = av_exists(av, idx); svp = av_fetch(av, idx, 1); if (!svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx); if (preeminent) save_aelem(av, idx, svp); else SAVEADELETE(av, idx); if (val) { /* local $x[$idx] = $val; */ SvSetMagicSV(*svp, val); } else { /* local $x[$idx]; delete $x[$idx]; */ av_delete(av, idx, G_DISCARD); } } /* ... Saving hash elements ................................................ */ 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; SV **svp; HV *stash; MAGIC *mg; if (SvCANEXISTDELETE(hv) || mg_find((SV *) hv, PERL_MAGIC_env)) preeminent = hv_exists_ent(hv, keysv, 0); he = hv_fetch_ent(hv, keysv, 1, 0); svp = he ? &HeVAL(he) : NULL; if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp)); if (HvNAME_get(hv) && isGV(*svp)) { save_gp((GV *) *svp, 0); return; } if (preeminent) { save_helem(hv, keysv, svp); } else { STRLEN keylen; const char * const key = SvPV_const(keysv, keylen); SAVEDELETE(hv, savepvn(key, keylen), SvUTF8(keysv) ? -(I32)keylen : (I32)keylen); } if (val) { /* local $x{$keysv} = $val; */ SvSetMagicSV(*svp, val); } else { /* local $x{$keysv}; delete $x{$keysv}; */ (void)hv_delete_ent(hv, keysv, G_DISCARD, HeHASH(he)); } } /* ... Saving code slots from a glob ....................................... */ #if !XSH_HAS_PERL(5, 10, 0) && !defined(mro_method_changed_in) # define mro_method_changed_in(G) PL_sub_generation++ #endif typedef struct { GV *gv; CV *old_cv; } su_save_gvcv_ud; static void su_restore_gvcv(pTHX_ void *ud_) { su_save_gvcv_ud *ud = ud_; GV *gv = ud->gv; GvCV_set(gv, ud->old_cv); GvCVGEN(gv) = 0; mro_method_changed_in(GvSTASH(gv)); Safefree(ud); } static void su_save_gvcv(pTHX_ GV *gv) { #define su_save_gvcv(G) su_save_gvcv(aTHX_ (G)) su_save_gvcv_ud *ud; Newx(ud, 1, su_save_gvcv_ud); ud->gv = gv; ud->old_cv = GvCV(gv); GvCV_set(gv, NULL); GvCVGEN(gv) = 0; mro_method_changed_in(GvSTASH(gv)); SAVEDESTRUCTOR_X(su_restore_gvcv, ud); } /* --- Actions ------------------------------------------------------------- */ typedef struct { I32 orig_ix; /* original savestack_ix */ I32 offset; /* how much we bumped this savestack index */ } su_ud_origin_elem; typedef struct { U8 type; U8 private; /* spare */ I32 depth; su_ud_origin_elem *origin; } su_ud_common; #define SU_UD_TYPE(U) (((su_ud_common *) (U))->type) #define SU_UD_PRIVATE(U) (((su_ud_common *) (U))->private) #define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth) #define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin) #define SU_UD_TYPE_REAP 0 #define SU_UD_TYPE_LOCALIZE 1 #define SU_UD_TYPE_UID 2 #define SU_UD_FREE(U) STMT_START { \ if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \ Safefree(U); \ } STMT_END /* ... Reap ................................................................ */ #define SU_SAVE_LAST_CX (!XSH_HAS_PERL(5, 8, 4) || (XSH_HAS_PERL(5, 9, 5) && !XSH_HAS_PERL(5, 14, 0)) || XSH_HAS_PERL(5, 15, 0)) typedef struct { su_ud_common ci; SV *cb; } su_ud_reap; #define SU_UD_REAP_CB(U) (((su_ud_reap *) (U))->cb) static void su_call(pTHX_ SV *cb) { #if SU_SAVE_LAST_CX I32 cxix; PERL_CONTEXT saved_cx; #endif /* SU_SAVE_LAST_CX */ dSP; XSH_D(xsh_debug_log("@@@ call scope_ix=%2d save_ix=%2d\n", PL_scopestack_ix, PL_savestack_ix)); ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; #if SU_SAVE_LAST_CX /* If the recently popped context isn't saved there, it will be overwritten by * the sub scope from call_sv, although it's still needed in our caller. */ cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); saved_cx = cxstack[cxix]; #endif /* SU_SAVE_LAST_CX */ call_sv(cb, G_VOID); #if SU_SAVE_LAST_CX cxstack[cxix] = saved_cx; #endif /* SU_SAVE_LAST_CX */ PUTBACK; FREETMPS; LEAVE; SvREFCNT_dec(cb); return; } /* ... Localize & localize array/hash element .............................. */ typedef struct { su_ud_common ci; SV *sv; SV *val; SV *elem; } su_ud_localize; #define SU_UD_LOCALIZE_SV(U) (((su_ud_localize *) (U))->sv) #define SU_UD_LOCALIZE_VAL(U) (((su_ud_localize *) (U))->val) #define SU_UD_LOCALIZE_ELEM(U) (((su_ud_localize *) (U))->elem) #define SU_UD_LOCALIZE_FREE(U) STMT_START { \ SvREFCNT_dec(SU_UD_LOCALIZE_ELEM(U)); \ SvREFCNT_dec(SU_UD_LOCALIZE_VAL(U)); \ SvREFCNT_dec(SU_UD_LOCALIZE_SV(U)); \ SU_UD_FREE(U); \ } STMT_END 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; I32 size; SvREFCNT_inc_simple_void(sv); if (SvTYPE(sv) >= SVt_PVGV) { if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */ t = SVt_PVGV; } else { /* local *x = \$val; */ t = SvTYPE(SvRV(val)); deref = 1; } } else if (SvROK(sv)) { croak("Invalid %s reference as the localization target", sv_reftype(SvRV(sv), 0)); } else { STRLEN len, l; const char *p = SvPV_const(sv, len), *s; for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { } if (!l) { l = len; s = p; } switch (*s) { case '$': t = SVt_PV; break; case '@': t = SVt_PVAV; break; case '%': t = SVt_PVHV; break; case '&': t = SVt_PVCV; break; case '*': t = SVt_PVGV; break; } if (t != SVt_NULL) { ++s; --l; } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */ if (SvROK(val) && !sv_isobject(val)) { t = SvTYPE(SvRV(val)); deref = 1; } else { t = SvTYPE(val); } } SvREFCNT_dec(sv); sv = newSVpvn(s, l); } switch (t) { case SVt_PVAV: size = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE : SU_SAVE_ARY_SIZE; deref = 0; break; case SVt_PVHV: size = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE : SU_SAVE_HASH_SIZE; deref = 0; break; case SVt_PVGV: size = SU_SAVE_GP_SIZE; deref = 0; break; case SVt_PVCV: size = SU_SAVE_GVCV_SIZE; deref = 0; break; default: size = SU_SAVE_SCALAR_SIZE; break; } /* When deref is set, val isn't NULL */ SU_UD_PRIVATE(ud) = t; ud->sv = sv; ud->val = val ? newSVsv(deref ? SvRV(val) : val) : NULL; ud->elem = SvREFCNT_inc(elem); return size; } 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; SV *val = ud->val; SV *elem = ud->elem; svtype t = SU_UD_PRIVATE(ud); GV *gv; if (SvTYPE(sv) >= SVt_PVGV) { gv = (GV *) sv; } else { /* new perl context implementation frees savestack *before* restoring * PL_curcop. Temporarily restore it prematurely to make gv_fetch* * looks up unqualified var names in the caller's package */ #if SU_HAS_NEW_CXT COP *old_cop = PL_curcop; PL_curcop = CX_CUR()->blk_oldcop; #endif #ifdef gv_fetchsv gv = gv_fetchsv(sv, GV_ADDMULTI, t); #else { STRLEN len; const char *name = SvPV_const(sv, len); gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t); } #endif #if SU_HAS_NEW_CXT CX_CUR()->blk_oldcop = old_cop; #endif } XSH_D({ SV *z = newSV(0); SvUPGRADE(z, t); xsh_debug_log("%p: === localize a %s\n", ud, sv_reftype(z, 0)); xsh_debug_log("%p: depth=%2d scope_ix=%2d save_ix=%2d\n", ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix); SvREFCNT_dec(z); }); /* Inspired from Alias.pm */ switch (t) { case SVt_PVAV: if (elem) { su_save_aelem(GvAV(gv), elem, val); return; } else { save_ary(gv); } break; case SVt_PVHV: if (elem) { su_save_helem(GvHV(gv), elem, val); return; } else { save_hash(gv); } break; case SVt_PVGV: save_gp(gv, 1); /* hide previous entry in symtab */ break; case SVt_PVCV: su_save_gvcv(gv); break; default: gv = (GV *) save_scalar(gv); break; } if (val) SvSetMagicSV((SV *) gv, val); return; } /* ... Unique context ID ................................................... */ /* We must pass the index because XSH_CXT.uid_storage might be reallocated * between the UID fetch and the invalidation at the end of scope. */ typedef struct { su_ud_common ci; I32 idx; } su_ud_uid; static void su_uid_drop(pTHX_ void *ud_) { su_ud_uid *ud = ud_; dXSH_CXT; XSH_CXT.uid_storage.map[ud->idx].flags &= ~SU_UID_ACTIVE; SU_UD_FREE(ud); return; } /* --- Pop a context back -------------------------------------------------- */ #ifdef DEBUGGING # define SU_CX_TYPENAME(T) PL_block_type[(T)] #else # if XSH_HAS_PERL(5, 23, 8) static const char *su_block_type[] = { "NULL", "WHEN", "BLOCK", "GIVEN", "LOOP_ARY", "LOOP_LAZYSV", "LOOP_LAZYIV", "LOOP_LIST", "LOOP_PLAIN", "SUB", "FORMAT", "EVAL", "SUBST" }; # elif XSH_HAS_PERL(5, 11, 0) static const char *su_block_type[] = { "NULL", "WHEN", "BLOCK", "GIVEN", "LOOP_FOR", "LOOP_PLAIN", "LOOP_LAZYSV", "LOOP_LAZYIV", "SUB", "FORMAT", "EVAL", "SUBST" }; # elif XSH_HAS_PERL(5, 10, 0) static const char *su_block_type[] = { "NULL", "SUB", "EVAL", "LOOP", "SUBST", "BLOCK", "FORMAT" "WHEN", "GIVEN" }; # else static const char *su_block_type[] = { "NULL", "SUB", "EVAL", "LOOP", "SUBST", "BLOCK", "FORMAT" }; # endif # define SU_CX_TYPENAME(T) su_block_type[(T)] #endif #define SU_CXNAME(C) SU_CX_TYPENAME(CxTYPE(C)) #if XSH_DEBUG /* for debugging. These indicate how many ENTERs each context type * does before the PUSHBLOCK */ static const int su_cxt_enter_count[] = { # if XSH_HAS_PERL(5, 23, 8) 0 /* context pushes no longer do ENTERs */ # elif XSH_HAS_PERL(5, 11, 0) /* NULL WHEN BLOCK GIVEN LOOP_FOR LOOP_PLAIN LOOP_LAZYSV * LOOP_LAZYIV SUB FORMAT EVAL SUBST */ 0, 1, 1, 1, 2, 2, 2, 2, 1, 1, 1, 0 # elif XSH_HAS_PERL(5, 10, 0) /* NULL SUB EVAL LOOP SUBST BLOCK FORMAT WHEN GIVEN */ 0, 1, 1, 2, 0, 1, 1, 1, 1 # else /* NULL SUB EVAL LOOP SUBST BLOCK FORMAT */ 0, 1, 1, 2, 0, 1, 1 # endif }; #endif /* XSH_DEBUG */ /* push at least 'size' slots worth of padding onto the savestack */ static void su_ss_push_padding(pTHX_ void *ud, I32 size) { #define su_ss_push_padding(U, S) su_ss_push_padding(aTHX_ (U), (S)) if (size <= 0) return; if (size < SU_SAVE_ALLOC_SIZE + 1) /* minimum possible SAVEt_ALLOC */ size = SU_SAVE_ALLOC_SIZE + 1; XSH_D(xsh_debug_log( "%p: push %2d padding at save_ix=%d\n", ud, size, PL_savestack_ix)); save_alloc((size - SU_SAVE_ALLOC_SIZE) * sizeof(*PL_savestack), 0); return; } static void su_pop(pTHX_ void *ud); /* push an su_pop destructor onto the savestack with suitable padding. * first indicates that this is the first push of a destructor */ static void su_ss_push_destructor(pTHX_ void *ud, I32 depth, bool first) { #define su_ss_push_destructor(U, D, F) su_ss_push_destructor(aTHX_ (U), (D), (F)) su_ud_origin_elem *origin = SU_UD_ORIGIN(ud); assert(first || origin[depth+1].orig_ix == PL_savestack_ix); su_ss_push_padding(ud, (origin[depth].orig_ix + origin[depth].offset) - PL_savestack_ix); XSH_D(xsh_debug_log( "%p: push destructor at save_ix=%d depth=%d scope_ix=%d\n", ud, PL_savestack_ix, depth, PL_scopestack_ix)); SAVEDESTRUCTOR_X(su_pop, ud); assert(first || PL_savestack_ix <= origin[depth+1].orig_ix + origin[depth+1].offset); return; } /* this is called during each leave_scope() via SAVEDESTRUCTOR_X */ static void su_pop(pTHX_ void *ud) { #define su_pop(U) su_pop(aTHX_ (U)) I32 depth, base, mark; su_ud_origin_elem *origin; depth = SU_UD_DEPTH(ud); origin = SU_UD_ORIGIN(ud); XSH_D(xsh_debug_log("%p: ### su_pop: depth=%d\n", ud, depth)); depth--; mark = PL_savestack_ix; base = origin[depth].orig_ix; XSH_D(xsh_debug_log("%p: residual savestack frame is %d(+%d)..%d\n", ud, base, origin[depth].offset, mark)); if (base < mark) { XSH_D(xsh_debug_log("%p: clear leftovers at %d..%d\n", ud, base, mark)); leave_scope(base); } assert(PL_savestack_ix == base); SU_UD_DEPTH(ud) = depth; if (depth > 0) { su_ss_push_destructor(ud, depth-1, 0); } else { I32 offset = origin[0].offset; /* grab value before origin is freed */ switch (SU_UD_TYPE(ud)) { case SU_UD_TYPE_REAP: { XSH_D( xsh_debug_log("%p: === reap\n%p: depth=%d scope_ix=%d save_ix=%d\n", ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix) ); SAVEDESTRUCTOR_X(su_call, SU_UD_REAP_CB(ud)); SU_UD_FREE(ud); break; } case SU_UD_TYPE_LOCALIZE: su_localize(ud); SU_UD_LOCALIZE_FREE(ud); break; case SU_UD_TYPE_UID: SAVEDESTRUCTOR_X(su_uid_drop, ud); break; } /* perl 5.23.8 onwards is very fussy about the return from leave_scope() * leaving PL_savestack_ix where it expects it to be */ if (PL_savestack_ix < base + offset) { I32 gap = (base + offset) - PL_savestack_ix; assert(gap >= SU_SAVE_ALLOC_SIZE + 1); su_ss_push_padding(ud, gap); } assert(PL_savestack_ix == base + offset); } XSH_D(xsh_debug_log("%p: end pop: ss_ix=%d\n", ud, PL_savestack_ix)); } /* --- Initialize the stack and the action userdata ------------------------ */ static void su_init(pTHX_ void *ud, I32 cxix, I32 size) { #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S)) su_ud_origin_elem *origin; I32 i, depth; I32 cur_cx_ix, cur_scope_ix; XSH_D(xsh_debug_log("%p: ### su_init(cxix=%d, size=%d)\n", ud, cxix, size)); depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp; #if SU_HAS_NEW_CXT depth += (cxstack_ix - cxix); /* each context frame holds 1 scope */ #endif XSH_D(xsh_debug_log( "%p: going down by depth=%d with scope_ix=%d save_ix=%d\n", ud, depth, PL_scopestack_ix, PL_savestack_ix)); /* Artificially increase the position of each savestack frame boundary * to make space to squeeze in a 'size' sized entry (first one) or a * SU_SAVE_DESTRUCTOR_SIZE sized entry (higher ones). In addition, make * sure that each boundary is higher than the previous, so that *every* * scope exit triggers a call to leave_scope(). Each scope exit will call * the su_pop() destructor, which is responsible for: freeing any * savestack entries below the artificially raised floor; then pushing a * new destructor in that space. On the final pop, the "real" savestack * action is pushed rather than another destructor. * * On older perls, savestack frame boundaries are specified by a range of * scopestack entries (one per ENTER). Each scope entry typically does * one or two ENTERs followed by a PUSHBLOCK. Thus the * cx->blku_oldscopesp field set by the PUSHBLOCK points to the next free * slot, which is one above the last of the ENTERs. In the debugging * output we indicate that by bracketing the ENTERs directly preceding * that context push with dashes, e.g.: * * 13b98d8: ------------------ * 13b98d8: ENTER origin[0] scope[3] savestack=3+3 * 13b98d8: ENTER origin[1] scope[4] savestack=9+3 * 13b98d8: cx=1 LOOP_LAZYIV * 13b98d8: ------------------ * * In addition to context stack pushes, other activities can push ENTERs * too, such as grep expr and XS sub calls. * * For newer perls (SU_HAS_NEW_CXT), a context push no longer does any * ENTERs; instead the old savestack position is stored in the new * cx->blk_oldsaveix field; thus this field specifies an additional * savestack frame boundary point in addition to the scopestack entries, * and will also need adjusting. * * We record the original and modified position of each boundary in the * origin array. * * The passed cxix argument represents the scope we wish to inject into; * we have to adjust all the savestack frame boundaries above (but not * including) that context. */ Newx(origin, depth, su_ud_origin_elem); cur_cx_ix = cxix; cur_scope_ix = cxstack[cxix].blk_oldscopesp; #if SU_HAS_NEW_CXT XSH_D(xsh_debug_log("%p: cx=%-2d %-11s\n", ud, cur_cx_ix, SU_CXNAME(cxstack+cur_cx_ix))); cur_cx_ix++; #endif for (i = 0; cur_scope_ix < PL_scopestack_ix; i++) { I32 *ixp; I32 offset; #if SU_HAS_NEW_CXT if (cur_cx_ix <= cxstack_ix && cur_scope_ix == cxstack[cur_cx_ix].blk_oldscopesp) ixp = &(cxstack[cur_cx_ix++].blk_oldsaveix); else ixp = &PL_scopestack[cur_scope_ix++]; /* an ENTER pushed after cur context */ #else XSH_D({ if (cur_cx_ix <= cxstack_ix) { if (cur_scope_ix == cxstack[cur_cx_ix].blk_oldscopesp) { xsh_debug_log("%p: cx=%-2d %s\n%p: ------------------\n", ud, cur_cx_ix, SU_CXNAME(cxstack+cur_cx_ix), ud); cur_cx_ix++; } else if (cur_scope_ix + su_cxt_enter_count[CxTYPE(cxstack+cur_cx_ix)] == cxstack[cur_cx_ix].blk_oldscopesp) xsh_debug_log("%p: ------------------\n", ud); } }); ixp = &PL_scopestack[cur_scope_ix++]; #endif if (i == 0) { offset = size; } else { /* we have three constraints to satisfy: * 1) Each adjusted offset must be at least SU_SAVE_DESTRUCTOR_SIZE * above its unadjusted boundary, so that there is space to inject a * destructor into the outer scope. * 2) Each adjusted boundary must be at least SU_SAVE_DESTRUCTOR_SIZE * higher than the previous adjusted boundary, so that a new * destructor can be added below the Nth adjusted frame boundary, * but be within the (N-1)th adjusted frame and so be triggered on * the next scope exit; * 3) If the adjustment needs to be greater than SU_SAVE_DESTRUCTOR_SIZE, * then it should be greater by an amount of at least the minimum * pad side, so a destructor and padding can be pushed. */ I32 pad; offset = SU_SAVE_DESTRUCTOR_SIZE; /* rule 1 */ pad = (origin[i-1].orig_ix + origin[i-1].offset) + offset - (*ixp + offset); if (pad > 0) { /* rule 2 */ if (pad < SU_SAVE_ALLOC_SIZE + 1) /* rule 3 */ pad = SU_SAVE_ALLOC_SIZE + 1; offset += pad; } } origin[i].offset = offset; origin[i].orig_ix = *ixp; *ixp += offset; #if SU_HAS_NEW_CXT XSH_D({ if (ixp == &PL_scopestack[cur_scope_ix-1]) xsh_debug_log( "%p: ENTER origin[%d] scope[%d] savestack=%d+%d\n", ud, i, cur_scope_ix, origin[i].orig_ix, origin[i].offset); else xsh_debug_log( "%p: cx=%-2d %-11s origin[%d] scope[%d] savestack=%d+%d\n", ud, cur_cx_ix-1, SU_CXNAME(cxstack+cur_cx_ix-1), i, cur_scope_ix, origin[i].orig_ix, origin[i].offset); }); #else XSH_D(xsh_debug_log( "%p: ENTER origin[%d] scope[%d] savestack=%d+%d\n", ud, i, cur_scope_ix, origin[i].orig_ix, origin[i].offset)); #endif } assert(i == depth); SU_UD_DEPTH(ud) = depth; SU_UD_ORIGIN(ud) = origin; su_ss_push_destructor(ud, depth-1, 1); } /* --- Unwind stack -------------------------------------------------------- */ static void su_unwind(pTHX_ void *ud_) { dXSH_CXT; I32 cxix = XSH_CXT.unwind_storage.cxix; I32 items = XSH_CXT.unwind_storage.items; I32 mark; PERL_UNUSED_VAR(ud_); PL_stack_sp = XSH_CXT.unwind_storage.savesp; #if XSH_HAS_PERL(5, 19, 4) { I32 i; SV **sp = PL_stack_sp; for (i = -items + 1; i <= 0; ++i) if (!SvTEMP(sp[i])) sv_2mortal(SvREFCNT_inc(sp[i])); } #endif if (cxstack_ix > cxix) dounwind(cxix); mark = PL_markstack[cxstack[cxix].blk_oldmarksp]; PUSHMARK(PL_stack_sp - items); XSH_D({ I32 gimme = GIMME_V; xsh_debug_log("%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n", &XSH_CXT, cxix, gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar", items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark); }); PL_op = (OP *) &(XSH_CXT.unwind_storage.return_op); PL_op = PL_op->op_ppaddr(aTHX); *PL_markstack_ptr = mark; XSH_CXT.unwind_storage.proxy_op.op_next = PL_op; PL_op = &(XSH_CXT.unwind_storage.proxy_op); } /* --- Yield --------------------------------------------------------------- */ #if XSH_HAS_PERL(5, 10, 0) # define SU_RETOP_SUB(C) ((C)->blk_sub.retop) # define SU_RETOP_EVAL(C) ((C)->blk_eval.retop) # define SU_RETOP_LOOP(C) ((C)->blk_loop.my_op->op_lastop->op_next) # define SU_RETOP_GIVEN(C) ((C)->blk_givwhen.leave_op->op_next) #else # define SU_RETOP_SUB(C) ((C)->blk_oldretsp > 0 ? PL_retstack[(C)->blk_oldretsp - 1] : NULL) # define SU_RETOP_EVAL(C) SU_RETOP_SUB(C) # define SU_RETOP_LOOP(C) ((C)->blk_loop.last_op->op_next) #endif static void su_yield(pTHX_ void *ud_) { dXSH_CXT; PERL_CONTEXT *cx; const char *which = ud_; I32 cxix = XSH_CXT.yield_storage.cxix; I32 items = XSH_CXT.yield_storage.items; opcode type = OP_NULL; U8 flags = 0; OP *next; cx = cxstack + cxix; switch (CxTYPE(cx)) { case CXt_BLOCK: { I32 i, cur = cxstack_ix, n = 1; OP *o = NULL; /* Is this actually a given/when block? This may occur only when yield was * called with HERE (or nothing) as the context. */ #if XSH_HAS_PERL(5, 10, 0) if (cxix > 0) { PERL_CONTEXT *prev = cx - 1; U8 prev_type = CxTYPE(prev); if ((prev_type == CXt_GIVEN || prev_type == CXt_WHEN) && (prev->blk_oldcop == cx->blk_oldcop)) { cxix--; cx = prev; if (prev_type == CXt_GIVEN) goto cxt_given; else goto cxt_when; } } #endif type = OP_LEAVE; next = NULL; /* Bare blocks (that appear as do { ... } blocks, map { ... } blocks or * constant folded blcoks) don't need to save the op to return to anywhere * since 'last' isn't supposed to work inside them. So we climb higher in * the context stack until we reach a context that has a return op (i.e. a * sub, an eval, a format or a real loop), recording how many blocks we * crossed. Then we follow the op_next chain until we get to the leave op * that closes the original block, which we are assured to reach since * everything is static (the blocks we have crossed cannot be evals or * subroutine calls). */ for (i = cxix + 1; i <= cur; ++i) { PERL_CONTEXT *cx2 = cxstack + i; switch (CxTYPE(cx2)) { case CXt_BLOCK: ++n; break; case CXt_SUB: case CXt_FORMAT: o = SU_RETOP_SUB(cx2); break; case CXt_EVAL: o = SU_RETOP_EVAL(cx2); break; #if XSH_HAS_PERL(5, 11, 0) # if XSH_HAS_PERL(5, 23, 8) case CXt_LOOP_ARY: case CXt_LOOP_LIST: # else case CXt_LOOP_FOR: # endif case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: #else case CXt_LOOP: #endif o = SU_RETOP_LOOP(cx2); break; } if (o) break; } if (!o) o = PL_op; while (n && o) { /* We may find other enter/leave blocks on our way to the matching leave. * Make sure the depth is incremented/decremented appropriately. */ if (o->op_type == OP_ENTER) { ++n; } else if (o->op_type == OP_LEAVE) { --n; if (!n) { next = o->op_next; break; } } o = o->op_next; } break; } case CXt_SUB: case CXt_FORMAT: type = OP_LEAVESUB; next = SU_RETOP_SUB(cx); break; case CXt_EVAL: type = CxTRYBLOCK(cx) ? OP_LEAVETRY : OP_LEAVEEVAL; next = SU_RETOP_EVAL(cx); break; #if XSH_HAS_PERL(5, 11, 0) # if XSH_HAS_PERL(5, 23, 8) case CXt_LOOP_ARY: case CXt_LOOP_LIST: # else case CXt_LOOP_FOR: # endif case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: #else case CXt_LOOP: #endif type = OP_LEAVELOOP; next = SU_RETOP_LOOP(cx); break; #if XSH_HAS_PERL(5, 10, 0) case CXt_GIVEN: cxt_given: type = OP_LEAVEGIVEN; next = SU_RETOP_GIVEN(cx); break; case CXt_WHEN: cxt_when: #if XSH_HAS_PERL(5, 15, 1) type = OP_LEAVEWHEN; #else type = OP_BREAK; flags |= OPf_SPECIAL; #endif next = NULL; break; #endif case CXt_SUBST: croak("%s() can't target a substitution context", which); break; default: croak("%s() doesn't know how to leave a %s context", which, SU_CXNAME(cxstack + cxix)); break; } PL_stack_sp = XSH_CXT.yield_storage.savesp; #if XSH_HAS_PERL(5, 19, 4) { I32 i; SV **sp = PL_stack_sp; for (i = -items + 1; i <= 0; ++i) if (!SvTEMP(sp[i])) sv_2mortal(SvREFCNT_inc(sp[i])); } #endif if (cxstack_ix > cxix) dounwind(cxix); /* Copy the arguments passed to yield() where the leave op expects to find * them. */ if (items) Move(PL_stack_sp - items + 1, PL_stack_base + cx->blk_oldsp + 1, items, SV *); PL_stack_sp = PL_stack_base + cx->blk_oldsp + items; flags |= OP_GIMME_REVERSE(cx->blk_gimme); XSH_CXT.yield_storage.leave_op.op_type = type; XSH_CXT.yield_storage.leave_op.op_ppaddr = PL_ppaddr[type]; XSH_CXT.yield_storage.leave_op.op_flags = flags; XSH_CXT.yield_storage.leave_op.op_next = next; PL_op = (OP *) &(XSH_CXT.yield_storage.leave_op); PL_op = PL_op->op_ppaddr(aTHX); XSH_CXT.yield_storage.proxy_op.op_next = PL_op; PL_op = &(XSH_CXT.yield_storage.proxy_op); } /* --- Uplevel ------------------------------------------------------------- */ #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) { #define su_uplevel_storage_new(I) su_uplevel_storage_new(aTHX_ (I)) su_uplevel_ud *sud; UV depth; dXSH_CXT; sud = XSH_CXT.uplevel_storage.root; if (sud) { XSH_CXT.uplevel_storage.root = sud->next; XSH_CXT.uplevel_storage.count--; } else { sud = su_uplevel_ud_new(); } sud->next = XSH_CXT.uplevel_storage.top; XSH_CXT.uplevel_storage.top = sud; depth = su_uid_depth(cxix); su_uid_storage_dup(&sud->tmp_uid_storage, &XSH_CXT.uid_storage, depth); sud->old_uid_storage = XSH_CXT.uid_storage; XSH_CXT.uid_storage = sud->tmp_uid_storage; return sud; } #if XSH_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)) dXSH_CXT; sud->tmp_uid_storage = XSH_CXT.uid_storage; XSH_CXT.uid_storage = sud->old_uid_storage; { su_uid *map; STRLEN i, alloc; map = sud->tmp_uid_storage.map; alloc = sud->tmp_uid_storage.alloc; for (i = 0; i < alloc; ++i) map[i].flags &= ~SU_UID_ACTIVE; } XSH_CXT.uplevel_storage.top = sud->next; if (XSH_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) { su_uplevel_ud_delete(sud); } else { sud->next = XSH_CXT.uplevel_storage.root; XSH_CXT.uplevel_storage.root = sud; XSH_CXT.uplevel_storage.count++; } } #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; switch (o->op_type) { case OP_LEAVEEVAL: case OP_LEAVETRY: /* Don't care about gotos inside eval, as they are forbidden at run time. */ break; case OP_GOTO: return 1; default: if (su_uplevel_goto_static(((const UNOP *) o)->op_first)) return 1; break; } } return 0; } #if !SU_HAS_NEW_CXT && SU_UPLEVEL_HIJACKS_RUNOPS static int su_uplevel_goto_runops(pTHX) { #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX) register OP *op; dVAR; op = PL_op; do { if (op->op_type == OP_GOTO) { AV *argarray = NULL; I32 cxix; for (cxix = cxstack_ix; cxix >= 0; --cxix) { const PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { case CXt_SUB: if (CxHASARGS(cx)) { argarray = cx->blk_sub.argarray; goto done; } break; case CXt_EVAL: case CXt_FORMAT: goto done; default: break; } } done: if (argarray) { dXSH_CXT; if (XSH_CXT.uplevel_storage.top->cxix == cxix) { AV *args = GvAV(PL_defgv); I32 items = AvFILLp(args); av_extend(argarray, items); Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *); AvFILLp(argarray) = items; } } } PL_op = op = op->op_ppaddr(aTHX); #if !XSH_HAS_PERL(5, 13, 0) PERL_ASYNC_CHECK(); #endif } while (op); TAINT_NOT; return 0; } #endif /* SU_UPLEVEL_HIJACKS_RUNOPS */ #define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] #if SU_HAS_NEW_CXT static void su_uplevel_restore_new(pTHX_ void *sus_) { su_uplevel_ud *sud = sus_; PERL_CONTEXT *cx; I32 i; U8 *saved_cxtypes = sud->cxtypes; for (i = 0; i < sud->gap; i++) { PERL_CONTEXT *cx = cxstack + sud->cxix + i; XSH_D(xsh_debug_log("su_uplevel_restore: i=%d cxix=%d type %s => %s\n", i, cx-cxstack, SU_CX_TYPENAME(CxTYPE(cx)), SU_CX_TYPENAME(saved_cxtypes[i] & CXTYPEMASK))); cx->cx_type = saved_cxtypes[i]; } Safefree(saved_cxtypes); /* renamed is a copy of callback, but they share the same CvPADLIST. * At this point any calls to renamed should have exited so that its * depth is back to that of of callback. At this point its safe to free * renamed, then undo the extra ref count that was ensuring that callback * remains alive */ assert(sud->renamed); assert(sud->callback); CvDEPTH(sud->callback)--; assert(CvDEPTH(sud->callback) == CvDEPTH(sud->renamed)); if (!CvISXSUB(sud->renamed)) { CvDEPTH(sud->renamed) = 0; CvPADLIST(sud->renamed) = NULL; } SvREFCNT_dec(sud->renamed); SvREFCNT_dec(sud->callback); SU_UPLEVEL_RESTORE(curcop); su_uplevel_storage_delete(sud); return; } #else /* 5.23.7 and earlier */ static void su_uplevel_restore_old(pTHX_ void *sus_) { su_uplevel_ud *sud = sus_; PERL_SI *cur = sud->old_curstackinfo; PERL_SI *si = sud->si; #if SU_UPLEVEL_HIJACKS_RUNOPS if (PL_runops == su_uplevel_goto_runops) PL_runops = sud->old_runops; #endif if (sud->callback) { PERL_CONTEXT *cx = cxstack + sud->cxix; AV *argarray = MUTABLE_AV(su_at_underscore(sud->callback)); /* We have to fix the pad entry for @_ in the original callback because it * may have been reified. */ if (AvREAL(argarray)) { const I32 fill = AvFILLp(argarray); SvREFCNT_dec(argarray); argarray = newAV(); AvREAL_off(argarray); AvREIFY_on(argarray); av_extend(argarray, fill); su_at_underscore(sud->callback) = MUTABLE_SV(argarray); } else { CLEAR_ARGARRAY(argarray); } /* If the old cv member is our renamed CV, it means that this place has been * reached without a goto() happening, and the old argarray member is * actually our fake argarray. Destroy it properly in that case. */ if (cx->blk_sub.cv == sud->renamed) { SvREFCNT_dec(cx->blk_sub.argarray); cx->blk_sub.argarray = argarray; } CvDEPTH(sud->callback)--; SvREFCNT_dec(sud->callback); } /* Free the renamed CV. We must do it ourselves so that we can force the * 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) { if (!CvISXSUB(sud->renamed)) { CvDEPTH(sud->renamed) = 0; CvPADLIST(sud->renamed) = NULL; } SvREFCNT_dec(sud->renamed); } CATCH_SET(sud->old_catch); SU_UPLEVEL_RESTORE(op); /* stack_grow() wants PL_curstack so restore the old stack first */ if (PL_curstackinfo == si) { PL_curstack = cur->si_stack; if (sud->old_mainstack) SU_UPLEVEL_RESTORE(mainstack); SU_UPLEVEL_RESTORE(curstackinfo); if (sud->died) { CV *target = sud->target; I32 levels = 0, i; /* When we die, the depth of the target CV is not updated because of the * stack switcheroo. So we have to look at all the frames between the * uplevel call and the catch block to count how many call frames to the * target CV were skipped. */ for (i = cur->si_cxix; i > sud->cxix; i--) { register const PERL_CONTEXT *cx = cxstack + i; if (CxTYPE(cx) == CXt_SUB) { if (cx->blk_sub.cv == target) ++levels; } } /* If we died, the replacement stack was already unwinded to the first * eval frame, and all the contexts down there were popped. We don't have * to pop manually any context of the original stack, because they must * have been in the replacement stack as well (since the second was copied * from the first). Thus we only have to make sure the original stack index * points to the context just below the first eval scope under the target * frame. */ for (; i >= 0; i--) { register const PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { case CXt_SUB: if (cx->blk_sub.cv == target) ++levels; break; case CXt_EVAL: goto found_it; break; default: break; } } found_it: CvDEPTH(target) = sud->target_depth - levels; PL_curstackinfo->si_cxix = i - 1; #if !XSH_HAS_PERL(5, 13, 1) /* Since $@ was maybe localized between the target frame and the uplevel * call, we forcefully flush the save stack to get rid of it and then * reset $@ to its proper value. Note that the the call to * su_uplevel_restore() must happen before the "reset $@" item of the save * stack is processed, as uplevel was called after the localization. * Andrew's changes to how $@ was handled, which were mainly integrated * between perl 5.13.0 and 5.13.1, fixed this. */ if (ERRSV && SvTRUE(ERRSV)) { register const PERL_CONTEXT *cx = cxstack + i; /* This is the eval scope */ SV *errsv = SvREFCNT_inc(ERRSV); PL_scopestack_ix = cx->blk_oldscopesp; leave_scope(PL_scopestack[PL_scopestack_ix]); sv_setsv(ERRSV, errsv); SvREFCNT_dec(errsv); } #endif } } SU_UPLEVEL_RESTORE(curcop); SvREFCNT_dec(sud->target); PL_stack_base = AvARRAY(cur->si_stack); PL_stack_sp = PL_stack_base + AvFILLp(cur->si_stack); PL_stack_max = PL_stack_base + AvMAX(cur->si_stack); /* When an exception is thrown from the uplevel'd subroutine, * su_uplevel_restore() may be called by the LEAVE in die_unwind() (renamed * die_where() in more recent perls), which has the sad habit of keeping a * pointer to the current context frame across this call. This means that we * can't free the temporary context stack we used for the uplevel call right * now, or that pointer upwards would point to garbage. */ #if XSH_HAS_PERL(5, 13, 7) /* This issue has been fixed in perl with commit 8f89e5a9, which was made * public in perl 5.13.7. */ su_uplevel_storage_delete(sud); #else /* Otherwise, we just enqueue it back in the global storage list. */ { dXSH_CXT; sud->tmp_uid_storage = XSH_CXT.uid_storage; XSH_CXT.uid_storage = sud->old_uid_storage; XSH_CXT.uplevel_storage.top = sud->next; sud->next = XSH_CXT.uplevel_storage.root; XSH_CXT.uplevel_storage.root = sud; XSH_CXT.uplevel_storage.count++; } #endif return; } #endif 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; cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); CvFLAGS(cv) = CvFLAGS(proto); #ifdef CVf_CVGV_RC CvFLAGS(cv) &= ~CVf_CVGV_RC; #endif CvDEPTH(cv) = CvDEPTH(proto); #ifdef USE_ITHREADS CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto)); #else CvFILE(cv) = CvFILE(proto); #endif CvGV_set(cv, gv); #if SU_RELEASE && XSH_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 * (which was part of perl 5.13.7). */ #if XSH_HAS_PERL(5, 13, 3) && !XSH_HAS_PERL(5, 13, 7) if (CvSTASH(proto)) Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv)); #endif if (CvISXSUB(proto)) { CvXSUB(cv) = CvXSUB(proto); CvXSUBANY(cv) = CvXSUBANY(proto); } else { OP_REFCNT_LOCK; 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)); #ifdef CvOUTSIDE_SEQ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); #endif if (SvPOK(proto)) sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); #ifdef CvCONST if (CvCONST(cv)) CvCONST_off(cv); #endif return cv; } #if SU_HAS_NEW_CXT /* this one-shot runops "loop" is designed to be called just before * execution of the first op following an uplevel()'s entersub. It gets a * chance to fix up the args as seen by caller(), before immediately * falling through to the previous runops loop. Note that pp_entersub is * called directly by call_sv() rather than being called from a runops * loop. */ static int su_uplevel_runops_hook_entersub(pTHX) { OP *op = PL_op; dXSH_CXT; su_uplevel_ud *sud = XSH_CXT.uplevel_storage.top; /* Create a new array containing a copy of the original sub's call args, * then stick it in PL_curpad[0] of the current running sub so that * thay will be seen by caller(). */ assert(sud); if (sud->argarray) { AV *av = newAV(); AvREAL_off(av); AvREIFY_on(av); av_extend(av, AvMAX(sud->argarray)); AvFILLp(av) = AvFILLp(sud->argarray); Copy(AvARRAY(sud->argarray), AvARRAY(av), AvFILLp(av) + 1, SV *); /* should be referenced by PL_curpad[0] and *_ */ assert(SvREFCNT(PL_curpad[0]) > 1); SvREFCNT_dec(PL_curpad[0]); PL_curpad[0] = (SV *) av; } /* undo the temporary runops hook and fall through to a real runops loop. */ assert(sud->old_runops != su_uplevel_runops_hook_entersub); PL_runops = sud->old_runops; CALLRUNOPS(aTHX); return 0; } static I32 su_uplevel_new(pTHX_ CV *callback, I32 cxix, I32 args) { #define su_uplevel_new(CB, CX, A) su_uplevel_new(aTHX_ (CB), (CX), (A)) su_uplevel_ud *sud; U8 *saved_cxtypes; I32 i, ret; I32 gimme; CV *base_cv = cxstack[cxix].blk_sub.cv; dSP; assert(CxTYPE(&cxstack[cxix]) == CXt_SUB); ENTER; gimme = GIMME_V; /* At this point SP points to the top arg. * Shuffle the args down by one, eliminating the CV slot */ Move(SP - args + 1, SP - args, args, SV *); SP--; PUSHMARK(SP - args); PUTBACK; sud = su_uplevel_storage_new(cxix); sud->cxix = cxix; sud->callback = (CV *) SvREFCNT_inc_simple(callback); sud->renamed = NULL; sud->gap = cxstack_ix - cxix + 1; sud->argarray = NULL; Newx(saved_cxtypes, sud->gap, U8); sud->cxtypes = saved_cxtypes; SAVEDESTRUCTOR_X(su_uplevel_restore_new, sud); SU_UPLEVEL_SAVE(curcop, cxstack[cxix].blk_oldcop); /* temporarily change the type of any contexts to NULL, so they're * invisible to caller() etc. */ for (i = 0; i < sud->gap; i++) { PERL_CONTEXT *cx = cxstack + cxix + i; saved_cxtypes[i] = cx->cx_type; /* save type and flags */ XSH_D(xsh_debug_log("su_uplevel: i=%d cxix=%d type %-11s => %s\n", i, cx-cxstack, SU_CX_TYPENAME(CxTYPE(cx)), SU_CX_TYPENAME(CXt_NULL))); cx->cx_type = (CXt_NULL | CXp_SU_UPLEVEL_NULLED); } /* create a copy of the callback with a doctored name (as seen by * caller). It shares the padlist with callback */ sud->renamed = su_cv_clone(callback, CvGV(base_cv)); sud->old_runops = PL_runops; if (!CvISXSUB(sud->renamed) && CxHASARGS(&cxstack[cxix])) { sud->argarray = (AV *) su_at_underscore(base_cv); assert(PL_runops != su_uplevel_runops_hook_entersub); /* set up a one-shot runops hook so that we can fake up the * args as seen by caller() on return from pp_entersub */ PL_runops = su_uplevel_runops_hook_entersub; } CvDEPTH(callback)++; /* match what CvDEPTH(sud->renamed) is about to become */ ret = call_sv((SV *) sud->renamed, gimme); LEAVE; return ret; } #else static I32 su_uplevel_old(pTHX_ CV *callback, I32 cxix, I32 args) { #define su_uplevel_old(CB, CX, A) su_uplevel_old(aTHX_ (CB), (CX), (A)) su_uplevel_ud *sud; const PERL_CONTEXT *cx = cxstack + cxix; PERL_SI *si; PERL_SI *cur = PL_curstackinfo; SV **old_stack_sp; CV *target; CV *renamed; UNOP sub_op; I32 gimme; I32 old_mark, new_mark; I32 ret; dSP; ENTER; gimme = GIMME_V; /* Make PL_stack_sp point just before the CV. */ PL_stack_sp -= args + 1; old_mark = AvFILLp(PL_curstack) = PL_stack_sp - PL_stack_base; SPAGAIN; sud = su_uplevel_storage_new(cxix); sud->cxix = cxix; sud->died = 1; sud->callback = NULL; sud->renamed = NULL; SAVEDESTRUCTOR_X(su_uplevel_restore_old, sud); si = sud->si; si->si_type = cur->si_type; si->si_next = NULL; si->si_prev = cur->si_prev; #ifdef DEBUGGING si->si_markoff = cx->blk_oldmarksp; #endif /* Allocate enough space for all the elements of the original stack up to the * target context, plus the forthcoming arguments. */ new_mark = cx->blk_oldsp; av_extend(si->si_stack, new_mark + 1 + args + 1); Copy(AvARRAY(PL_curstack), AvARRAY(si->si_stack), new_mark + 1, SV *); AvFILLp(si->si_stack) = new_mark; SU_POISON(AvARRAY(si->si_stack) + new_mark + 1, args + 1, SV *); /* Specialized SWITCHSTACK() */ PL_stack_base = AvARRAY(si->si_stack); old_stack_sp = PL_stack_sp; PL_stack_sp = PL_stack_base + AvFILLp(si->si_stack); PL_stack_max = PL_stack_base + AvMAX(si->si_stack); SPAGAIN; /* Copy the context stack up to the context just below the target. */ si->si_cxix = (cxix < 0) ? -1 : (cxix - 1); if (si->si_cxmax < cxix) { /* The max size must be at least two so that GROW(max) = (max*3)/2 > max */ si->si_cxmax = (cxix < 4) ? 4 : cxix; Renew(si->si_cxstack, si->si_cxmax + 1, PERL_CONTEXT); } Copy(cur->si_cxstack, si->si_cxstack, cxix, PERL_CONTEXT); SU_POISON(si->si_cxstack + cxix, si->si_cxmax + 1 - cxix, PERL_CONTEXT); target = cx->blk_sub.cv; sud->target = (CV *) SvREFCNT_inc(target); sud->target_depth = CvDEPTH(target); /* blk_oldcop is essentially needed for caller() and stack traces. It has no * run-time implication, since PL_curcop will be overwritten as soon as we * enter a sub (a sub starts by a nextstate/dbstate). Hence it's safe to just * make it point to the blk_oldcop for the target frame, so that caller() * reports the right file name, line number and lexical hints. */ SU_UPLEVEL_SAVE(curcop, cx->blk_oldcop); /* Don't reset PL_markstack_ptr, or we would overwrite the mark stack below * this point. Don't reset PL_curpm either, we want the most recent matches. */ SU_UPLEVEL_SAVE(curstackinfo, si); /* If those two are equal, we need to fool POPSTACK_TO() */ if (PL_mainstack == PL_curstack) SU_UPLEVEL_SAVE(mainstack, si->si_stack); else sud->old_mainstack = NULL; PL_curstack = si->si_stack; renamed = su_cv_clone(callback, CvGV(target)); sud->renamed = renamed; PUSHMARK(SP); /* Both SP and old_stack_sp point just before the CV. */ Copy(old_stack_sp + 2, SP + 1, args, SV *); SP += args; PUSHs((SV *) renamed); PUTBACK; Zero(&sub_op, 1, UNOP); sub_op.op_type = OP_ENTERSUB; sub_op.op_next = NULL; sub_op.op_flags = OP_GIMME_REVERSE(gimme) | OPf_STACKED; if (PL_DBsub) sub_op.op_flags |= OPpENTERSUB_DB; SU_UPLEVEL_SAVE(op, (OP *) &sub_op); #if SU_UPLEVEL_HIJACKS_RUNOPS sud->old_runops = PL_runops; #endif sud->old_catch = CATCH_GET; CATCH_SET(TRUE); if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) { PERL_CONTEXT *sub_cx = cxstack + cxstack_ix; AV *argarray = cx->blk_sub.argarray; /* If pp_entersub() returns a non-null OP, it means that the callback is not * an XSUB. */ sud->callback = MUTABLE_CV(SvREFCNT_inc(callback)); CvDEPTH(callback)++; if (CxHASARGS(cx) && argarray) { /* The call to pp_entersub() has saved the current @_ (in XS terms, * GvAV(PL_defgv)) in the savearray member, and has created a new argarray * with what we put on the stack. But we want to fake up the same arguments * as the ones in use at the context we uplevel to, so we replace the * argarray with an unreal copy of the original @_. */ AV *av = newAV(); AvREAL_off(av); AvREIFY_on(av); av_extend(av, AvMAX(argarray)); AvFILLp(av) = AvFILLp(argarray); Copy(AvARRAY(argarray), AvARRAY(av), AvFILLp(av) + 1, SV *); sub_cx->blk_sub.argarray = av; } else { SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray); } if (su_uplevel_goto_static(CvROOT(renamed))) { #if SU_UPLEVEL_HIJACKS_RUNOPS if (PL_runops != PL_runops_std) { if (PL_runops == PL_runops_dbg) { if (PL_debug) croak("uplevel() can't execute code that calls goto when debugging flags are set"); } else if (PL_runops != su_uplevel_goto_runops) croak("uplevel() can't execute code that calls goto with a custom runloop"); } PL_runops = su_uplevel_goto_runops; #else /* SU_UPLEVEL_HIJACKS_RUNOPS */ croak("uplevel() can't execute code that calls goto before perl 5.8"); #endif /* !SU_UPLEVEL_HIJACKS_RUNOPS */ } CALLRUNOPS(aTHX); } sud->died = 0; ret = PL_stack_sp - (PL_stack_base + new_mark); if (ret > 0) { AV *old_stack = sud->old_curstackinfo->si_stack; if (old_mark + ret > AvMAX(old_stack)) { /* Specialized EXTEND(old_sp, ret) */ av_extend(old_stack, old_mark + ret + 1); old_stack_sp = AvARRAY(old_stack) + old_mark; } Copy(PL_stack_sp - ret + 1, old_stack_sp + 1, ret, SV *); PL_stack_sp += ret; AvFILLp(old_stack) += ret; } LEAVE; return ret; } #endif /* --- Unique context ID --------------------------------------------------- */ 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; STRLEN alloc; dXSH_CXT; map = XSH_CXT.uid_storage.map; alloc = XSH_CXT.uid_storage.alloc; if (depth >= alloc) { STRLEN i; Renew(map, depth + 1, su_uid); for (i = alloc; i <= depth; ++i) { map[i].seq = 0; map[i].flags = 0; } XSH_CXT.uid_storage.map = map; XSH_CXT.uid_storage.alloc = depth + 1; } if (depth >= XSH_CXT.uid_storage.used) XSH_CXT.uid_storage.used = depth + 1; return map + depth; } 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; dXSH_CXT; if (depth >= XSH_CXT.uid_storage.used) return 0; uid = XSH_CXT.uid_storage.map + depth; return (uid->seq == seq) && (uid->flags & SU_UID_ACTIVE); } static SV *su_uid_get(pTHX_ I32 cxix) { #define su_uid_get(I) su_uid_get(aTHX_ (I)) su_uid *uid; SV *uid_sv; UV depth; depth = su_uid_depth(cxix); uid = su_uid_storage_fetch(depth); if (!(uid->flags & SU_UID_ACTIVE)) { su_ud_uid *ud; uid->seq = su_uid_seq_next(depth); uid->flags |= SU_UID_ACTIVE; Newx(ud, 1, su_ud_uid); SU_UD_TYPE(ud) = SU_UD_TYPE_UID; ud->idx = depth; su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); } uid_sv = sv_newmortal(); sv_setpvf(uid_sv, "%"UVuf"-%"UVuf, depth, uid->seq); return uid_sv; } #ifdef grok_number #define su_grok_number(S, L, VP) grok_number((S), (L), (VP)) #else /* grok_number */ #define IS_NUMBER_IN_UV 0x1 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; /* This crude check should be good enough for a fallback implementation. * Better be too strict than too lax. */ for (i = 0; i < len; ++i) { if (!isDIGIT(s[i])) return 0; } tmpsv = sv_newmortal(); sv_setpvn(tmpsv, s, len); *valuep = sv_2uv(tmpsv); return IS_NUMBER_IN_UV; } #endif /* !grok_number */ 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; UV depth, seq; int type; s = SvPV_const(uid, len); while (p < len && s[p] != '-') ++p; if (p >= len) croak("UID contains only one part"); type = su_grok_number(s, p, &depth); if (type != IS_NUMBER_IN_UV) croak("First UID part is not an unsigned integer"); ++p; /* Skip '-'. As we used to have p < len, len - (p + 1) >= 0. */ type = su_grok_number(s + p, len - p, &seq); if (type != IS_NUMBER_IN_UV) croak("Second UID part is not an unsigned integer"); return su_uid_storage_check(depth, seq); } /* --- Context operations -------------------------------------------------- */ /* 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) { #define su_context_skip_db(C) su_context_skip_db(aTHX_ (C)) I32 i; if (!PL_DBsub) return cxix; for (i = cxix; i > 0; --i) { PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { #if XSH_HAS_PERL(5, 17, 1) case CXt_LOOP_PLAIN: #endif case CXt_BLOCK: if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv)) continue; break; case CXt_SUB: if (cx->blk_sub.cv == GvCV(PL_DBsub)) { cxix = i - 1; continue; } break; default: break; } break; } return cxix; } #if SU_HAS_NEW_CXT /* convert a physical context stack index into the logical equivalent: * one that ignores all the context frames hidden by uplevel(). * Perl-level functions use logical args (e.g. UP takes an optional logical * value and returns a logical value), while we use and store *real* * values internally. */ static I32 su_context_real2logical(pTHX_ I32 cxix) { # define su_context_real2logical(C) su_context_real2logical(aTHX_ (C)) PERL_CONTEXT *cx; I32 i, gaps = 0; for (i = 0; i <= cxix; i++) { cx = cxstack + i; if (cx->cx_type == (CXt_NULL | CXp_SU_UPLEVEL_NULLED)) gaps++; } XSH_D(xsh_debug_log("su_context_real2logical: %d => %d\n", cxix, cxix - gaps)); return cxix - gaps; } /* convert a logical context stack index (one that ignores all the context * frames hidden by uplevel) into the physical equivalent */ static I32 su_context_logical2real(pTHX_ I32 cxix) { # define su_context_logical2real(C) su_context_logical2real(aTHX_ (C)) PERL_CONTEXT *cx; I32 i, seen = -1; for (i = 0; i <= cxstack_ix; i++) { PERL_CONTEXT *cx = cxstack + i; if (cx->cx_type != (CXt_NULL | CXp_SU_UPLEVEL_NULLED)) seen++; if (seen >= cxix) break; } XSH_D(xsh_debug_log("su_context_logical2real: %d => %d\n", cxix, i)); if (i > cxstack_ix) i = cxstack_ix; return i; } #else # define su_context_real2logical(C) (C) # define su_context_logical2real(C) (C) #endif static I32 su_context_normalize_up(pTHX_ I32 cxix) { #define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C)) PERL_CONTEXT *cx; if (cxix <= 0) return 0; cx = cxstack + cxix; if (CxTYPE(cx) == CXt_BLOCK) { PERL_CONTEXT *prev = cx - 1; switch (CxTYPE(prev)) { #if XSH_HAS_PERL(5, 10, 0) case CXt_GIVEN: case CXt_WHEN: #endif #if XSH_HAS_PERL(5, 11, 0) /* That's the only subcategory that can cause an extra BLOCK context */ case CXt_LOOP_PLAIN: #else case CXt_LOOP: #endif if (cx->blk_oldcop == prev->blk_oldcop) return cxix - 1; break; case CXt_SUBST: if (cx->blk_oldcop && OpSIBLING(cx->blk_oldcop) && OpSIBLING(cx->blk_oldcop)->op_type == OP_SUBST) return cxix - 1; break; } } return 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; if (cxix >= cxstack_ix) return cxstack_ix; next = cxstack + cxix + 1; if (CxTYPE(next) == CXt_BLOCK) { PERL_CONTEXT *cx = next - 1; switch (CxTYPE(cx)) { #if XSH_HAS_PERL(5, 10, 0) case CXt_GIVEN: case CXt_WHEN: #endif #if XSH_HAS_PERL(5, 11, 0) /* That's the only subcategory that can cause an extra BLOCK context */ case CXt_LOOP_PLAIN: #else case CXt_LOOP: #endif if (cx->blk_oldcop == next->blk_oldcop) return cxix + 1; break; case CXt_SUBST: if (next->blk_oldcop && OpSIBLING(next->blk_oldcop) && OpSIBLING(next->blk_oldcop)->op_type == OP_SUBST) return cxix + 1; break; } } return cxix; } #define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix)) static I32 su_context_gimme(pTHX_ I32 cxix) { #define su_context_gimme(C) su_context_gimme(aTHX_ (C)) I32 i; for (i = cxix; i >= 0; --i) { PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { /* gimme is always G_ARRAY for loop contexts. */ #if XSH_HAS_PERL(5, 11, 0) # if XSH_HAS_PERL(5, 23, 8) case CXt_LOOP_ARY: case CXt_LOOP_LIST: # else case CXt_LOOP_FOR: # endif case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYSV: case CXt_LOOP_LAZYIV: #else case CXt_LOOP: #endif case CXt_SUBST: { const COP *cop = cx->blk_oldcop; if (cop && OpSIBLING(cop)) { switch (OpSIBLING(cop)->op_flags & OPf_WANT) { case OPf_WANT_VOID: return G_VOID; case OPf_WANT_SCALAR: return G_SCALAR; case OPf_WANT_LIST: return G_ARRAY; default: break; } } break; } default: return CxGIMME(cx); break; } } return G_VOID; } /* --- Module setup/teardown ----------------------------------------------- */ static void xsh_user_global_setup(pTHX) { HV *stash; MUTEX_INIT(&su_uid_seq_counter_mutex); XSH_LOCK(&su_uid_seq_counter_mutex); su_uid_seq_counter.seqs = NULL; su_uid_seq_counter.size = 0; XSH_UNLOCK(&su_uid_seq_counter_mutex); stash = gv_stashpv(XSH_PACKAGE, 1); newCONSTSUB(stash, "TOP", newSViv(0)); newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(XSH_THREADSAFE)); return; } static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { /* NewOp() calls calloc() which just zeroes the memory with memset(). */ Zero(&(cxt->unwind_storage.return_op), 1, LISTOP); cxt->unwind_storage.return_op.op_type = OP_RETURN; cxt->unwind_storage.return_op.op_ppaddr = PL_ppaddr[OP_RETURN]; Zero(&(cxt->unwind_storage.proxy_op), 1, OP); cxt->unwind_storage.proxy_op.op_type = OP_STUB; cxt->unwind_storage.proxy_op.op_ppaddr = NULL; Zero(&(cxt->yield_storage.leave_op), 1, UNOP); cxt->yield_storage.leave_op.op_type = OP_STUB; cxt->yield_storage.leave_op.op_ppaddr = NULL; Zero(&(cxt->yield_storage.proxy_op), 1, OP); cxt->yield_storage.proxy_op.op_type = OP_STUB; cxt->yield_storage.proxy_op.op_ppaddr = NULL; cxt->uplevel_storage.top = NULL; cxt->uplevel_storage.root = NULL; cxt->uplevel_storage.count = 0; cxt->uid_storage.map = NULL; cxt->uid_storage.used = 0; cxt->uid_storage.alloc = 0; return; } static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { su_uplevel_ud *cur; Safefree(cxt->uid_storage.map); cur = cxt->uplevel_storage.root; if (cur) { su_uplevel_ud *prev; do { prev = cur; cur = prev->next; su_uplevel_ud_delete(prev); } while (cur); } return; } static void xsh_user_global_teardown(pTHX) { XSH_LOCK(&su_uid_seq_counter_mutex); PerlMemShared_free(su_uid_seq_counter.seqs); su_uid_seq_counter.size = 0; XSH_UNLOCK(&su_uid_seq_counter_mutex); MUTEX_DESTROY(&su_uid_seq_counter_mutex); return; } /* --- XS ------------------------------------------------------------------ */ /* D is real; B is logical. Returns real. */ #define SU_GET_CONTEXT(A, B, D) \ STMT_START { \ if (items > A) { \ SV *csv = ST(B); \ if (!SvOK(csv)) \ goto default_cx; \ cxix = SvIV(csv); \ if (cxix < 0) \ cxix = 0; \ else if (cxix > cxstack_ix) \ goto default_cx; \ cxix = su_context_logical2real(cxix); \ } else { \ default_cx: \ cxix = (D); \ } \ } STMT_END #define SU_GET_LEVEL(A, B) \ STMT_START { \ level = 0; \ if (items > 0) { \ SV *lsv = ST(B); \ if (SvOK(lsv)) { \ level = SvIV(lsv); \ if (level < 0) \ level = 0; \ } \ } \ } STMT_END #if XSH_HAS_PERL(5, 10, 0) # define SU_INFO_COUNT 11 #else # define SU_INFO_COUNT 10 #endif XS(XS_Scope__Upper_unwind) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif dXSH_CXT; I32 cxix; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ SU_GET_CONTEXT(0, items - 1, cxstack_ix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { case CXt_SUB: if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) continue; case CXt_EVAL: case CXt_FORMAT: XSH_CXT.unwind_storage.cxix = cxix; XSH_CXT.unwind_storage.items = items; XSH_CXT.unwind_storage.savesp = PL_stack_sp; if (items > 0) { XSH_CXT.unwind_storage.items--; XSH_CXT.unwind_storage.savesp--; } /* pp_entersub will want to sanitize the stack after returning from there * Screw that, we're insane! * dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */ if (GIMME_V == G_SCALAR) PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; SAVEDESTRUCTOR_X(su_unwind, NULL); return; default: break; } } while (--cxix >= 0); croak("Can't return outside a subroutine"); } static const char su_yield_name[] = "yield"; XS(XS_Scope__Upper_yield) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif dXSH_CXT; I32 cxix; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ SU_GET_CONTEXT(0, items - 1, su_context_here()); XSH_CXT.yield_storage.cxix = cxix; XSH_CXT.yield_storage.items = items; XSH_CXT.yield_storage.savesp = PL_stack_sp; if (items > 0) { XSH_CXT.yield_storage.items--; XSH_CXT.yield_storage.savesp--; } /* See XS_Scope__Upper_unwind */ if (GIMME_V == G_SCALAR) PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; SAVEDESTRUCTOR_X(su_yield, su_yield_name); return; } static const char su_leave_name[] = "leave"; XS(XS_Scope__Upper_leave) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif dXSH_CXT; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ XSH_CXT.yield_storage.cxix = su_context_here(); XSH_CXT.yield_storage.items = items; XSH_CXT.yield_storage.savesp = PL_stack_sp; /* See XS_Scope__Upper_unwind */ if (GIMME_V == G_SCALAR) PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1; SAVEDESTRUCTOR_X(su_yield, su_leave_name); return; } MODULE = Scope::Upper PACKAGE = Scope::Upper PROTOTYPES: ENABLE BOOT: { xsh_setup(); 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 XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PPCODE: xsh_clone(); XSRETURN(0); #endif /* XSH_THREADSAFE */ void HERE() PROTOTYPE: PREINIT: I32 cxix; PPCODE: cxix = su_context_real2logical(su_context_here()); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); void UP(...) PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0, su_context_here()); if (cxix > 0) { --cxix; cxix = su_context_skip_db(cxix); cxix = su_context_normalize_up(cxix); cxix = su_context_real2logical(cxix); } else { warn(su_stack_smash); } EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); void SUB(...) PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0, cxstack_ix); EXTEND(SP, 1); for (; cxix >= 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { default: continue; case CXt_SUB: if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) continue; cxix = su_context_real2logical(cxix); mPUSHi(cxix); XSRETURN(1); } } warn(su_no_such_target, "subroutine"); XSRETURN_UNDEF; void EVAL(...) PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0, cxstack_ix); EXTEND(SP, 1); for (; cxix >= 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: cxix = su_context_real2logical(cxix); mPUSHi(cxix); XSRETURN(1); } } warn(su_no_such_target, "eval"); XSRETURN_UNDEF; void SCOPE(...) PROTOTYPE: ;$ PREINIT: I32 cxix, level; PPCODE: SU_GET_LEVEL(0, 0); cxix = su_context_here(); while (--level >= 0) { if (cxix <= 0) { warn(su_stack_smash); break; } --cxix; cxix = su_context_skip_db(cxix); cxix = su_context_normalize_up(cxix); cxix = su_context_real2logical(cxix); } EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); void CALLER(...) PROTOTYPE: ;$ PREINIT: I32 cxix, level; PPCODE: SU_GET_LEVEL(0, 0); for (cxix = cxstack_ix; cxix > 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { case CXt_SUB: if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) continue; case CXt_EVAL: case CXt_FORMAT: if (--level < 0) goto done; break; } } done: if (level >= 0) warn(su_stack_smash); EXTEND(SP, 1); cxix = su_context_real2logical(cxix); mPUSHi(cxix); XSRETURN(1); void want_at(...) PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0, cxstack_ix); EXTEND(SP, 1); while (cxix > 0) { PERL_CONTEXT *cx = cxstack + cxix--; switch (CxTYPE(cx)) { case CXt_SUB: if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) continue; case CXt_EVAL: case CXt_FORMAT: { I32 gimme = cx->blk_gimme; switch (gimme) { case G_VOID: XSRETURN_UNDEF; break; case G_SCALAR: XSRETURN_NO; break; case G_ARRAY: XSRETURN_YES; break; } break; } } } XSRETURN_UNDEF; void context_info(...) PROTOTYPE: ;$ PREINIT: I32 cxix; const PERL_CONTEXT *cx, *dbcx; COP *cop; PPCODE: SU_GET_CONTEXT(0, 0, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_up(cxix); cx = cxstack + cxix; dbcx = cx; if (PL_DBsub && cxix && (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)) { I32 i = su_context_skip_db(cxix - 1) + 1; if (i < cxix && CxTYPE(cxstack + i) == CXt_SUB) cx = cxstack + i; } cop = cx->blk_oldcop; EXTEND(SP, SU_INFO_COUNT); /* stash (0) */ { HV *stash = CopSTASH(cop); if (stash) PUSHs(su_newmortal_pvn(HvNAME(stash), HvNAMELEN(stash))); else PUSHs(&PL_sv_undef); } /* file (1) */ PUSHs(su_newmortal_pvn(OutCopFILE(cop), OutCopFILE_len(cop))); /* line (2) */ mPUSHi(CopLINE(cop)); /* subroutine (3) and has_args (4) */ switch (CxTYPE(cx)) { case CXt_SUB: case CXt_FORMAT: { GV *cvgv = CvGV(dbcx->blk_sub.cv); if (cvgv && isGV(cvgv)) { SV *sv = sv_newmortal(); gv_efullname3(sv, cvgv, NULL); PUSHs(sv); } else { PUSHs(su_newmortal_pvs("(unknown)")); } if (CxHASARGS(cx)) PUSHs(&PL_sv_yes); else PUSHs(&PL_sv_no); break; } case CXt_EVAL: PUSHs(su_newmortal_pvs("(eval)")); mPUSHi(0); break; default: PUSHs(&PL_sv_undef); PUSHs(&PL_sv_undef); } /* gimme (5) */ switch (su_context_gimme(cxix)) { case G_ARRAY: PUSHs(&PL_sv_yes); break; case G_SCALAR: PUSHs(&PL_sv_no); break; default: /* G_VOID */ PUSHs(&PL_sv_undef); break; } /* eval text (6) and is_require (7) */ switch (CxTYPE(cx)) { case CXt_EVAL: if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { /* eval STRING */ #if XSH_HAS_PERL(5, 17, 4) PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), SvCUR(cx->blk_eval.cur_text)-2, SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); #else PUSHs(cx->blk_eval.cur_text); #endif PUSHs(&PL_sv_no); break; } else if (cx->blk_eval.old_namesv) { /* require */ PUSHs(sv_mortalcopy(cx->blk_eval.old_namesv)); PUSHs(&PL_sv_yes); break; } /* FALLTHROUGH */ default: /* Anything else including eval BLOCK */ PUSHs(&PL_sv_undef); PUSHs(&PL_sv_undef); break; } /* hints (8) */ mPUSHi(CopHINTS_get(cop)); /* warnings (9) */ { SV *mask = NULL; #if XSH_HAS_PERL(5, 9, 4) STRLEN *old_warnings = cop->cop_warnings; #else SV *old_warnings = cop->cop_warnings; #endif if (old_warnings == pWARN_STD) { if (PL_dowarn & G_WARN_ON) goto context_info_warnings_on; else #if XSH_HAS_PERL(5, 17, 4) mask = &PL_sv_undef; #else goto context_info_warnings_off; #endif } else if (old_warnings == pWARN_NONE) { #if !XSH_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; context_info_warnings_on: #if XSH_HAS_PERL(5, 8, 7) bits = get_hv("warnings::Bits", 0); if (bits) { SV **bits_all = hv_fetchs(bits, "all", FALSE); if (bits_all) mask = sv_mortalcopy(*bits_all); } #endif if (!mask) mask = su_newmortal_pvn(WARN_ALLstring, WARNsize); } else { #if XSH_HAS_PERL(5, 9, 4) mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]); #else mask = sv_mortalcopy(old_warnings); #endif } PUSHs(mask); } #if XSH_HAS_PERL(5, 10, 0) /* hints hash (10) */ { COPHH *hints_hash = CopHINTHASH_get(cop); if (hints_hash) { SV *rhv = sv_2mortal(newRV_noinc((SV *) cophh_2hv(hints_hash, 0))); PUSHs(rhv); } else { PUSHs(&PL_sv_undef); } } #endif XSRETURN(SU_INFO_COUNT); void reap(SV *hook, ...) PROTOTYPE: &;$ PREINIT: I32 cxix; su_ud_reap *ud; CODE: SU_GET_CONTEXT(1, 1, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_reap); SU_UD_TYPE(ud) = SU_UD_TYPE_REAP; ud->cb = (SvROK(hook) && SvTYPE(SvRV(hook)) >= SVt_PVCV) ? SvRV(hook) : hook; SvREFCNT_inc_simple_void(ud->cb); su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE); void localize(SV *sv, SV *val, ...) PROTOTYPE: $$;$ PREINIT: I32 cxix; I32 size; su_ud_localize *ud; CODE: SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE; size = su_ud_localize_init(ud, sv, val, NULL); su_init(ud, cxix, size); void localize_elem(SV *sv, SV *elem, SV *val, ...) PROTOTYPE: $$$;$ PREINIT: I32 cxix; I32 size; su_ud_localize *ud; CODE: if (SvTYPE(sv) >= SVt_PVGV) croak("Can't infer the element localization type from a glob and the value"); SU_GET_CONTEXT(3, 3, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); /* Initialize SU_UD_ORIGIN(ud) in case SU_UD_LOCALIZE_FREE(ud) needs it */ SU_UD_ORIGIN(ud) = NULL; SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE; size = su_ud_localize_init(ud, sv, val, elem); if (SU_UD_PRIVATE(ud) != SVt_PVAV && SU_UD_PRIVATE(ud) != SVt_PVHV) { SU_UD_LOCALIZE_FREE(ud); croak("Can't localize an element of something that isn't an array or a hash"); } su_init(ud, cxix, size); void localize_delete(SV *sv, SV *elem, ...) PROTOTYPE: $$;$ PREINIT: I32 cxix; I32 size; su_ud_localize *ud; CODE: SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix)); cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); SU_UD_TYPE(ud) = SU_UD_TYPE_LOCALIZE; size = su_ud_localize_init(ud, sv, NULL, elem); su_init(ud, cxix, size); void uplevel(SV *code, ...) PROTOTYPE: &@ PREINIT: I32 cxix, ret, args = 0; PPCODE: if (SvROK(code)) code = SvRV(code); if (SvTYPE(code) < SVt_PVCV) croak("First argument to uplevel must be a code reference"); SU_GET_CONTEXT(1, items - 1, cxstack_ix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { case CXt_EVAL: croak("Can't uplevel to an eval frame"); case CXt_FORMAT: croak("Can't uplevel to a format frame"); case CXt_SUB: if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) continue; if (items > 1) { PL_stack_sp--; args = items - 2; } /* su_uplevel() takes care of extending the stack if needed. */ #if SU_HAS_NEW_CXT ret = su_uplevel_new((CV *) code, cxix, args); #else ret = su_uplevel_old((CV *) code, cxix, args); #endif XSRETURN(ret); default: break; } } while (--cxix >= 0); croak("Can't uplevel outside a subroutine"); void uid(...) PROTOTYPE: ;$ PREINIT: I32 cxix; SV *uid; PPCODE: SU_GET_CONTEXT(0, 0, su_context_here()); uid = su_uid_get(cxix); EXTEND(SP, 1); PUSHs(uid); XSRETURN(1); void validate_uid(SV *uid) PROTOTYPE: $ PREINIT: SV *ret; PPCODE: ret = su_uid_validate(uid) ? &PL_sv_yes : &PL_sv_no; EXTEND(SP, 1); PUSHs(ret); XSRETURN(1); Scope-Upper-0.29/xsh/000755 000765 000024 00000000000 12725253617 015233 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/xsh/caps.h000644 000765 000024 00000002630 12616400775 016331 0ustar00vincentstaff000000 000000 #ifndef XSH_CAPS_H #define XSH_CAPS_H 1 #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 */ Scope-Upper-0.29/xsh/debug.h000644 000765 000024 00000000733 12725240601 016462 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 */ Scope-Upper-0.29/xsh/threads.h000644 000765 000024 00000025054 12723034216 017032 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 */ #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; PerlMemShared_free(tok); 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; tok = PerlMemShared_malloc(sizeof *tok); 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 */ Scope-Upper-0.29/xsh/util.h000644 000765 000024 00000004227 12725240530 016354 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 #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #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))) /* 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 #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 */ Scope-Upper-0.29/t/00-load.t000644 000765 000024 00000000255 12500306324 016200 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'Scope::Upper' ); } diag( "Testing Scope::Upper $Scope::Upper::VERSION, Perl $], $^X" ); Scope-Upper-0.29/t/01-import.t000644 000765 000024 00000001415 12500306324 016573 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 2 * 20; require Scope::Upper; my %syms = ( reap => '&;$', localize => '$$;$', localize_elem => '$$$;$', localize_delete => '$$;$', unwind => undef, yield => undef, leave => undef, want_at => ';$', context_info => ';$', uplevel => '&@', uid => ';$', validate_uid => '$', TOP => '', HERE => '', UP => ';$', SUB => ';$', EVAL => ';$', SCOPE => ';$', CALLER => ';$', SU_THREADSAFE => '', ); for (keys %syms) { eval { Scope::Upper->import($_) }; is $@, '', "import $_"; is prototype($_), $syms{$_}, "prototype $_"; } Scope-Upper-0.29/t/05-words.t000644 000765 000024 00000041212 12557756345 016452 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; plan tests => 23 * ($^P ? 4 : 5) + 40 + ($^P ? 1 : 3) + 7 + (32 + 7) + 1; use Scope::Upper qw<:words>; # Tests with hardcoded values are for internal use only and doesn't imply any # kind of future compatibility on what the words should actually return. my $stray_warnings = 0; local $SIG{__WARN__} = sub { ++$stray_warnings; warn(@_); }; our @warns; my $warn_catcher = sub { my $what; if ($_[0] =~ /^Cannot target a scope outside of the current stack at /) { $what = 'smash'; } elsif ($_[0] =~ /^No targetable (subroutine|eval) scope in the current stack at /) { $what = $1; } if (defined $what) { push @warns, $what; } else { warn(@_); } return; }; my $old_sig_warn; my $top = HERE; is $top, 0, 'main : here' unless $^P; is TOP, $top, 'main : top'; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is UP, $top, 'main : up'; is "@warns", 'smash', 'main : up warns'; local @warns; is SUB, undef, 'main : sub'; is "@warns", 'subroutine', 'main : sub warns'; local @warns; is EVAL, undef, 'main : eval'; is "@warns", 'eval', 'main : eval warns'; local $SIG{__WARN__} = $old_sig_warn; { my $desc = '{ 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } do { my $desc = 'do { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; }; eval { my $desc = 'eval { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local $SIG{__WARN__} = $old_sig_warn; is EVAL, HERE, "$desc : eval"; }; diag $@ if $@; eval q[ my $desc = 'eval "1"'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local $SIG{__WARN__} = $old_sig_warn; is EVAL, HERE, "$desc : eval"; ]; diag $@ if $@; sub { my $desc = 'sub { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; is SUB, HERE, "$desc : sub"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; }->(); my $true = 1; my $false = !$true; if ($true) { my $desc = 'if () { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } unless ($false) { my $desc = 'unless () { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } if ($false) { fail "false was true : $_" for 1 .. 5; } else { my $desc = 'if () { } else { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } for (1) { my $desc = 'for (list) { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } for (1 .. 1) { my $desc = 'for (num range) { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } for (1 .. 1) { my $desc = 'for (pv range) { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } for (my $i = 0; $i < 1; ++$i) { my $desc = 'for (;;) { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } my $flag = 1; while ($flag) { $flag = 0; my $desc = 'while () { 1 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } my @list = (1); while (my $thing = shift @list) { my $desc = 'while (my $thing = ...) { 2 }'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } do { my $desc = 'do { 1 } while (0)'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } while (0); map { my $desc = 'map { 1 } 1'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } 1; grep { my $desc = 'grep { 1 } 1'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; } 1; my $var = 'a'; $var =~ s[.][ my $desc = 'subst'; is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local @warns; is EVAL, undef, "$desc : eval"; is "@warns", 'eval', "$desc : eval warns"; local $SIG{__WARN__} = $old_sig_warn; ]e; $var = 'a'; $var =~ s{.}{UP}e; is $var, $top, 'subst : fake block'; $var = 'a'; $var =~ s{.}{do { UP }}e; is $var, 1, 'subst : do block optimized away' unless $^P; $var = 'a'; $var =~ s{.}{do { my $x; UP }}e; is $var, 1, 'subst : do block preserved' unless $^P; SKIP: { skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) + 4 if "$]" < 5.010; eval <<'TEST_GIVEN'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; my $desc = 'given'; my $base = HERE; given (1) { is HERE, $base + 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $base, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local $SIG{__WARN__} = $old_sig_warn; is EVAL, $base, "$desc : eval"; } TEST_GIVEN diag $@ if $@; eval <<'TEST_GIVEN_WHEN'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; my $desc = 'when in given'; my $base = HERE; given (1) { my $given = HERE; when (1) { is HERE, $base + 3, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $given, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local $SIG{__WARN__} = $old_sig_warn; is EVAL, $base, "$desc : eval"; } } TEST_GIVEN_WHEN diag $@ if $@; eval <<'TEST_GIVEN_DEFAULT'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; my $desc = 'default in given'; my $base = HERE; given (1) { my $given = HERE; default { is HERE, $base + 3, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $given, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local $SIG{__WARN__} = $old_sig_warn; is EVAL, $base, "$desc : eval"; } } TEST_GIVEN_DEFAULT diag $@ if $@; eval <<'TEST_FOR_WHEN'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; my $desc = 'when in for'; my $base = HERE; for (1) { my $loop = HERE; when (1) { is HERE, $base + 2, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $loop, "$desc : up"; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SUB, undef, "$desc : sub"; is "@warns", 'subroutine', "$desc : sub warns"; local $SIG{__WARN__} = $old_sig_warn; is EVAL, $base, "$desc : eval"; } } TEST_FOR_WHEN diag $@ if $@; } SKIP: { skip 'Hardcoded values are wrong under the debugger' => 7 if $^P; my $base = HERE; do { eval { do { sub { eval q[ { is HERE, $base + 6, 'mixed : here'; is TOP, $top, 'mixed : top'; is SUB, $base + 4, 'mixed : first sub'; is SUB(SUB), $base + 4, 'mixed : still first sub'; is EVAL, $base + 5, 'mixed : first eval'; is EVAL(EVAL), $base + 5, 'mixed : still first eval'; is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval'; } ]; }->(); } }; } while (0); } { my $block = HERE; is SCOPE, $block, 'block : scope'; is SCOPE(0), $block, 'block : scope 0'; is SCOPE(1), $top, 'block : scope 1'; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is SCOPE(2), $top, 'block : scope 2'; is "@warns", 'smash', 'block : scope 2 warns'; local @warns; is CALLER, $top, 'block : caller'; is "@warns", 'smash', 'block : caller warns'; local @warns; is CALLER(0), $top, 'block : caller 0'; is "@warns", 'smash', 'block : caller 0 warns'; local @warns; is CALLER(1), $top, 'block : caller 1'; is "@warns", 'smash', 'block : caller 1 warns'; local $SIG{__WARN__} = $old_sig_warn; sub { my $sub = HERE; is SCOPE, $sub, 'block sub : scope'; is SCOPE(0), $sub, 'block sub : scope 0'; is SCOPE(1), $block, 'block sub : scope 1'; is SCOPE(2), $top, 'block sub : scope 2'; is CALLER, $sub, 'block sub : caller'; is CALLER(0), $sub, 'block sub : caller 0'; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is CALLER(1), $top, 'block sub : caller 1'; is "@warns", 'smash', 'block sub : caller 1 warns'; local $SIG{__WARN__} = $old_sig_warn; for (1) { my $loop = HERE; is SCOPE, $loop, 'block sub for : scope'; is SCOPE(0), $loop, 'block sub for : scope 0'; is SCOPE(1), $sub, 'block sub for : scope 1'; is SCOPE(2), $block, 'block sub for : scope 2'; is SCOPE(3), $top, 'block sub for : scope 3'; is CALLER, $sub, 'block sub for : caller'; is CALLER(0), $sub, 'block sub for : caller 0'; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is CALLER(1), $top, 'block sub for : caller 1'; is "@warns", 'smash', 'block sub for : caller 1 warns'; local $SIG{__WARN__} = $old_sig_warn; eval { my $eval = HERE; is SCOPE, $eval, 'block sub for eval : scope'; is SCOPE(0), $eval, 'block sub for eval : scope 0'; is SCOPE(1), $loop, 'block sub for eval : scope 1'; is SCOPE(2), $sub, 'block sub for eval : scope 2'; is SCOPE(3), $block, 'block sub for eval : scope 3'; is SCOPE(4), $top, 'block sub for eval : scope 4'; is CALLER, $eval, 'block sub for eval : caller'; is CALLER(0), $eval, 'block sub for eval : caller 0'; is CALLER(1), $sub, 'block sub for eval : caller 1'; $old_sig_warn = $SIG{__WARN__}; local ($SIG{__WARN__}, @warns) = $warn_catcher; is CALLER(2), $top, 'block sub for eval : caller 2'; is "@warns", 'smash', 'block sub for eval : caller 2 warns'; local $SIG{__WARN__} = $old_sig_warn; } } }->(); } is $stray_warnings, 0, 'no stray warnings'; Scope-Upper-0.29/t/06-want_at.t000644 000765 000024 00000002443 12557701414 016740 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 18; use Scope::Upper qw; sub check { my ($w, $exp, $desc) = @_; my $cx = sub { my $a = shift; if (!defined $a) { return 'void'; } elsif ($a) { return 'list'; } else { return 'scalar'; } }; is $cx->($w), $cx->($exp), $desc; } my $w; check want_at, undef, 'main : want_at'; check want_at(HERE), undef, 'main : want_at HERE'; check want_at(-1), undef, 'main : want_at -1'; my @a = sub { check want_at, 1, 'sub0 : want_at'; { check want_at, 1, 'sub : want_at'; check want_at(UP), 1, 'sub : want_at UP'; for (1) { check want_at, 1, 'for : want_at'; check want_at(UP), 1, 'for : want_at UP'; check want_at(UP UP), 1, 'for : want_at UP UP'; } eval " check want_at, undef, 'eval string : want_at'; check want_at(UP), 1, 'eval string : want_at UP'; check want_at(UP UP), 1, 'eval string : want_at UP UP'; "; my $x = eval { do { check want_at, 0, 'do : want_at'; check want_at(UP), 0, 'do : want_at UP'; check want_at(UP UP), 1, 'do : want_at UP UP'; }; check want_at, 0, 'eval : want_at'; check want_at(UP), 1, 'eval : want_at UP'; check want_at(UP UP), 1, 'eval : want_at UP UP'; }; } }->(); Scope-Upper-0.29/t/07-context_info.t000644 000765 000024 00000010111 12557701433 017773 0ustar00vincentstaff000000 000000 #!perl -T my $exp0 = ::expected('block', 0, undef); use strict; use warnings; use Config qw<%Config>; # We're using Test::Leaner here because Test::More loads overload, which itself # uses warning::register, which may cause the "all warnings on" bitmask to # change ; and that doesn't fit well with how we're testing things. use lib 't/lib'; use Test::Leaner tests => 18 + 6; use Scope::Upper qw; sub HINT_BLOCK_SCOPE () { 0x100 } sub expected { my ($type, $line, $want) = @_; my $top; my @caller = caller 1; my @here = caller 0; unless (@caller) { @caller = @here; $top++; } my $pkg = $here[0]; my ($file, $eval, $require, $hints, $warnings, $hinthash) = @caller[1, 6, 7, 8, 9, 10]; $line = $caller[2] unless defined $line; my ($sub, $hasargs); if ($type eq 'sub' or $type eq 'eval' or $type eq 'format') { $sub = $caller[3]; $hasargs = $caller[4]; $want = $caller[5]; $want = '' if defined $want and not $want; } if ($top) { $want = "$]" < 5.015_001 ? '' : undef; $hints &= ~HINT_BLOCK_SCOPE if $Config{usesitecustomize}; $hints |= HINT_BLOCK_SCOPE if "$]" >= 5.019003; $warnings = sub { use warnings; (caller 0)[9] }->() if "$]" < 5.007 and not $^W; } my @exp = ( $pkg, $file, $line, $sub, $hasargs, $want, $eval, $require, $hints, $warnings, ); push @exp, $hinthash if "$]" >= 5.010; return \@exp; } sub setup () { my $pkg = caller; for my $sub (qw) { no strict 'refs'; *{"${pkg}::$sub"} = \&{"main::$sub"}; } } is_deeply [ context_info ], $exp0, 'main : context_info'; is_deeply [ context_info(HERE) ], $exp0, 'main : context_info HERE'; is_deeply [ context_info(-1) ], $exp0, 'main : context_info -1'; package Scope::Upper::TestPkg::A; BEGIN { ::setup } my @a = sub { my $exp1 = expected('sub', undef); is_deeply [ context_info ], $exp1, 'sub0 : context_info'; package Scope::Upper::TestPkg::B; BEGIN { ::setup } { my $exp2 = expected('block', __LINE__, 1); is_deeply [ context_info ], $exp2, 'sub : context_info'; is_deeply [ context_info(UP) ], $exp1, 'sub : context_info UP'; package Scope::Upper::TestPkg::C; BEGIN { ::setup } for (1) { my $exp3 = expected('loop', __LINE__ - 1, undef); is_deeply [ context_info ], $exp3, 'for : context_info'; is_deeply [ context_info(UP) ], $exp2, 'for : context_info UP'; is_deeply [ context_info(UP UP) ], $exp1, 'for : context_info UP UP'; } package Scope::Upper::TestPkg::D; BEGIN { ::setup } my $eval_line = __LINE__+1; eval <<'CODE'; my $exp4 = expected('eval', $eval_line); is_deeply [ context_info ], $exp4, 'eval string : context_info'; is_deeply [ context_info(UP) ], $exp2, 'eval string : context_info UP'; is_deeply [ context_info(UP UP) ], $exp1, 'eval string : context_info UP UP'; CODE die $@ if $@; package Scope::Upper::TestPkg::E; BEGIN { ::setup } my $x = eval { my $exp5 = expected('eval', __LINE__ - 1); package Scope::Upper::TestPkg::F; BEGIN { ::setup } do { my $exp6 = expected('block', __LINE__ - 1, undef); is_deeply [ context_info ], $exp6, 'do : context_info'; is_deeply [ context_info(UP) ], $exp5, 'do : context_info UP'; is_deeply [ context_info(UP UP) ], $exp2, 'do : context_info UP UP'; }; is_deeply [ context_info ], $exp5, 'eval : context_info'; is_deeply [ context_info(UP) ], $exp2, 'eval : context_info UP'; is_deeply [ context_info(UP UP) ], $exp1, 'eval : context_info UP UP'; }; } }->(1); package main; sub first { do { second(@_); } } my $fourth; sub second { my $x = eval { my @y = $fourth->(); }; die $@ if $@; } $fourth = sub { my $z = do { my $dummy; eval q[ call(@_); ]; die $@ if $@; } }; sub call { for my $depth (0 .. 5) { my @got = context_info(CALLER $depth); my @exp = caller $depth; defined and not $_ and $_ = '' for $exp[5]; is_deeply \@got, \@exp, "context_info vs caller $depth"; } } first(); Scope-Upper-0.29/t/09-load-threads.t000644 000765 000024 00000016773 12557756555 017710 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; 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 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(); Scope-Upper-0.29/t/11-reap-level.t000644 000765 000024 00000001474 12554504437 017341 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "reap \\&check => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = $i < $height - $level ? 1 : 'undef'; return "verbose_is(\$main::y, $j, 'y h=$height, l=$level, i=$i');\n"; }; our ($x, $y, $testcase); sub check { $y = 0 unless defined $y; ++$y } for my $level (0 .. 2) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = $y = undef; eval $testcase; diag $@ if $@; } } } Scope-Upper-0.29/t/12-reap-block.t000644 000765 000024 00000002115 12500306324 017300 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "reap \\&check => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i, $x) = @_; my $j = $i < $height - $level ? 0 : (defined $x ? $x : 'undef'); return "verbose_is(\$x, $j, 'x h=$height, l=$level, i=$i');\n"; }; local $Scope::Upper::TestGenerator::local_decl = sub { my ($height, $level, $i, $x) = @_; return $i == $height - $level ? "\$x = $x;\n" : "local \$x = $x;\n"; }; local $Scope::Upper::TestGenerator::local_test = sub { '' }; local $Scope::Upper::TestGenerator::allblocks = 1; our ($x, $testcase); sub check { $x = (defined $x) ? ($x ? 0 : $x . 'x') : 0 } for my $level (0 .. 1) { my $height = $level + 1; my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = undef; eval $testcase; diag $@ if $@; } } Scope-Upper-0.29/t/13-reap-ctl.t000644 000765 000024 00000020605 12725240530 017002 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 41 + 30 + 4 * 7; use Scope::Upper qw; our ($x, $y); sub check { ++$y } { local $x = 1; { local $x = 2; { reap \&check => UP; } is $x, 2, 'goto 1 [not yet - x]'; is $y, undef, 'goto 1 [not yet - y]'; { local $x = 3; goto OVER1; } } $y = 0; OVER1: is $x, 1, 'goto 1 [ok - x]'; is $y, 1, 'goto 1 [ok - y]'; } $y = undef; { local $x = 1; { local $x = 2; { local $x = 3; { reap \&check => UP UP; } is $x, 3, 'goto 2 [not yet - x]'; is $y, undef, 'goto 2 [not yet - y]'; { local $x = 4; goto OVER2; } } } $y = 0; OVER2: is $x, 1, 'goto 2 [ok - x]'; is $y, 1, 'goto 2 [ok - y]'; } $y = undef; { local $x = 1; { eval { local $x = 2; { { local $x = 3; reap \&check => UP UP UP; is $x, 3, 'die - reap outside eval [not yet 1 - x]'; is $y, undef, 'die - reap outside eval [not yet 1 - y]'; } is $x, 2, 'die - reap outside eval [not yet 2 - x]'; is $y, undef, 'die - reap outside eval [not yet 2 - y]'; die; } }; is $x, 1, 'die - reap outside eval [not yet 3 - x]'; is $y, undef, 'die - reap outside eval [not yet 3 - y]'; } # should trigger here is $x, 1, 'die - reap outside eval [ok - x]'; is $y, 1, 'die - reap outside eval [ok - y]'; } $y = undef; { local $x = 1; eval { local $x = 2; { { local $x = 3; reap \&check => UP UP; is $x, 3, 'die - reap at eval [not yet 1 - x]'; is $y, undef, 'die - reap at eval [not yet 1 - y]'; } is $x, 2, 'die - reap at eval [not yet 2 - x]'; is $y, undef, 'die - reap at eval [not yet 2 - y]'; die; } }; # should trigger here is $x, 1, 'die - reap at eval [ok - x]'; is $y, 1, 'die - reap at eval [ok - y]'; } $y = undef; { local $x = 1; eval { local $x = 2; { { local $x = 3; reap \&check => UP; is $x, 3, 'die - reap inside eval [not yet 1 - x]'; is $y, undef, 'die - reap inside eval [not yet 1 - y]'; } is $x, 2, 'die - reap inside eval [not yet 2 - x]'; is $y, undef, 'die - reap inside eval [not yet 2 - y]'; die; } # should trigger here }; is $x, 1, 'die - reap inside eval [ok - x]'; is $y, 1, 'die - reap inside eval [ok - y]'; } { my $z = 0; my $reaped = 0; eval { reap { $reaped = 1 }; is $reaped, 0, 'died of natural death - not reaped yet'; my $res = 1 / $z; }; my $err = $@; is $reaped, 1, 'died of natural death - reaped'; like $err, qr/division by zero/, 'died of natural death - divided by zero'; } SKIP: { skip 'Perl 5.10 required to test given/when' => 30 if "$]" < 5.010; eval <<' GIVEN_TEST_1'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; when (1) { local $x = 3; reap \&check => UP; is $x, 3, 'given/when - reap at given [not yet - x]'; is $y, undef, 'given/when - reap at given [not yet - y]'; } fail 'not reached'; } is $x, 1, 'given/when - reap at given [ok - x]'; is $y, 1, 'given/when - reap at given [ok - y]'; } GIVEN_TEST_1 fail $@ if $@; eval <<' GIVEN_TEST_2'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; when (1) { local $x = 3; reap \&check => UP; is $x, 3, 'given/when/continue - reap at given [not yet 1 - x]'; is $y, undef, 'given/when/continue - reap at given [not yet 1 - y]'; continue; } is $x, 2, 'given/when/continue - reap at given [not yet 2 - x]'; is $y, undef, 'given/when/continue - reap at given [not yet 2 - y]'; } is $x, 1, 'given/when/continue - reap at given [ok - x]'; is $y, 1, 'given/when/continue - reap at given [ok - y]'; } GIVEN_TEST_2 fail $@ if $@; eval <<' GIVEN_TEST_3'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; default { local $x = 3; reap \&check => UP; is $x, 3, 'given/default - reap at given [not yet - x]'; is $y, undef, 'given/default - reap at given [not yet - y]'; } fail 'not reached'; } is $x, 1, 'given/default - reap at given [ok - x]'; is $y, 1, 'given/default - reap at given [ok - y]'; } GIVEN_TEST_3 fail $@ if $@; eval <<' GIVEN_TEST_4'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; default { local $x = 3; reap \&check => UP; is $x, 3, 'given/default/continue - reap at given [not yet 1 - x]'; is $y, undef, 'given/default/continue - reap at given [not yet 1 - y]'; continue; } is $x, 2, 'given/default/continue - reap at given [not yet 2 - x]'; is $y, undef, 'given/default/continue - reap at given [not yet 2 - y]'; } is $x, 1, 'given/default/continue - reap at given [ok - x]'; is $y, 1, 'given/default/continue - reap at given [ok - y]'; } GIVEN_TEST_4 fail $@ if $@; eval <<' GIVEN_TEST_5'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; default { local $x = 3; given (2) { local $x = 4; when (2) { local $x = 5; reap \&check => UP UP; is $x, 5, 'given/default/given/when - reap at default [not yet 1 - x]'; is $y, undef, 'given/default/given/when - reap at default [not yet 1 - y]'; continue; } is $x, 4, 'given/default/given/when - reap at default [not yet 2 - x]'; is $y, undef, 'given/default/given/when - reap at default [not yet 2 - y]'; } is $x, 3, 'given/default/given/when - reap at default [not yet 3 - x]'; is $y, undef, 'given/default/given/when - reap at default [not yet 3 - y]'; continue; } is $x, 2, 'given/default/given/when - reap at default [ok 1 - x]'; is $y, 1, 'given/default/given/when - reap at default [ok 1 - y]'; } is $x, 1, 'given/default/given/when - reap at default [ok 2 - x]'; is $y, 1, 'given/default/given/when - reap at default [ok 2 - y]'; } GIVEN_TEST_5 fail $@ if $@; } $y = undef; { local $x = 1; eval { local $x = 2; eval { local $x = 3; reap { ++$y; die "reaped\n" } => HERE; is $x, 3, 'die in reap at eval [not yet - x]'; is $y, undef, 'die in reap at eval [not yet - y]'; }; # should trigger here, but the die isn't catched by this eval in # ealier perls die "inner\n"; }; is $@, ($] >= 5.023008 ? "inner\n" : "reaped\n"), 'die in reap at eval [ok - $@]'; is $x, 1, 'die in reap at eval [ok - x]'; is $y, 1, 'die in reap at eval [ok - y]'; } $y = undef; { local $x = 1; eval { local $x = 2; { local $x = 3; reap { ++$y; die "reaped\n" } => HERE; is $x, 3, 'die in reap inside eval [not yet - x]'; is $y, undef, 'die in reap inside eval [not yet - y]'; } # should trigger here die "failed\n"; }; is $@, "reaped\n", 'die in reap inside eval [ok - $@]'; is $x, 1, 'die in reap inside eval [ok - x]'; is $y, 1, 'die in reap inside eval [ok - y]'; } sub hijacked { my ($cb, $desc) = @_; local $x = 2; sub { local $x = 3; &reap($cb => UP); is $x, 3, "$desc [not yet 1 - x]"; is $y, undef, "$desc [not yet 1 - y]"; }->(); is $x, 2, "$desc [not yet 2 - x]"; is $y, undef, "$desc [not yet 2 - y]"; 11, 12; } for ([ sub { ++$y; 15, 16, 17, 18 }, 'implicit ' ], [ sub { ++$y; return 15, 16, 17, 18 }, '' ]) { my ($cb, $imp) = @$_; $imp = "RT #44204 - ${imp}return from reap"; my $desc; $y = undef; { $desc = "$imp in list context"; local $x = 1; my @l = hijacked($cb, $desc); is $x, 1, "$desc [ok - x]"; is $y, 1, "$desc [ok - y]"; is_deeply \@l, [ 11, 12 ], "$desc [ok - l]"; } $y = undef; { $desc = "$imp in list context"; local $x = 1; my $s = hijacked($cb, $desc); is $x, 1, "$desc [ok - x]"; is $y, 1, "$desc [ok - y]"; is $s, 12, "$desc [ok - s]"; } } Scope-Upper-0.29/t/15-reap-multi.t000644 000765 000024 00000006474 12500306324 017357 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 8 + 18 + 4 + 8 + 11 + 5 + 17; use Scope::Upper qw; my $x; sub add { local $_; my $y = $_[0]; reap sub { $x += $y } => $_[1] } $x = 0; { is($x, 0, 'start'); { add 1 => HERE; is($x, 0, '1 didn\'t run'); { add 2 => HERE; is($x, 0, '1 and 2 didn\'t run'); } is($x, 2, '1 didn\'t run, 2 ran'); { add 4 => HERE; is($x, 2, '1 and 3 didn\'t run, 2 ran'); } is($x, 6, '1 didn\'t run, 2 and 3 ran'); } is($x, 7, '1, 2 and 3 ran'); } is($x, 7, 'end'); $x = 0; { is($x, 0, 'start'); local $_ = 3; is($_, 3, '$_ has the right value'); { add 1 => HERE; is($_, 3, '$_ has the right value'); local $_ = 5; is($x, 0, '1 didn\'t run'); is($_, 5, '$_ has the right value'); { add 2 => HERE; is($_, 5, '$_ has the right value'); local $_ = 7; is($_, 7, '$_ has the right value'); is($x, 0, '1 and 2 didn\'t run'); } is($x, 2, '1 didn\'t run, 2 ran'); is($_, 5, '$_ has the right value'); { local $_ = 9; is($_, 9, '$_ has the right value'); add 4 => HERE; local $_ = 11; is($_, 11, '$_ has the right value'); is($x, 2, '1 and 3 didn\'t run, 2 ran'); } is($x, 6, '1 didn\'t run, 2 and 3 ran'); is($_, 5, '$_ has the right value'); } is($x, 7, '1, 2 and 3 ran'); is($_, 3, '$_ has the right value'); } is($x, 7, 'end'); $x = 0; { is($x, 0, 'start'); { add 1 => HERE; add 2 => HERE; is($x, 0, '1 and 2 didn\'t run'); } is($x, 3, '1 and 2 ran'); } is($x, 3, 'end'); $x = 0; { is($x, 0, 'start'); local $_ = 3; { local $_ = 5; add 1 => HERE; is($_, 5, '$_ has the right value'); local $_ = 7; add 2 => HERE; is($_, 7, '$_ has the right value'); is($x, 0, '1 and 2 didn\'t run'); local $_ = 9; is($_, 9, '$_ has the right value'); } is($x, 3, '1 and 2 ran'); is($_, 3, '$_ has the right value'); } is($x, 3, 'end'); $x = 0; { is($x, 0, 'start'); { { add 1 => UP; is($x, 0, '1 didn\'t run'); } is($x, 0, '1 didn\'t run'); } is($x, 1, '1 ran'); { { { add 2 => UP UP; is($x, 1, '2 didn\'t run'); } is($x, 1, '2 didn\'t run'); { add 4 => UP; is($x, 1, '2 and 3 didn\'t run'); } is($x, 1, '2 and 3 didn\'t run'); } is($x, 5, '2 didn\'t run, 3 ran'); } is($x, 7, '2 and 3 ran'); } is($x, 7, 'end'); sub bleh { add 2 => UP; } $x = 0; { is($x, 0, 'start'); { add 1 => HERE; is($x, 0, '1 didn\'t run'); bleh(); is($x, 0, '1 didn\'t run'); } is($x, 3, '1 ran'); } is($x, 3, 'end'); sub bar { is($_, 7, '$_ has the right value'); local $_ = 9; add 4 => UP UP; is($_, 9, '$_ has the right value'); add 8 => UP UP UP; is($_, 9, '$_ has the right value'); } sub foo { local $_ = 7; add 2 => HERE; is($_, 7, '$_ has the right value'); is($x, 0, '1, 2 didn\'t run'); bar(); is($x, 0, '1, 2, 3, 4 didn\'t run'); is($_, 7, '$_ has the right value'); add 16 => UP; is($_, 7, '$_ has the right value'); } $x = 0; { is($x, 0, 'start'); local $_ = 3; add 1 => HERE; is($_, 3, '$_ has the right value'); { local $_ = 5; is($_, 5, '$_ has the right value'); is($x, 0, '1 didn\'t run'); { foo(); is($x, 2, '1, 3, 4 and 5 didn\'t run, 2 ran'); is($_, 5, '$_ has the right value'); } is($x, 22, '1 and 4 didn\'t run, 2, 3 and 5 ran'); } is($x, 30, '1 didn\'t run, 2, 3, 4 and 5 ran'); } is($x, 31, 'end'); Scope-Upper-0.29/t/16-reap-numerous.t000644 000765 000024 00000000507 12505322506 020077 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; my $n; BEGIN { $n = 1000; } use Test::More tests => $n; use Scope::Upper qw; my $count; sub setup { for my $i (reverse 1 .. $n) { reap { is $count, $i, "$i-th destructor called at the right time"; ++$count; } UP UP; } } $count = $n + 1; { setup; $count = 1; } Scope-Upper-0.29/t/20-localize-target.t000644 000765 000024 00000016366 12500306324 020363 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 70 + 4; use Scope::Upper qw; # Scalars our $x; { local $x = 2; { localize *x, \1 => HERE; is $x, 1, 'localize *x, \1 => HERE [ok]'; } is $x, 2, 'localize *x, \1 => HERE [end]'; } sub _t { shift->{t} } { local $x; { localize *x, \bless({ t => 1 }, 'main') => HERE; is ref($x), 'main', 'localize *x, obj => HERE [ref]'; is $x->_t, 1, 'localize *x, obj => HERE [meth]'; } is $x, undef, 'localize *x, obj => HERE [end]'; } our $y; { local $x = 1; local $y = 2; { local $y = 3; localize *x, 'y' => HERE; is $x, 3, "localize *x, 'y' => HERE [ok]"; } is $x, 1, "localize *x, 'y' => HERE [end]"; } undef *x; { local $x = 7; { localize '$x', 2 => HERE; is $x, 2, 'localize "$x", 2 => HERE [ok]'; } is $x, 7, 'localize "$x", 2 => HERE [end]'; } { local $x = 8; { localize ' $x', 3 => HERE; is $x, 3, 'localize " $x", 3 => HERE [ok]'; } is $x, 8, 'localize " $x", 3 => HERE [end]'; } SKIP: { skip 'Can\'t localize through a reference before 5.8.1' => 2 if "$]" < 5.008_001; eval q{ no strict 'refs'; local ${''} = 9; { localize '$', 4 => HERE; is ${''}, 4, 'localize "$", 4 => HERE [ok]'; } is ${''}, 9, 'localize "$", 4 => HERE [end]'; }; } SKIP: { skip 'Can\'t localize through a reference before 5.8.1' => 2 if "$]" < 5.008_001; eval q{ no strict 'refs'; local ${''} = 10; { localize '', 5 => HERE; is ${''}, 5, 'localize "", 4 => HERE [ok]'; } is ${''}, 10, 'localize "", 4 => HERE [end]'; }; } { local $x = 2; { localize 'x', \1 => HERE; is $x, 1, 'localize "x", \1 => HERE [ok]'; } is $x, 2, 'localize "x", \1 => HERE [end]'; } { local $x = 4; { localize 'x', 3 => HERE; is $x, 3, 'localize "x", 3 => HERE [ok]'; } is $x, 4, 'localize "x", 3 => HERE [end]'; } { local $x; { localize 'x', bless({ t => 2 }, 'main') => HERE; is ref($x), 'main', 'localize "x", obj => HERE [ref]'; is $x->_t, 2, 'localize "x", obj => HERE [meth]'; } is $x, undef, 'localize "x", obj => HERE [end]'; } sub callthrough (*$) { my ($what, $val) = @_; if (ref $what) { $what = $$what; $val = eval "\\$val"; } local $x = 'x'; localize $what, $val => UP; is $x, 'x', 'localize callthrough [not yet]'; } { package Scope::Upper::Test::Mock1; our $x; { main::callthrough(*x, 4); Test::More::is($x, 4, 'localize glob [ok - SUTM1]'); Test::More::is($main::x, undef, 'localize glob [ok - main]'); } } { package Scope::Upper::Test::Mock2; our $x; { main::callthrough(*main::x, 5); Test::More::is($x, undef, 'localize qualified glob [ok - SUTM2]'); Test::More::is($main::x, 5, 'localize qualified glob [ok - main]'); } } { package Scope::Upper::Test::Mock3; our $x; { main::callthrough('$main::x', 6); Test::More::is($x, undef, 'localize fully qualified name [ok - SUTM3]'); Test::More::is($main::x, 6, 'localize fully qualified name [ok - main]'); } } { package Scope::Upper::Test::Mock4; our $x; { main::callthrough('$x', 7); Test::More::is($x, 7, 'localize unqualified name [ok - SUTM4]'); Test::More::is($main::x, undef, 'localize unqualified name [ok - main]'); } } $_ = 'foo'; { package Scope::Upper::Test::Mock5; { main::callthrough('$_', 'bar'); Test::More::ok(/bar/, 'localize $_ [ok]'); } } undef $_; # Arrays our @a; my $xa = [ 7 .. 9 ]; { local @a = (4 .. 6); { localize *a, $xa => HERE; is_deeply \@a, $xa, 'localize *a, [ ] => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize *a, [ ] => HERE [end]'; } { local @a = (4 .. 6); { local @a = (5 .. 7); { localize *a, $xa => UP; is_deeply \@a, [ 5 .. 7 ], 'localize *a, [ ] => UP [not yet]'; } is_deeply \@a, $xa, 'localize *a, [ ] => UP [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize *a, [ ] => UP [end]'; } # Hashes our %h; my $xh = { a => 5, c => 7 }; { local %h = (a => 1, b => 2); { localize *h, $xh => HERE; is_deeply \%h, $xh, 'localize *h, { } => HERE [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize *h, { } => HERE [end]'; } { local %h = (a => 1, b => 2); { local %h = (b => 3, c => 4); { localize *h, $xh => UP; is_deeply \%h, { b => 3, c => 4 }, 'localize *h, { } => UP [not yet]'; } is_deeply \%h, $xh, 'localize *h, { } => UP [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize *h, { } => UP [end]'; } # Code { local *foo = sub { 7 }; { localize *foo, sub { 6 } => UP; is foo(), 7, 'localize *foo, sub { 6 } => UP [not yet]'; } is foo(), 6, 'localize *foo, sub { 6 } => UP [ok]'; } { local *foo = sub { 9 }; { localize '&foo', sub { 8 } => UP; is foo(), 9, 'localize "&foo", sub { 8 } => UP [not yet]'; } is foo(), 8, 'localize "&foo", sub { 8 } => UP [ok]'; } { local *foo = sub { 'a' }; { { localize *foo, sub { 'b' } => UP; is foo(), 'a', 'localize *foo, sub { "b" } => UP [not yet 1]'; { no warnings 'redefine'; local *foo = sub { 'c' }; is foo(), 'c', 'localize *foo, sub { "b" } => UP [localized 1]'; } is foo(), 'a', 'localize *foo, sub { "b" } => UP [not yet 2]'; } is foo(), 'b', 'localize *foo, sub { "b" } => UP [ok 1]'; { no warnings 'redefine'; local *foo = sub { 'd' }; is foo(), 'd', 'localize *foo, sub { "b" } => UP [localized 2]'; } is foo(), 'b', 'localize *foo, sub { "b" } => UP [ok 2]'; } is foo(), 'a', 'localize *foo, sub { "b" } => UP [end]'; } { local *foo = sub { 'x' }; { { localize *foo, sub { 'y' } => UP; is foo(), 'x', 'localize *foo, sub { "y" } => UP [not yet]'; } is foo(), 'y', 'localize *foo, sub { "y" } => UP [ok]'; no warnings 'redefine'; *foo = sub { 'z' }; is foo(), 'z', 'localize *foo, sub { "y" } => UP [replaced]'; } is foo(), 'x', 'localize *foo, sub { "y" } => UP [end]'; } sub X::foo { 'X::foo' } { { { localize 'X::foo', sub { 'X::foo 2' } => UP; is(X->foo, 'X::foo', 'localize "X::foo", sub { "X::foo 2" } => UP [not yet]') } is(X->foo, 'X::foo 2', 'localize "X::foo", sub { "X::foo 2" } => UP [ok]'); } is(X->foo, 'X::foo', 'localize "X::foo", sub { "X::foo 2" } => UP [end]'); } @Y::ISA = 'X'; { { { localize 'X::foo', sub { 'X::foo 3' } => UP; is(Y->foo, 'X::foo', 'localize "X::foo", sub { "X::foo 3" } => UP [not yet]') } is(Y->foo, 'X::foo 3', 'localize "X::foo", sub { "X::foo 3" } => UP [ok]'); } is(Y->foo, 'X::foo', 'localize "X::foo", sub { "X::foo 2" } => UP [end]'); } { { { localize 'Y::foo', sub { 'Y::foo' } => UP; is(Y->foo, 'X::foo', 'localize "Y::foo", sub { "Y::foo" } => UP [not yet]'); } is(Y->foo, 'Y::foo', 'localize "Y::foo", sub { "Y::foo" } => UP [ok]'); } is(Y->foo, 'X::foo', 'localize "Y::foo", sub { "Y::foo" } => UP [end]'); } # Invalid sub invalid_ref { qr/^Invalid \Q$_[0]\E reference as the localization target/ } { eval { localize \1, 0 => HERE }; like $@, invalid_ref('SCALAR'), 'invalid localize \1, 0 => HERE'; } { eval { localize [ ], 0 => HERE }; like $@, invalid_ref('ARRAY'), 'invalid localize [ ], 0 => HERE'; } { eval { localize { }, 0 => HERE }; like $@, invalid_ref('HASH'), 'invalid localize { }, 0 => HERE'; } { eval { localize sub { }, 0 => HERE }; like $@, invalid_ref('CODE'), 'invalid localize sub { }, 0 => HERE'; } Scope-Upper-0.29/t/21-localize-level.t000644 000765 000024 00000001441 12500306324 020171 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize '\$main::y' => 1 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = ($i == $height - $level) ? 1 : 'undef'; return "verbose_is(\$main::y, $j, 'y h=$height, l=$level, i=$i');\n"; }; our ($x, $y, $testcase); for my $level (0 .. 2) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = $y = undef; eval $testcase; diag $@ if $@; } } } Scope-Upper-0.29/t/22-localize-block.t000644 000765 000024 00000001572 12500306324 020162 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize '\$x' => 0 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i, $x) = @_; my $j = ($i == $height - $level) ? 0 : (defined $x ? $x : 'undef'); return "verbose_is(\$x, $j, 'x h=$height, l=$level, i=$i');\n"; }; local $Scope::Upper::TestGenerator::local_test = sub { '' }; local $Scope::Upper::TestGenerator::allblocks = 1; our ($x, $testcase); for my $level (0 .. 1) { my $height = $level + 1; my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = undef; eval $testcase; diag $@ if $@; } } Scope-Upper-0.29/t/23-localize-ctl.t000644 000765 000024 00000017011 12500306324 017646 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 44 + 30; use Scope::Upper qw; our ($x, $y); { local $x = 1; { local $x = 2; localize '$y' => 1 => HERE; is $x, 2, 'last 0 [ok - x]'; is $y, 1, 'last 0 [ok - y]'; last; $y = 2; } is $x, 1, 'last 0 [end - x]'; is $y, undef, 'last 0 [end - y]'; } { local $x = 1; LOOP: { local $x = 2; local $y = 0; { local $x = 3; localize '$y' => 1 => UP; is $x, 3, 'last 1 [ok - x]'; is $y, 0, 'last 1 [ok - y]'; last LOOP; $y = 3; } $y = 2; } is $x, 1, 'last 1 [end - x]'; is $y, undef, 'last 1 [end - y]'; } { local $x = 1; { local $x = 2; localize '$y' => 1 => HERE; is $x, 2, 'next 0 [ok - x]'; is $y, 1, 'next 0 [ok - y]'; next; $y = 2; } is $x, 1, 'next 0 [end - x]'; is $y, undef, 'next 0 [end - y]'; } { local $x = 1; LOOP: { local $x = 2; local $y = 0; { local $x = 3; localize '$y' => 1 => UP; is $x, 3, 'next 1 [ok - x]'; is $y, 0, 'next 1 [ok - y]'; next LOOP; $y = 3; } $y = 2; } is $x, 1, 'next 1 [end - x]'; is $y, undef, 'next 1 [end - y]'; } { local $x = 1; { local $x = 2; { localize '$y' => 1 => UP UP; } is $x, 2, 'goto 1 [not yet - x]'; is $y, undef, 'goto 1 [not yet - y]'; { local $x = 3; goto OVER1; } } $y = 0; OVER1: is $x, 1, 'goto 1 [ok - x]'; is $y, 1, 'goto 1 [ok - y]'; } $y = undef; { local $x = 1; { local $x = 2; { local $x = 3; { localize '$y' => 1 => UP UP UP; } is $x, 3, 'goto 2 [not yet - x]'; is $y, undef, 'goto 2 [not yet - y]'; { local $x = 4; goto OVER2; } } } $y = 0; OVER2: is $x, 1, 'goto 2 [ok - x]'; is $y, 1, 'goto 2 [ok - y]'; } $y = undef; { local $x = 1; { eval { local $x = 2; { { local $x = 3; localize '$y' => 1 => UP UP UP UP; is $x, 3, 'die - localize outside eval [not yet 1 - x]'; is $y, undef, 'die - localize outside eval [not yet 1 - y]'; } is $x, 2, 'die - localize outside eval [not yet 2 - x]'; is $y, undef, 'die - localize outside eval [not yet 2 - y]'; die; } }; is $x, 1, 'die - localize outside eval [not yet 3 - x]'; is $y, undef, 'die - localize outside eval [not yet 3 - y]'; } # should trigger here is $x, 1, 'die - localize outside eval [ok - x]'; is $y, 1, 'die - localize outside eval [ok - y]'; } $y = undef; { local $x = 1; eval { local $x = 2; { { local $x = 3; localize '$y' => 1 => UP UP UP; is $x, 3, 'die - localize at eval [not yet 1 - x]'; is $y, undef, 'die - localize at eval [not yet 1 - y]'; } is $x, 2, 'die - localize at eval [not yet 2 - x]'; is $y, undef, 'die - localize at eval [not yet 2 - y]'; die; } }; # should trigger here is $x, 1, 'die - localize at eval [ok - x]'; is $y, 1, 'die - localize at eval [ok - y]'; } $y = undef; { local $x = 1; eval { local $x = 2; { { local $x = 3; localize '$y' => 1 => UP UP; is $x, 3, 'die - localize inside eval [not yet 1 - x]'; is $y, undef, 'die - localize inside eval [not yet 1 - y]'; } is $x, 2, 'die - localize inside eval [not yet 2 - x]'; is $y, undef, 'die - localize inside eval [not yet 2 - y]'; die; } # should trigger here }; is $x, 1, 'die - localize inside eval [ok - x]'; is $y, undef, 'die - localize inside eval [ok - y]'; } SKIP: { skip 'Perl 5.10 required to test given/when' => 30 if "$]" < 5.010; eval <<' GIVEN_TEST_1'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; when (1) { local $x = 3; localize '$y' => 1 => UP UP; is $x, 3, 'given/when - localize at given [not yet - x]'; is $y, undef, 'given/when - localize at given [not yet - y]'; } fail 'not reached'; } is $x, 1, 'given/when - localize at given [ok - x]'; is $y, 1, 'given/when - localize at given [ok - y]'; } GIVEN_TEST_1 fail $@ if $@; eval <<' GIVEN_TEST_2'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; when (1) { local $x = 3; localize '$y' => 1 => UP UP; is $x, 3, 'given/when/continue - localize at given [not yet 1 - x]'; is $y, undef, 'given/when/continue - localize at given [not yet 1 - y]'; continue; } is $x, 2, 'given/when/continue - localize at given [not yet 2 - x]'; is $y, undef, 'given/when/continue - localize at given [not yet 2 - y]'; } is $x, 1, 'given/when/continue - localize at given [ok - x]'; is $y, 1, 'given/when/continue - localize at given [ok - y]'; } GIVEN_TEST_2 fail $@ if $@; eval <<' GIVEN_TEST_3'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; default { local $x = 3; localize '$y' => 1 => UP UP; is $x, 3, 'given/default - localize at given [not yet - x]'; is $y, undef, 'given/default - localize at given [not yet - y]'; } fail 'not reached'; } is $x, 1, 'given/default - localize at given [ok - x]'; is $y, 1, 'given/default - localize at given [ok - y]'; } GIVEN_TEST_3 fail $@ if $@; eval <<' GIVEN_TEST_4'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; default { local $x = 3; localize '$y' => 1 => UP UP; is $x, 3, 'given/default/continue - localize at given [not yet 1 - x]'; is $y, undef, 'given/default/continue - localize at given [not yet 1 - y]'; continue; } is $x, 2, 'given/default/continue - localize at given [not yet 2 - x]'; is $y, undef, 'given/default/continue - localize at given [not yet 2 - y]'; } is $x, 1, 'given/default/continue - localize at given [ok - x]'; is $y, 1, 'given/default/continue - localize at given [ok - y]'; } GIVEN_TEST_4 fail $@ if $@; eval <<' GIVEN_TEST_5'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; local $y; { local $x = 1; given (1) { local $x = 2; default { local $x = 3; given (2) { local $x = 4; when (2) { local $x = 5; localize '$y' => 1 => UP UP UP; is $x, 5, 'given/default/given/when - localize at default [not yet 1 - x]'; is $y, undef, 'given/default/given/when - localize at default [not yet 1 - y]'; continue; } is $x, 4, 'given/default/given/when - localize at default [not yet 2 - x]'; is $y, undef, 'given/default/given/when - localize at default [not yet 2 - y]'; } is $x, 3, 'given/default/given/when - localize at default [not yet 3 - x]'; is $y, undef, 'given/default/given/when - localize at default [not yet 3 - y]'; continue; } is $x, 2, 'given/default/given/when - localize at default [ok 1 - x]'; is $y, 1, 'given/default/given/when - localize at default [ok 1 - y]'; } is $x, 1, 'given/default/given/when - localize at default [ok 2 - x]'; is $y, undef, 'given/default/given/when - localize at default [ok 2 - y]'; } GIVEN_TEST_5 fail $@ if $@; } Scope-Upper-0.29/t/24-localize-magic.t000644 000765 000024 00000000764 12500306324 020154 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Scope::Upper qw; use Test::More tests => 5; my @a = qw; { local $" = ''; { localize '$"', '_' => HERE; is "@a", 'a_b_c', 'localize $" => HERE [ok]'; } is "@a", 'abc', 'localize $" => HERE [end]'; } { local $" = ''; { local $" = '-'; { localize '$"', '_' => UP; is "@a", 'a-b-c', 'localize $" => UP [not yet]'; } is "@a", 'a_b_c', 'localize $" => UP [ok]'; } is "@a", 'abc', 'localize $" => UP [end]'; } Scope-Upper-0.29/t/25-localize-multi.t000644 000765 000024 00000002062 12500306324 020220 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 10 + 5 + 6; use Scope::Upper qw; our $x; sub loc { local $x; my $y = $_[0]; localize '$x', $y => $_[1] } $x = 0; { is($x, 0, 'start'); local $x = 7; { local $x = 8; loc 1 => UP; is($x, 8, 'not localized'); local $x = 9; is($x, 9, 'not localized'); } is($x, 1, 'localized to 1'); { is($x, 1, 'localized to 1'); { is($x, 1, 'localized to 1'); local $x = 10; is($x, 10, 'localized to undef'); } is($x, 1, 'localized to 1'); } is($x, 1, 'localized to 1'); } is($x, 0, 'end'); $x = 0; { is($x, 0, 'start'); local $x = 8; { { local $x = 8; loc 1 => UP UP; is($x, 8, 'not localized'); } loc 2 => HERE; is($x, 2, 'localized to 2'); } is($x, 1, 'localized to 1'); } is($x, 0, 'end'); $x = 0; { is($x, 0, 'start'); local $x; { { loc 1 => UP UP; is($x, undef, 'not localized'); local $x; loc 2 => UP; is($x, undef, 'not localized'); } is($x, 2, 'localized to 2'); } is($x, 1, 'localized to 1'); } is($x, 0, 'end'); Scope-Upper-0.29/t/26-localize-numerous.t000644 000765 000024 00000000551 12500306324 020745 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; my $n; BEGIN { $n = 1000; } use Test::More tests => 3; use Scope::Upper qw; our $x = 0; our $z = $n; sub setup { for (1 .. $n) { localize *x, *z => UP UP; } } is $x, 0, '$x is correctly initialized'; { setup; is $x, $n, '$x is correctly localized'; } is $x, 0, '$x regained its original value'; Scope-Upper-0.29/t/30-localize_elem-target.t000644 000765 000024 00000011543 12500306324 021356 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 25 + 12; use Scope::Upper qw; # Arrays our @a; { local @a = (4 .. 6); { localize_elem '@main::a', 1, 8 => HERE; is_deeply \@a, [ 4, 8, 6 ], 'localize_elem "@a", 1, 8 => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", 1, 8 => HERE [end]'; } { local @a = (4 .. 6); { localize_elem '@main::a', 4, 8 => HERE; is_deeply \@a, [ 4 .. 6, undef, 8 ], 'localize_elem "@a", 4, 8 => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", 4, 8 => HERE [end]'; } { local @a = (4 .. 6); { localize_elem '@main::a', -2, 8 => HERE; is_deeply \@a, [ 4, 8, 6 ], 'localize_elem "@a", -2, 8 => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", -2, 8 => HERE [end]'; } { local @a = (4 .. 6); { eval { localize_elem '@main::a', -4, 8 => HERE }; like $@, qr/Modification of non-creatable array value attempted, subscript -4/, 'localize_elem "@a", -4, 8 => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", -4, 8 => HERE [end]'; } { local @a = (4 .. 6); { local @a = (5 .. 7); { localize_elem '@main::a', 1, 12 => UP; is_deeply \@a, [ 5 .. 7 ], 'localize_elem "@a", 1, 12 => UP [not yet]'; } is_deeply \@a, [ 5, 12, 7 ], 'localize_elem "@a", 1, 12 => UP [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", 1, 12 => UP [end]'; } { local @a = (4 .. 6); { local @a = (5 .. 7); { localize_elem '@main::a', 4, 12 => UP; is_deeply \@a, [ 5 .. 7 ], 'localize_elem "@a", 4, 12 => UP [not yet]'; } is_deeply \@a, [ 5 .. 7, undef, 12 ], 'localize_elem "@a", 4, 12 => UP [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", 4, 12 => UP [end]'; } { { localize_elem '@nonexistent', 2, 7; is_deeply eval('*nonexistent{ARRAY}'), [ undef, undef, 7 ], 'localize_elem "@nonexistent", 2, 7 => HERE [ok]'; } is_deeply eval('*nonexistent{ARRAY}'), [ ], 'localize_elem "@nonexistent", 2, 7 => HERE [end]'; } # Hashes our %h; { local %h = (a => 1, b => 2); { localize_elem '%main::h', 'a', 3 => HERE; is_deeply \%h, { a => 3, b => 2 }, 'localize_elem "%h", "a", 3 => HERE [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize_elem "%h", "a", 3 => HERE [end]'; } { local %h = (a => 1, b => 2); { localize_elem '%main::h', 'c', 3 => HERE; is_deeply \%h, { a => 1, b => 2, c => 3 }, 'localize_elem "%h", "c", 3 => HERE [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize_elem "%h", "c", 3 => HERE [end]'; } { local %h = (a => 1, b => 2); { local %h = (a => 3, c => 4); { localize_elem '%main::h', 'a', 5 => UP; is_deeply \%h, { a => 3, c => 4 }, 'localize_elem "%h", "a", 5 => UP [not yet]'; } is_deeply \%h, { a => 5, c => 4 }, 'localize_elem "%h", "a", 5 => UP [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize_elem "%h", "a", 5 => UP [end]'; } { { localize_elem '%nonexistent', 'a', 13; is_deeply eval('*nonexistent{HASH}'), { a => 13 }, 'localize_elem "%nonexistent", "a", 13 => HERE [ok]'; } is_deeply eval('*nonexistent{HASH}'), { }, 'localize_elem "%nonexistent", "a", 13 => HERE [end]'; } # Invalid my $invalid_glob = qr/^Can't infer the element localization type from a glob and the value/; my $invalid_type = qr/^Can't localize an element of something that isn't an array or a hash/; { local *x; eval { localize_elem '$x', 0, 1 }; like $@, $invalid_type, 'invalid localize_elem "$x", 0, 1'; } { local *x; eval { localize_elem '&x', 0, sub { } }; like $@, $invalid_type, 'invalid localize_elem "&x", 0, sub { }'; } { local *x; eval { localize_elem '*x', 0, \1 }; like $@, $invalid_type, 'invalid localize_elem "*x", 0, \1'; } { local *x; eval { localize_elem *x, 0, \1 }; like $@, $invalid_glob, 'invalid localize_elem *x, 0, \1'; } { local *x; eval { localize_elem *x, 0, [ 1 ] }; like $@, $invalid_glob, 'invalid localize_elem *x, 0, [ 1 ]'; } { local *x; eval { localize_elem *x, 0, { a => 1 } }; like $@, $invalid_glob, 'invalid localize_elem *x, 0, { a => 1 }'; } { local *x; eval { localize_elem *x, 0, sub { } }; like $@, $invalid_glob, 'invalid localize_elem *x, 0, sub { }'; } { local *x; eval { localize_elem *x, 0, *x }; like $@, $invalid_glob, 'invalid localize_elem *x, 0, *x'; } sub invalid_ref { qr/^Invalid \Q$_[0]\E reference as the localization target/ } { eval { localize_elem \1, 0, 0 => HERE }; like $@, invalid_ref('SCALAR'), 'invalid localize_elem \1, 0, 0 => HERE'; } { eval { localize_elem [ ], 0, 0 => HERE }; like $@, invalid_ref('ARRAY'), 'invalid localize_elem [ ], 0, 0 => HERE'; } { eval { localize_elem { }, 0, 0 => HERE }; like $@, invalid_ref('HASH'), 'invalid localize_elem { }, 0, 0 => HERE'; } { eval { localize_elem sub { }, 0, 0 => HERE }; like $@, invalid_ref('CODE'), 'invalid localize_elem sub { }, 0, 0 => HERE'; } Scope-Upper-0.29/t/31-localize_elem-level.t000644 000765 000024 00000002720 12500306324 021175 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; our ($x, $testcase); local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize_elem '\@main::a', 1 => 3 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = ($i == $height - $level) ? '1, 3' : '1, 2'; return "is_deeply(\\\@main::a, [ $j ], 'a h=$height, l=$level, i=$i');\n"; }; our @a; for my $level (0 .. 2) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = undef; @a = (1, 2); eval $testcase; diag $@ if $@; } } } local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize_elem '%main::h', 'a' => 1 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = ($i == $height - $level) ? 'a => 1' : ''; return "is_deeply(\\%main::h, { $j }, 'h h=$height, l=$level, i=$i');\n"; }; our %h; for my $level (0 .. 2) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = undef; %h = (); eval $testcase; diag $@ if $@; } } } Scope-Upper-0.29/t/32-localize_elem-block.t000644 000765 000024 00000003146 12500306324 021164 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; our $testcase; local $Scope::Upper::TestGenerator::local_test = sub { '' }; local $Scope::Upper::TestGenerator::allblocks = 1; local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize_elem '\@a', 1 => 0 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i, $x) = @_; my $j = ($i == $height - $level) ? 0 : (defined $x ? $x : 11); return "verbose_is(\$a[1], $j, 'x h=$height, l=$level, i=$i');\n"; }; local $Scope::Upper::TestGenerator::local_var = '$a[1]'; our @a; for my $level (0 .. 1) { my $height = $level + 1; my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { @a = (10, 11); eval $testcase; diag $@ if $@; } } local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize_elem '%h', 'a' => 0 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i, $x) = @_; my $j = ($i == $height - $level) ? 0 : (defined $x ? $x : 'undef'); return "verbose_is(\$h{a}, $j, 'x h=$height, l=$level, i=$i');\n"; }; local $Scope::Upper::TestGenerator::local_var = '$h{a}'; our %h; for my $level (0 .. 1) { my $height = $level + 1; my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { %h = (); eval $testcase; diag $@ if $@; } } Scope-Upper-0.29/t/34-localize_elem-magic.t000644 000765 000024 00000003131 12500306324 021146 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Scope::Upper qw; use Test::More tests => 8; { package Scope::Upper::Test::TiedArray; sub TIEARRAY { bless [], $_[0] } sub STORE { $_[0]->[$_[1]] = $_[2] } sub FETCH { $_[0]->[$_[1]] } sub CLEAR { @{$_[0]} = (); } sub FETCHSIZE { scalar @{$_[0]} } sub EXTEND {} } our @a; { local @a; tie @a, 'Scope::Upper::Test::TiedArray'; @a = (5 .. 7); { localize_elem '@a', 4 => 12 => HERE; is_deeply \@a, [ 5 .. 7, undef, 12 ], 'localize_elem @incomplete_tied_array, $nonexistent, 12 => HERE [ok]'; } is_deeply \@a, [ 5 .. 7, undef, undef ], 'localize_elem @incomplete_tied_array, $nonexistent, 12 => HERE [end]'; } our $x; { local $x; local $SIG{__WARN__} = sub { }; { { localize_elem '%SIG', '__WARN__' => sub { $x = join '', @_ } => UP; is $x, undef, 'localize_elem $SIG{__WARN__} [not yet]'; } warn "1\n"; is $x, "1\n", 'localize_elem $SIG{__WARN__} [ok]'; } warn "2\n"; is $x, "1\n", 'localize_elem $SIG{__WARN__} [done]'; } sub runperl { my ($val, $in, $desc) = @_; system { $^X } $^X, '-e', "exit(\$ENV{SCOPE_UPPER_TEST} == $val ? 0 : 1)"; SKIP: { skip "system() failed: $!" => 1 if $? == -1; if ($in) { is $?, 0, $desc; } else { isnt $?, 0, $desc; } } } eval "setpgrp 0, 0"; my $time = time; { local $ENV{SCOPE_UPPER_TEST}; { { localize_elem '%ENV', 'SCOPE_UPPER_TEST' => $time => UP; runperl $time, 0, 'localize_elem $ENV{SCOPE_UPPER_TEST} [not yet]'; } runperl $time, 1, 'localize_elem $ENV{SCOPE_UPPER_TEST} [ok]'; } runperl $time, 0, 'localize_elem $ENV{SCOPE_UPPER_TEST} [done]'; } Scope-Upper-0.29/t/36-localize_elem-numerous.t000644 000765 000024 00000000715 12500306324 021752 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; my $n; BEGIN { $n = 1000; } use Test::More tests => 3; use Scope::Upper qw; our @A = ((0) x $n); sub setup { for (reverse 0 .. ($n-1)) { localize_elem '@A', $_ => ($_ + 1) => UP UP; } } is_deeply \@A, [ (0) x $n ], '@A was correctly initialized'; { setup; is_deeply \@A, [ 1 .. $n ], '@A elements are correctly localized'; } is_deeply \@A, [ (0) x $n ], '@A regained its original elements'; Scope-Upper-0.29/t/40-localize_delete-target.t000644 000765 000024 00000015456 12500306324 021706 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 53 + 4; use Scope::Upper qw; # Arrays our @a; { local @a = (4 .. 6); { localize_delete '@main::a', 1 => HERE; is_deeply \@a, [ 4, undef, 6 ], 'localize_delete "@a", 1 => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 1 => HERE [end]'; } { local @a = (4 .. 6); { localize_delete '@main::a', 4 => HERE; is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (nonexistent) => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (nonexistent) => HERE [end]'; } { local @a = (4 .. 6); local $a[4] = 7; { localize_delete '@main::a', 4 => HERE; is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (exists) => HERE [ok]'; } is_deeply \@a, [ 4 .. 6, undef, 7 ], 'localize_delete "@a", 4 (exists) => HERE [end]'; } { local @a = (4 .. 6); { localize_delete '@main::a', -2 => HERE; is_deeply \@a, [ 4, undef, 6 ], 'localize_delete "@a", -2 => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", -2 => HERE [end]'; } { local @a = (4 .. 6); local $a[4] = 7; { localize_delete '@main::a', -1 => HERE; is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", -1 (exists) => HERE [ok]'; } is_deeply \@a, [ 4 .. 6, undef, 7 ], 'localize_delete "@a", -1 (exists) => HERE [end]'; } { local @a = (4 .. 6); { eval { localize_delete '@main::a', -4 => HERE }; like $@, qr/Modification of non-creatable array value attempted, subscript -4/, 'localize_delete "@a", -4 (out of bounds) => HERE [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", -4 (out of bounds) => HERE [end]'; } { local @a = (4 .. 6); { local @a = (5 .. 7); { localize_delete '@main::a', 1 => UP; is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 1 => UP [not yet]'; } is_deeply \@a, [ 5, undef, 7 ], 'localize_delete "@a", 1 => UP [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 1 => UP [end]'; } { local @a = (4 .. 6); { local @a = (5 .. 7); { localize_delete '@main::a', 4 => UP; is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 4 (nonexistent) => UP [not yet]'; } is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 4 (nonexistent) => UP [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (nonexistent) => UP [end]'; } { local @a = (4 .. 6); { local @a = (5 .. 7); local $a[4] = 8; { localize_delete '@main::a', 4 => UP; is_deeply \@a, [ 5 .. 7, undef, 8 ], 'localize_delete "@a", 4 (exists) => UP [not yet]'; } is_deeply \@a, [ 5 .. 7 ], 'localize_delete "@a", 4 (exists) => UP [ok]'; } is_deeply \@a, [ 4 .. 6 ], 'localize_delete "@a", 4 (exists) => UP [end]'; } { { localize_delete '@nonexistent', 2; is_deeply eval('*nonexistent{ARRAY}'), [ ], 'localize_delete "@nonexistent", anything => HERE [ok]'; } is_deeply eval('*nonexistent{ARRAY}'), [ ], 'localize_delete "@nonexistent", anything => HERE [end]'; } # Hashes our %h; { local %h = (a => 1, b => 2); { localize_delete '%main::h', 'a' => HERE; is_deeply \%h, { b => 2 }, 'localize_delete "%h", "a" => HERE [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "a" => HERE [end]'; } { local %h = (a => 1, b => 2); { localize_delete '%main::h', 'c' => HERE; is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "c" => HERE [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "c" => HERE [end]'; } { local %h = (a => 1, b => 2); { local %h = (a => 3, c => 4); { localize_delete '%main::h', 'a' => UP; is_deeply \%h, { a => 3, c => 4 }, 'localize_delete "%h", "a" => UP [not yet]'; } is_deeply \%h, { c => 4 }, 'localize_delete "%h", "a" => UP [ok]'; } is_deeply \%h, { a => 1, b => 2 }, 'localize_delete "%h", "a" => UP [end]'; } { { localize_delete '%nonexistent', 'a'; is_deeply eval('*nonexistent{HASH}'), { }, 'localize_delete "%nonexistent", anything => HERE [ok]'; } is_deeply eval('*nonexistent{HASH}'), { }, 'localize_delete "%nonexistent", anything => HERE [end]'; } # Scalars our $x = 1; { localize_delete '$x', 2 => HERE; is $x, undef, 'localize_delete "$x", anything => HERE [ok]'; } is $x, 1, 'localize_delete "$x", anything => HERE [end]'; { { localize_delete '$nonexistent', 2; is eval('${*nonexistent{SCALAR}}'), undef, 'localize_delete "$nonexistent", anything => HERE [ok]'; } is eval('${*nonexistent{SCALAR}}'), undef, 'localize_delete "$nonexistent", anything => HERE [end]'; } # Code sub x { 1 }; { localize_delete '&x', 2 => HERE; ok !exists(&x), 'localize_delete "&x", anything => HERE [ok]'; } is x(), 1, 'localize_delete "&x", anything => HERE [end]'; { { localize_delete '&nonexistent', 2; is eval('exists &nonexistent'), !1, 'localize_delete "&nonexistent", anything => HERE [ok]'; } is eval('exists &nonexistent'), !1, 'localize_delete "&nonexistent", anything => HERE [end]'; } { localize_delete *x, sub { } => HERE; is !exists(&x), 1, 'localize_delete *x, anything => HERE [ok 1]'; is !defined($x), 1, 'localize_delete *x, anything => HERE [ok 2]'; } is x(), 1, 'localize_delete *x, anything => HERE [end 1]'; is $x, 1, 'localize_delete *x, anything => HERE [end 2]'; sub X::foo { 'X::foo' } { { { localize_delete '&X::foo', undef => UP; is(X->foo(), 'X::foo', 'localize_delete "&X::foo", undef => UP [not yet X]'); } ok(!X->can('foo'), 'localize_delete "&X::foo", undef => UP [ok X]'); } is(X->foo(), 'X::foo', 'localize_delete "&X::foo", undef => UP [end X]'); } @Y::ISA = 'X'; { { { localize_delete '&X::foo', undef => UP; is(Y->foo(), 'X::foo', 'localize_delete "&X::foo", undef => UP [not yet Y]'); } ok(!Y->can('foo'), 'localize_delete "&X::foo", undef => UP [ok Y]'); } is(Y->foo(), 'X::foo', 'localize_delete "&X::foo", undef => UP [end Y]'); } { local *Y::foo = sub { 'Y::foo' }; { { localize_delete '&Y::foo', undef => UP; is(Y->foo(), 'Y::foo', 'localize_delete "&Y::foo", undef => UP [not yet]'); } is(Y->foo(), 'X::foo', 'localize_delete "&Y::foo", undef => UP [ok]'); } is(Y->foo(), 'Y::foo', 'localize_delete "&Y::foo", undef => UP [end]'); } { # Prevent 'only once' warnings local *Y::foo = *Y::foo; } # Invalid sub invalid_ref { qr/^Invalid \Q$_[0]\E reference as the localization target/ } { eval { localize_delete \1, 0 => HERE }; like $@, invalid_ref('SCALAR'), 'invalid localize_delete \1, 0 => HERE'; } { eval { localize_delete [ ], 0 => HERE }; like $@, invalid_ref('ARRAY'), 'invalid localize_delete [ ], 0 => HERE'; } { eval { localize_delete { }, 0 => HERE }; like $@, invalid_ref('HASH'), 'invalid localize_delete { }, 0 => HERE'; } { eval { localize_delete sub { }, 0 => HERE }; like $@, invalid_ref('CODE'), 'invalid localize_delete sub { }, 0 => HERE'; } Scope-Upper-0.29/t/41-localize_delete-level.t000644 000765 000024 00000002765 12500306324 021527 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; our ($x, $testcase); local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize_delete '\@main::a', 2 => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = ($i == $height - $level) ? '1' : '1, undef, 2'; return "is_deeply(\\\@main::a, [ $j ], 'a h=$height, l=$level, i=$i');\n"; }; our @a; for my $level (0 .. 2) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for (@$tests) { $testcase = $_; $x = undef; @a = (1); $a[2] = 2; eval; diag $@ if $@; } } } local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "localize_delete '%main::h', 'a' => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = ($i == $height - $level) ? 'b => 2' : 'a => 1, b => 2'; return "is_deeply(\\%main::h, { $j }, 'h h=$height, l=$level, i=$i');\n"; }; our %h; for my $level (0 .. 2) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for (@$tests) { $testcase = $_; $x = undef; %h = (a => 1, b => 2); eval; diag $@ if $@; } } } Scope-Upper-0.29/t/44-localize_delete-magic.t000644 000765 000024 00000003554 12500306324 021500 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Scope::Upper qw; use Test::More tests => 9; our $deleted; { package Scope::Upper::Test::TiedArray; sub TIEARRAY { bless [], $_[0] } sub STORE { $_[0]->[$_[1]] = $_[2] } sub FETCH { $_[0]->[$_[1]] } sub CLEAR { @{$_[0]} = (); } sub FETCHSIZE { scalar @{$_[0]} } sub DELETE { ++$main::deleted; delete $_[0]->[$_[1]] } sub EXTEND {} our $NEGATIVE_INDICES = 0; } our @a; { local @a; tie @a, 'Scope::Upper::Test::TiedArray'; @a = (5 .. 7); local $a[4] = 9; is $deleted, undef, 'localize_delete @tied_array, $existent => HERE [not deleted]'; { localize_delete '@a', 4 => HERE; is $deleted, 1, 'localize_delete @tied_array, $existent => HERE [deleted]'; is_deeply \@a, [ 5 .. 7 ], 'localize_delete @tied_array, $existent => HERE [ok]'; } is_deeply \@a, [ 5 .. 7, undef, 9 ], 'localize_elem @incomplete_tied_array, $nonexistent, 12 => HERE [end]'; is $deleted, 1, 'localize_delete @tied_array, $existent => HERE [not more deleted]'; } { local @a; tie @a, 'Scope::Upper::Test::TiedArray'; @a = (4 .. 6); local $a[4] = 7; { localize_delete '@main::a', -1 => HERE; is_deeply \@a, [ 4 .. 6 ], 'localize_delete @tied_array, $existent_neg => HERE [ok]'; } is_deeply \@a, [ 4 .. 6, undef, 7 ], 'localize_delete @tied_array, $existent_neg => HERE [end]'; } SKIP: { skip '$NEGATIVE_INDICES has no special meaning on 5.8.0 and older' => 2 if "$]" < 5.008_001; local $Scope::Upper::Test::TiedArray::NEGATIVE_INDICES = 1; local @a; tie @a, 'Scope::Upper::Test::TiedArray'; @a = (4 .. 6); local $a[4] = 7; { localize_delete '@main::a', -1 => HERE; is_deeply \@a, [ 4 .. 6 ], 'localize_delete @tied_array_wo_neg, $existent_neg => HERE [ok]'; } is_deeply \@a, [ 4, 5, 7 ], 'localize_delete @tied_array_wo_neg, $existent_neg => HERE [end]'; } Scope-Upper-0.29/t/46-localize_delete-numerous.t000644 000765 000024 00000000661 12500306324 022273 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; my $n; BEGIN { $n = 1000; } use Test::More tests => 3; use Scope::Upper qw; our @A = (1 .. $n); sub setup { for (reverse 0 .. ($n-1)) { localize_delete '@A', $_ => UP UP; } } is_deeply \@A, [ 1 .. $n ], '@A was correctly initialized'; { setup; is_deeply \@A, [ ], '@A is empty inside the block'; } is_deeply \@A, [ 1 .. $n ], '@A regained its elements'; Scope-Upper-0.29/t/50-unwind-target.t000644 000765 000024 00000001012 12500306324 020046 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 6; use Scope::Upper qw; my @res; @res = (7, eval { unwind; 8; }); is $@, '', 'unwind() does not croak'; is_deeply \@res, [ 7 ], 'unwind()'; @res = (7, eval { unwind -1; 8; }); like $@, qr/^Can't\s+return\s+outside\s+a\s+subroutine/, 'unwind(-1) croaks'; is_deeply \@res, [ 7 ], 'unwind(-1)'; @res = (7, eval { unwind 0; 8; }); like $@, qr/^Can't\s+return\s+outside\s+a\s+subroutine/, 'unwind(0) croaks'; is_deeply \@res, [ 7 ], 'unwind(0)'; Scope-Upper-0.29/t/51-unwind-multi.t000644 000765 000024 00000003416 12500306324 017725 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 13 + 3; use Scope::Upper qw; my ($l1, $l2); our $x; sub c { $x = 3; sub { unwind("eval", eval { do { for (3, 4, 5) { 1, unwind('from', 'the', 'sub', 'c' => SCOPE $l1); } } } => SCOPE $l2); }->(2, 3, 4); return 'in c' } sub b { local $x = 2; my @c = (1 .. 12, c()); is $x, 3, '$x in b after c()'; return @c, 'in b'; } sub a { local $x = 1; my @b = b(); is $x, 1, '$x in a after b()'; return @b, 'in a'; } $l1 = 0; $l2 = 0; is_deeply [ a() ], [ 1 .. 12, 'in c', 'in b', 'in a' ], 'l1=0, l2=0'; $l1 = 0; $l2 = 1; is_deeply [ a() ], [ 1 .. 12, qw, 'in b', 'in a' ], 'l1=0, l2=1'; $l1 = 0; $l2 = 2; is_deeply [ a() ], [ qw, 'in a' ], 'l1=0, l2=2'; $l1 = 4; $l2 = 999; is_deeply [ a() ], [ 1 .. 12, qw, 'in b', 'in a' ], 'l1=4, l2=?'; $l1 = 5; $l2 = 999; is_deeply [ a() ], [ qw, 'in a' ], 'l1=5, l2=?'; # Unwinding while unwinding { package Scope::Upper::TestGuard; sub new { my $class = shift; bless { cb => $_[0] }, $class; } sub DESTROY { $_[0]->{cb}->() } } { my $desc = 'unwinding while unwinding'; local $@; eval { my @res = sub { sub { my $guard = Scope::Upper::TestGuard->new(sub { my @res = sub { sub { unwind @_ => CALLER(1); }->(@_); fail "$desc (second): not reached"; }->(qw); is_deeply \@res, [ qw ], "$desc (second): correct returned values"; }); unwind @_ => CALLER(1); }->(@_); fail "$desc (first): not reached"; }->(qw); is_deeply \@res, [ qw ], "$desc (first): correct returned values"; }; is $@, '', "$desc: did not croak"; } Scope-Upper-0.29/t/52-unwind-context.t000644 000765 000024 00000012735 12500306324 020264 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 33; use Scope::Upper qw; my ($res, @res); # --- Void to void ------------------------------------------------------------ sub { $res = 1; unwind(qw => SUB); $res = 0; }->(0); ok $res, 'unwind in void context at sub to void'; sub { $res = 1; eval { unwind(qw => SUB); }; $res = 0; }->(0); ok $res, 'unwind in void context at sub across eval to void'; sub { $res = 1; for (1 .. 5) { unwind qw => SUB; } $res = 0; }->(0); ok $res, 'unwind in void context at sub across loop to void'; # --- Void to scalar ---------------------------------------------------------- $res = sub { unwind(qw => SUB); return 'XXX'; }->(0); is $res, 'c', 'unwind in void context at sub to scalar'; $res = sub { eval { unwind qw => SUB; }; return 'XXX'; }->(0); is $res, 'f', 'unwind in void context at sub across eval to scalar'; $res = sub { for (1 .. 5) { unwind qw => SUB; } }->(0); is $res, 'i', 'unwind in void context at sub across loop to scalar'; $res = sub { for (6, unwind qw => SUB) { $res = 'NO'; } return 'XXX'; }->(0); is $res, 'l', 'unwind in void context at sub across loop iterator to scalar'; # --- Void to list ------------------------------------------------------------ @res = sub { unwind qw => SUB; return 'XXX'; }->(0); is_deeply \@res, [ qw ], 'unwind in void context at sub to list'; @res = sub { eval { unwind qw => SUB; }; return 'XXX'; }->(0); is_deeply \@res, [ qw ], 'unwind in void context at sub across eval to list'; @res = sub { for (1 .. 5) { unwind qw => SUB; } }->(0); is_deeply \@res, [ qw ], 'unwind in void context at sub across loop to list'; # --- Scalar to void ---------------------------------------------------------- sub { $res = 1; my $temp = unwind(qw => SUB); $res = 0; }->(0); ok $res, 'unwind in scalar context at sub to void'; sub { $res = 1; my $temp = eval { unwind(qw => SUB); }; $res = 0; }->(0); ok $res, 'unwind in scalar context at sub across eval to void'; sub { $res = 1; for (1 .. 5) { my $temp = (unwind qw => SUB); } $res = 0; }->(0); ok $res, 'unwind in scalar context at sub across loop to void'; sub { $res = 1; if (unwind qw => SUB) { $res = undef; } $res = 0; }->(0); ok $res, 'unwind in scalar context at sub across test to void'; # --- Scalar to scalar -------------------------------------------------------- $res = sub { 1, unwind(qw => SUB); }->(0); is $res, 'c', 'unwind in scalar context at sub to scalar'; $res = sub { eval { 8, unwind qw => SUB; }; }->(0); is $res, 'f', 'unwind in scalar context at sub across eval to scalar'; $res = sub { if (unwind qw => SUB) { return 'XXX'; } }->(0); is $res, 'o', 'unwind in scalar context at sub across test to scalar'; # --- Scalar to list ---------------------------------------------------------- @res = sub { if (unwind qw => SUB) { return 'XXX'; } }->(0); is_deeply \@res, [ qw ], 'unwind in scalar context at sub across test to list'; # --- List to void ------------------------------------------------------------ sub { $res = 1; my @temp = unwind(qw => SUB); $res = 0; }->(0); ok $res, 'unwind in list context at sub to void'; sub { $res = 1; my @temp = eval { unwind(qw => SUB); }; $res = 0; }->(0); ok $res, 'unwind in list context at sub across eval to void'; sub { $res = 1; for (1 .. 5) { my @temp = (unwind qw => SUB); } $res = 0; }->(0); ok $res, 'unwind in list context at sub across loop to void'; sub { $res = 1; for (6, unwind qw => SUB) { $res = undef; } $res = 0; }->(0); ok $res, 'unwind in list context at sub across test to void'; # --- List to scalar ---------------------------------------------------------- $res = sub { my @temp = (1, unwind(qw => SUB)); return 'XXX'; }->(0); is $res, 'c', 'unwind in list context at sub to scalar'; $res = sub { my @temp = eval { 8, unwind qw => SUB; }; return 'XXX'; }->(0); is $res, 'f', 'unwind in list context at sub across eval to scalar'; $res = sub { for (1 .. 5) { my @temp = (7, unwind qw => SUB); } return 'XXX'; }->(0); is $res, 'i', 'unwind in list context at sub across loop to scalar'; $res = sub { for (6, unwind qw => SUB) { return 'XXX'; } }->(0); is $res, 'l', 'unwind in list context at sub across loop iterator to scalar'; # --- List to list ------------------------------------------------------------ @res = sub { 2, unwind qw => SUB; }->(0); is_deeply \@res, [ qw ], 'unwind in list context at sub to list'; @res = sub { eval { 8, unwind qw => SUB; }; }->(0); is_deeply \@res, [ qw ], 'unwind in list context at sub across eval to list'; @res = sub { for (6, unwind qw => SUB) { return 'XXX'; } }->(0); is_deeply \@res, [ qw ], 'unwind in list context at sub across loop iterator to list'; # --- Prototypes -------------------------------------------------------------- sub pie { 7, unwind qw, $_[0] => SUB } sub wlist (@) { return @_ } $res = wlist pie 1; is $res, 3, 'unwind to list prototype to scalar'; @res = wlist pie 2; is_deeply \@res, [ qw ], 'unwind to list prototype to list'; sub wscalar ($$) { return @_ } $res = wscalar pie(6), pie(7); is $res, 2, 'unwind to scalar prototype to scalar'; @res = wscalar pie(8), pie(9); is_deeply \@res, [ 8, 9 ], 'unwind to scalar prototype to list'; Scope-Upper-0.29/t/53-unwind-misc.t000644 000765 000024 00000002270 12500306324 017525 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 7; use Scope::Upper qw; { my @destroyed; { package Scope::Upper::TestTimelyDestruction; sub new { my ($class, $label) = @_; bless { label => $label }, $class; } sub label { $_[0]->{label} } sub DESTROY { push @destroyed, $_[0]->label; } } sub SU_TTD () { 'Scope::Upper::TestTimelyDestruction' } sub foo { my $r = SU_TTD->new('a'); my @x = (SU_TTD->new('c'), SU_TTD->new('d')); unwind 123, $r, SU_TTD->new('b'), @x, sub { SU_TTD->new('e') }->() => UP SUB; } sub bar { foo(); die 'not reached'; } { my $desc = sub { "unwinding @_ across a sub" }; my @res = bar(); is $res[0], 123, $desc->('a constant literal'); is $res[1]->label, 'a', $desc->('a lexical'); is $res[2]->label, 'b', $desc->('a temporary object'); is $res[3]->label, 'c', $desc->('the contents of a lexical array (1)'); is $res[4]->label, 'd', $desc->('the contents of a lexical array (2)'); is $res[5]->label, 'e', $desc->('a temporary object returned by a sub'); } is_deeply \@destroyed, [ qw ], 'all these objects were properly destroyed'; } Scope-Upper-0.29/t/54-unwind-threads.t000644 000765 000024 00000001407 12557756555 020261 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'Scope::Upper' => 'Scope::Upper::SU_THREADSAFE()' ], 'usleep', ); use Test::Leaner; use Scope::Upper qw; our $z; sub up1 { my $tid = threads->tid(); local $z = $tid; my $p = "[$tid] up1"; usleep rand(2.5e5); my @res = ( -1, sub { my @dummy = ( 999, sub { my $foo = unwind $tid .. $tid + 2 => UP; fail "$p: not reached"; }->() ); fail "$p: not reached"; }->(), -2 ); is_deeply \@res, [ -1, $tid .. $tid + 2, -2 ], "$p: unwinded correctly"; return 1; } my @threads = map spawn(\&up1), 1 .. 30; my $completed = 0; for my $thr (@threads) { ++$completed if $thr->join; } pass 'done'; done_testing($completed + 1); Scope-Upper-0.29/t/55-yield-target.t000644 000765 000024 00000006354 12500306324 017673 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 18; use Scope::Upper qw; my @res; @res = (0, eval { yield; 1; }, 2); is $@, '', 'yield() does not croak'; is_deeply \@res, [ 0, 2 ], 'yield() in eval { ... }'; @res = (3, eval " yield; 4; ", 5); is $@, '', 'yield() does not croak'; is_deeply \@res, [ 3, 5 ], 'yield() in eval "..."'; @res = (6, sub { yield; 7; }->(), 8); is_deeply \@res, [ 6, 8 ], 'yield() in sub { ... }'; @res = (9, do { yield; 10; }, 11); is_deeply \@res, [ 9, 11 ], 'yield() in do { ... }'; @res = (12, (map { yield; 13; } qw), 14); is_deeply \@res, [ 12, 14 ], 'yield() in map { ... }'; my $loop; @res = (15, do { for (16, 17) { $loop = $_; yield; my $x = 18; } }, 19); is $loop, 16, 'yield() exited for'; is_deeply \@res, [ 15, 19 ], 'yield() in for () { ... }'; @res = (20, do { $loop = 21; while ($loop) { yield; $loop = 0; my $x = 22; } }, 23); is $loop, 21, 'yield() exited while'; is_deeply \@res, [ 20, 23 ], 'yield() in while () { ... }'; SKIP: { skip '"eval { $str =~ s/./die q[foo]/e }" breaks havoc on perl 5.8 and below' => 1 if "$]" < 5.010; my $s = 'a'; local $@; eval { $s =~ s/./yield; die 'not reached'/e; }; my $err = $@; my $line = __LINE__-3; like $err, qr/^yield\(\) can't target a substitution context at \Q$0\E line $line/, 'yield() cannot exit subst'; } SKIP: { skip 'perl 5.10 is required to test interaction with given/when' => 6 if "$]" < 5.010; @res = eval <<'TESTCASE'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; (24, do { given (25) { yield; my $x = 26; } }, 27); TESTCASE diag $@ if $@; is_deeply \@res, [ 24, 27 ], 'yield() in given { }'; # Beware that calling yield() in when() in given() sends us directly at the # end of the enclosing given block. @res = (); eval <<'TESTCASE'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; @res = (28, do { given (29) { when (29) { yield; die 'not reached 1'; } die 'not reached 2'; } }, 30) TESTCASE is $@, '', 'yield() in when { } in given did not croak'; is_deeply \@res, [ 28, 30 ], 'yield() in when { } in given'; # But calling yield() in when() in for() sends us at the next iteration. @res = (); eval <<'TESTCASE'; BEGIN { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } } use feature 'switch'; @res = (31, do { for (32, 33) { $loop = $_; when (32) { yield; die 'not reached 3'; my $x = 34; } when (33) { yield; die 'not reached 4'; my $x = 35; } die 'not reached 5'; my $x = 36; } }, 37) TESTCASE is $@, '', 'yield() in for { } in given did not croak'; is $loop, 33, 'yield() exited for on the second iteration'; # A loop exited by last() evaluates to an empty list, but a loop that reached # its natural end evaluates to false! is_deeply \@res, [ 31, '', 37 ], 'yield() in when { }'; } Scope-Upper-0.29/t/57-yield-context.t000644 000765 000024 00000012554 12500306324 020072 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 33; use Scope::Upper qw; my ($res, @res); # --- Void to void ------------------------------------------------------------ do { $res = 1; yield(qw => HERE); $res = 0; }; ok $res, 'yield in void context at sub to void'; do { $res = 1; eval { yield(qw => SCOPE(1)); }; $res = 0; }; ok $res, 'yield in void context at sub across eval to void'; do { $res = 1; for (1 .. 5) { yield qw => SCOPE(1); } $res = 0; }; ok $res, 'yield in void context at sub across loop to void'; # --- Void to scalar ---------------------------------------------------------- $res = do { yield(qw => HERE); return 'XXX'; }; is $res, 'c', 'yield in void context at sub to scalar'; $res = do { eval { yield qw => SCOPE(1); }; return 'XXX'; }; is $res, 'f', 'yield in void context at sub across eval to scalar'; $res = do { for (1 .. 5) { yield qw => SCOPE(1); } }; is $res, 'i', 'yield in void context at sub across loop to scalar'; $res = do { for (6, yield qw => SCOPE(0)) { $res = 'NO'; } 'XXX'; }; is $res, 'l', 'yield in void context at sub across loop iterator to scalar'; # --- Void to list ------------------------------------------------------------ @res = do { yield qw => HERE; return 'XXX'; }; is_deeply \@res, [ qw ], 'yield in void context at sub to list'; @res = do { eval { yield qw => SCOPE(1); }; 'XXX'; }; is_deeply \@res, [ qw ], 'yield in void context at sub across eval to list'; @res = do { for (1 .. 5) { yield qw => SCOPE(1); } }; is_deeply \@res, [ qw ], 'yield in void context at sub across loop to list'; # --- Scalar to void ---------------------------------------------------------- do { $res = 1; my $temp = yield(qw => HERE); $res = 0; }; ok $res, 'yield in scalar context at sub to void'; do { $res = 1; my $temp = eval { yield(qw => SCOPE(1)); }; $res = 0; }; ok $res, 'yield in scalar context at sub across eval to void'; do { $res = 1; for (1 .. 5) { my $temp = (yield qw => SCOPE(1)); } $res = 0; }; ok $res, 'yield in scalar context at sub across loop to void'; do { $res = 1; if (yield qw => SCOPE(0)) { $res = undef; } $res = 0; }; ok $res, 'yield in scalar context at sub across test to void'; # --- Scalar to scalar -------------------------------------------------------- $res = sub { 1, yield(qw => HERE); }->(0); is $res, 'c', 'yield in scalar context at sub to scalar'; $res = sub { eval { 8, yield qw => SCOPE(1); }; }->(0); is $res, 'f', 'yield in scalar context at sub across eval to scalar'; $res = sub { if (yield qw => SCOPE(0)) { return 'XXX'; } }->(0); is $res, 'o', 'yield in scalar context at sub across test to scalar'; # --- Scalar to list ---------------------------------------------------------- @res = sub { if (yield qw => SCOPE(0)) { return 'XXX'; } }->(0); is_deeply \@res, [ qw ], 'yield in scalar context at sub across test to list'; # --- List to void ------------------------------------------------------------ do { $res = 1; my @temp = yield(qw => HERE); $res = 0; }; ok $res, 'yield in list context at sub to void'; do { $res = 1; my @temp = eval { yield(qw => SCOPE(1)); }; $res = 0; }; ok $res, 'yield in list context at sub across eval to void'; do { $res = 1; for (1 .. 5) { my @temp = (yield qw => SCOPE(1)); } $res = 0; }; ok $res, 'yield in list context at sub across loop to void'; do { $res = 1; for (6, yield qw => SCOPE(0)) { $res = undef; } $res = 0; }; ok $res, 'yield in list context at sub across test to void'; # --- List to scalar ---------------------------------------------------------- $res = do { my @temp = (1, yield(qw => HERE)); 'XXX'; }; is $res, 'c', 'yield in list context at sub to scalar'; $res = do { my @temp = eval { 8, yield qw => SCOPE(1); }; 'XXX'; }; is $res, 'f', 'yield in list context at sub across eval to scalar'; $res = do { for (1 .. 5) { my @temp = (7, yield qw => SCOPE(1)); } 'XXX'; }; is $res, 'i', 'yield in list context at sub across loop to scalar'; $res = sub { for (6, yield qw => SCOPE(0)) { return 'XXX'; } }->(0); is $res, 'l', 'yield in list context at sub across loop iterator to scalar'; # --- List to list ------------------------------------------------------------ @res = do { 2, yield qw => HERE; }; is_deeply \@res, [ qw ], 'yield in list context at sub to list'; @res = do { eval { 8, yield qw => SCOPE(1); }; }; is_deeply \@res, [ qw ], 'yield in list context at sub across eval to list'; @res = sub { for (6, yield qw => SCOPE(0)) { return 'XXX'; } }->(0); is_deeply \@res, [ qw ], 'yield in list context at sub across loop iterator to list'; # --- Prototypes -------------------------------------------------------------- sub pie { 7, yield qw, $_[0] => SUB } sub wlist (@) { return @_ } $res = wlist pie 1; is $res, 3, 'yield to list prototype to scalar'; @res = wlist pie 2; is_deeply \@res, [ qw ], 'yield to list prototype to list'; sub wscalar ($$) { return @_ } $res = wscalar pie(6), pie(7); is $res, 2, 'yield to scalar prototype to scalar'; @res = wscalar pie(8), pie(9); is_deeply \@res, [ 8, 9 ], 'yield to scalar prototype to list'; Scope-Upper-0.29/t/58-yield-misc.t000644 000765 000024 00000007124 12500306324 017337 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 4 * 3 + 1 + 3 + 7; use lib 't/lib'; use VPIT::TestHelpers; use Scope::Upper qw; # Test timely destruction of values returned from yield() our $destroyed; sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) } { my $desc = 'scalar context, above'; local $destroyed; { my $obj = guard(); my $res = do { is $destroyed, undef, "$desc: not yet destroyed 1"; yield $obj => HERE; fail 'not reached 1'; }; is $destroyed, undef, "$desc: not yet destroyed 2"; } is $destroyed, 1, "$desc: destroyed 1"; } { my $desc = 'scalar context, below'; local $destroyed; { my $res = do { my $obj = guard(); is $destroyed, undef, "$desc: not yet destroyed 1"; yield $obj => HERE; fail 'not reached 1'; }; is $destroyed, undef, "$desc: not yet destroyed 2"; } is $destroyed, 1, "$desc: destroyed 1"; } { my $desc = 'void context, above'; local $destroyed; { my $obj = guard(); { is $destroyed, undef, "$desc: not yet destroyed 1"; yield $obj => HERE; fail 'not reached 1'; } is $destroyed, undef, "$desc: not yet destroyed 2"; } is $destroyed, 1, "$desc: destroyed 1"; } { my $desc = 'void context, below'; local $destroyed; { { is $destroyed, undef, "$desc: not yet destroyed 1"; my $obj = guard(); yield $obj => HERE; fail 'not reached 2'; } is $destroyed, 1, "$desc: destroyed 1"; } is $destroyed, 1, "$desc: destroyed 2"; } # Test 'return from do' in special cases { no warnings 'void'; my @res = (1, do { my $cxt = HERE; my $thing = (777, do { my @stuff = (888, do { yield 2, 3 => $cxt; map { my $x; $_ x 3 } qw }, 999); if (@stuff) { my $y; ++$y; 'YYY'; } else { die 'not reached'; } }); if (1) { my $z; 'ZZZ'; } 'VVV' }, 4); is "@res", '1 2 3 4', 'yield() found the op to return to'; } # Test leave { my @res = (1, do { leave; 'XXX'; }, 2); is "@res", '1 2', 'leave without arguments'; } { my @res = (1, do { leave 2, 3; 'XXX'; }, 4); is "@res", '1 2 3 4', 'leave with arguments'; } SKIP: { skip '"eval { $str =~ s/./die q[foo]/e }" breaks havoc on perl 5.8 and below' => 1 if "$]" < 5.010; my $s = 'a'; local $@; eval { $s =~ s/./leave; die 'not reached'/e; }; my $err = $@; my $line = __LINE__-3; like $err, qr/^leave\(\) can't target a substitution context at \Q$0\E line $line/, 'leave() cannot exit subst'; } { my @destroyed; { package Scope::Upper::TestTimelyDestruction; sub new { my ($class, $label) = @_; bless { label => $label }, $class; } sub label { $_[0]->{label} } sub DESTROY { push @destroyed, $_[0]->label; } } sub SU_TTD () { 'Scope::Upper::TestTimelyDestruction' } sub foo { my $r = SU_TTD->new('a'); my @x = (SU_TTD->new('c'), SU_TTD->new('d')); yield 123, $r, SU_TTD->new('b'), @x, sub { SU_TTD->new('e') }->() => UP SUB; } sub bar { foo(); die 'not reached'; } { my $desc = sub { "yielding @_ across a sub" }; my @res = bar(); is $res[0], 123, $desc->('a constant literal'); is $res[1]->label, 'a', $desc->('a lexical'); is $res[2]->label, 'b', $desc->('a temporary object'); is $res[3]->label, 'c', $desc->('the contents of a lexical array (1)'); is $res[4]->label, 'd', $desc->('the contents of a lexical array (2)'); is $res[5]->label, 'e', $desc->('a temporary object returned by a sub'); } is_deeply \@destroyed, [ qw ], 'all these objects were properly destroyed'; } Scope-Upper-0.29/t/59-yield-threads.t000644 000765 000024 00000001377 12557756555 020076 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'Scope::Upper' => 'Scope::Upper::SU_THREADSAFE()' ], 'usleep', ); use Test::Leaner; use Scope::Upper qw; our $z; sub up1 { my $tid = threads->tid(); local $z = $tid; my $p = "[$tid] up1"; usleep rand(2.5e5); my @res = ( -1, do { my @dummy = ( 999, map { my $foo = yield $tid .. $tid + 2 => UP; fail "$p: not reached"; } 666 ); fail "$p: not reached"; }, -2 ); is_deeply \@res, [ -1, $tid .. $tid + 2, -2 ], "$p: yielded correctly"; return 1; } my @threads = map spawn(\&up1), 1 .. 30; my $completed = 0; for my $thr (@threads) { ++$completed if $thr->join; } pass 'done'; done_testing($completed + 1); Scope-Upper-0.29/t/60-uplevel-target.t000644 000765 000024 00000014172 12500306324 020232 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 7 + (5 + 6 + 5 + 6 + 5); use Scope::Upper qw; our ($desc, $target); my @cxt; sub three { my ($depth, $code) = @_; $cxt[0] = HERE; $target = $cxt[$depth]; &uplevel($code => $target); pass("$desc: reached end of three()"); } my $two = sub { $cxt[1] = HERE; three(@_); pass("$desc: reached end of \$two"); }; sub one { $cxt[2] = HERE; $two->(@_); pass("$desc: reached end of one()"); } sub tester_sub { is(HERE, $target, "$desc: right context"); } my $tester_anon = sub { is(HERE, $target, "$desc: right context"); }; my @subs = (\&three, $two, \&one); for my $height (0 .. 2) { my $base = $subs[$height]; for my $anon (0, 1) { my $code = $anon ? $tester_anon : \&tester_sub; for my $depth (0 .. $height) { local $target; local $desc = "uplevel at depth $depth/$height"; $desc .= $anon ? ' (anonymous callback)' : ' (named callback)'; local $@; eval { $base->($depth, $code) }; is $@, '', "$desc: no error"; } } } { my $desc = 'uplevel called without a code reference'; local $@; eval { three(0, "wut"); fail "$desc: uplevel should have croaked"; }; like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies"; } sub four { my $desc = shift; my $cxt = HERE; uplevel { is HERE, $cxt, "$desc: right context" }; pass "$desc: reached end of four()"; } { my $desc = 'uplevel called without a target'; local $@; eval { four($desc); }; is $@, '', "$desc: no error"; } { my $desc = 'uplevel to top'; local $@; eval { uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP; fail "$desc: uplevel should have croaked"; }; like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies"; } { my $desc = 'uplevel to eval 1'; local $@; eval { uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE; fail "$desc: uplevel should have croaked"; }; like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies"; } { my $desc = 'uplevel to eval 2'; local $@; sub { eval { uplevel { fail "$desc: uplevel body should not be executed" }; fail "$desc: uplevel should have croaked"; }; return; }->(); like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies"; } # XS { my $desc = 'uplevel to XS 1'; local $@; eval { sub { my $cxt = HERE; pass "$desc: before"; &uplevel(\&HERE => $cxt); is HERE, $cxt, "$desc: after"; }->(); }; is $@, '', "$desc: no error"; } { my $desc = 'uplevel to XS 1'; local $@; eval { sub { my $up = HERE; sub { is UP, $up, "$desc: before"; &uplevel(\&HERE => $up); isnt HERE, $up, "$desc: after 1"; }->(); is HERE, $up, "$desc: after 2"; }->(); }; is $@, '', "$desc: no error"; } # Target destruction { our $destroyed; sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed } { local $@; local $destroyed = 0; my $desc = 'target destruction 1'; { my $lexical; my $target = sub { my $code = shift; ++$lexical; $code->(); }; $target = bless $target, 'Scope::Upper::TestCodeDestruction'; eval { $target->( sub { uplevel { is $destroyed, 0, "$desc: not yet 1"; } UP; is $destroyed, 0, "$desc: not yet 2"; }, ); }; is $@, '', "$desc: no error"; is $destroyed, 0, "$desc: not yet 3"; } is $destroyed, 1, "$desc: target is detroyed"; } SKIP: { skip 'This fails even with a plain subroutine call on 5.8.x' => 6 if "$]" < 5.009; local $@; local $destroyed = 0; my $desc = 'target destruction 2'; { my $lexical; my $target = sub { my $code = shift; ++$lexical; $code->(); }; $target = bless $target, 'Scope::Upper::TestCodeDestruction'; eval { $target->( sub { uplevel { $target->(sub { is $destroyed, 0, "$desc: not yet 1"; }); is $destroyed, 0, "$desc: not yet 2"; } UP; is $destroyed, 0, "$desc: not yet 3"; }, ); }; is $@, '', "$desc: no error"; is $destroyed, 0, "$desc: not yet 4"; } is $destroyed, 1, "$desc: target is detroyed"; } { local $@; local $destroyed = 0; my $desc = 'target destruction 3'; { my $lexical; my $target = sub { ++$lexical; if (@_) { my $code = shift; $code->(); } else { is $destroyed, 0, "$desc: not yet 1"; } }; $target = bless $target, 'Scope::Upper::TestCodeDestruction'; eval { $target->( sub { &uplevel($target => UP); is $destroyed, 0, "$desc: not yet 2"; }, ); }; is $@, '', "$desc: no error"; is $destroyed, 0, "$desc: not yet 3"; } is $destroyed, 1, "$desc: target is detroyed"; } SKIP: { skip 'This fails even with a plain subroutine call on 5.8.x' => 6 if "$]" < 5.009; local $@; local $destroyed = 0; my $desc = 'code destruction'; { my $lexical; my $code = sub { ++$lexical; is $destroyed, 0, "$desc: not yet 1"; }; $code = bless $code, 'Scope::Upper::TestCodeDestruction'; eval { sub { sub { &uplevel($code, UP); is $destroyed, 0, "$desc: not yet 2"; }->(); is $destroyed, 0, "$desc: not yet 2"; }->(); }; is $@, '', "$desc: no error"; is $destroyed, 0, "$desc: not yet 3"; }; is $destroyed, 1, "$desc: code is destroyed"; } SKIP: { skip 'This fails even with a plain subroutine call on 5.8.x' => 5 if "$]" < 5.009; local $@; local $destroyed = 0; my $desc = 'code destruction and goto'; { my $lexical = 0; my $cb = sub { ++$lexical; is $destroyed, 0, "$desc: not yet 1"; }; $cb = bless $cb, 'Scope::Upper::TestCodeDestruction'; eval { sub { &uplevel(sub { goto $cb } => HERE); is $destroyed, 0, "$desc: not yet 2"; }->(); }; is $@, '', "$desc: no error"; is $destroyed, 0, "$desc: not yet 3"; } is $destroyed, 1, "$desc: code is destroyed"; } } Scope-Upper-0.29/t/61-uplevel-args.t000644 000765 000024 00000017777 12500306324 017717 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 5 + 3 + 2 + 6; use Scope::Upper qw; # Basic sub { uplevel { pass 'no @_: callback' }; is "@_", 'dummy', 'no @_: @_ outside'; }->('dummy'); sub { uplevel { is "@_", '', "no arguments, no context" } }->('dummy'); sub { uplevel { is "@_", '', "no arguments, with context" } HERE }->('dummy'); sub { uplevel { is "@_", '1', "one const argument" } 1, HERE }->('dummy'); my $x = 2; sub { uplevel { is "@_", '2', "one lexical argument" } $x, HERE }->('dummy'); our $y = 3; sub { uplevel { is "@_", '3', "one global argument" } $y, HERE }->('dummy'); sub { uplevel { is "@_", '4 5', "two const arguments" } 4, 5, HERE }->('dummy'); sub { uplevel { is "@_", '1 2 3 4 5 6 7 8 9 10', "ten const arguments" } 1 .. 10 => HERE; }->('dummy'); # Reification of @_ sub { my @args = (1 .. 10); uplevel { my $r = shift; is $r, 1, 'shift: result'; is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside'; } @args, HERE; is_deeply \@args, [ 1 .. 10 ], 'shift: args'; is_deeply \@_, [ 'dummy' ], 'shift: @_ outside'; }->('dummy'); sub { my @args = (1 .. 10); uplevel { my $r = pop; is $r, 10, 'pop: result'; is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside'; } @args, HERE; is_deeply \@args, [ 1 .. 10 ], 'pop: args'; is_deeply \@_, [ 'dummy' ], 'pop: @_ outside'; }->('dummy'); sub { my @args = (1 .. 10); uplevel { my $r = unshift @_, 0; is $r, 11, 'unshift: result'; is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside'; } @args, HERE; is_deeply \@args, [ 1 .. 10 ], 'unshift: args'; is_deeply \@_, [ 'dummy' ], 'unshift: @_ outside'; }->('dummy'); sub { my @args = (1 .. 10); uplevel { my $r = push @_, 11; is $r, 11, 'push: result'; is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside'; } @args, HERE; is_deeply \@args, [ 1 .. 10 ], 'push: args'; is_deeply \@_, [ 'dummy' ], 'push: @_ outside'; }->('dummy'); sub { my @args = (1 .. 10); uplevel { my ($r) = splice @_, 4, 1; is $r, 5, 'splice: result'; is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside'; } @args, HERE; is_deeply \@args, [ 1 .. 10 ], 'splice: args'; is_deeply \@_, [ 'dummy' ], 'splice: @_ outside'; }->('dummy'); sub { my @args = (1 .. 10); uplevel { my ($r, $s, $t, @rest) = @_; is_deeply [ $r, $s, $t, \@rest ], [ 1 .. 3, [ 4 .. 10 ] ], 'unpack 1: result'; is_deeply \@_, [ 1 .. 10 ], 'unpack 1: @_ inside'; } @args, HERE; is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args'; is_deeply \@_, [ 'dummy' ], 'unpack 1: @_ outside'; }->('dummy'); sub { my @args = (1, 2); uplevel { my ($r, $s, $t, @rest) = @_; is_deeply [ $r, $s, $t, \@rest ], [ 1, 2, undef, [ ] ], 'unpack 2: result'; is_deeply \@_, [ 1, 2 ], 'unpack 2: @_ inside'; } @args, HERE; is_deeply \@args, [ 1, 2 ], 'unpack 2: args'; is_deeply \@_, [ 'dummy' ], 'unpack 2: @_ outside'; }->('dummy'); # Aliasing sub { my $s = 'abc'; uplevel { $_[0] = 'xyz'; } $s, HERE; is $s, 'xyz', 'aliasing, one layer'; }->('dummy'); sub { my $s = 'abc'; sub { uplevel { $_[0] = 'xyz'; } $_[0], HERE; is $_[0], 'xyz', 'aliasing, two layers 1'; }->($s); is $s, 'xyz', 'aliasing, two layers 2'; }->('dummy'); # goto SKIP: { if ("$]" < 5.008) { my $cb = sub { fail 'should not be executed' }; local $@; eval { sub { uplevel { goto $cb } HERE }->() }; like $@, qr/^uplevel\(\) can't execute code that calls goto before perl 5\.8/, 'goto croaks'; skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => ((5 * 4 * 4) * 3 + 1) - 1; } my @args = ( [ [ ], [ 'm' ] ], [ [ 'a' ], [ ] ], [ [ 'b' ], [ 'n' ] ], [ [ 'c' ], [ 'o', 'p' ] ], [ [ 'd', 'e' ], [ 'q' ] ], ); for my $args (@args) { my ($out, $in) = @$args; my @out = @$out; my @in = @$in; for my $reify_out (0, 1) { for my $reify_in (0, 1) { my $desc; my $base_test = sub { if ($reify_in) { is_deeply \@_, $in, "$desc: \@_ inside"; } else { is "@_", "@in", "$desc: \@_ inside"; } }; my $goto_test = sub { goto $base_test }; my $uplevel_test = sub { &uplevel($base_test, @_, HERE) }; my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) }; my @tests = ( [ 'goto' => sub { goto $base_test } ], [ 'goto in goto' => sub { goto $goto_test } ], [ 'uplevel in goto' => sub { goto $uplevel_test } ], [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ], ); for my $test (@tests) { ($desc, my $cb) = @$test; $desc .= ' (' . @out . ' out, ' . @in . ' in'; $desc .= ', reify out' if $reify_out; $desc .= ', reify in' if $reify_in; $desc .= ')'; local $@; eval { sub { &uplevel($cb, @in, HERE); if ($reify_out) { is_deeply \@_, $out, "$desc: \@_ outside"; } else { is "@_", "@out", "$desc: \@_ outside"; } }->(@out); }; is $@, '', "$desc: no error"; } } } } sub { my $s = 'caesar'; my $cb = sub { $_[0] = 'brutus'; }; sub { uplevel { goto $cb; } $_[0], HERE; }->($s); is $s, 'brutus', 'aliasing and goto'; }->('dummy'); } # goto XS SKIP: { skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => 5 if "$]" < 5.008; my $desc = 'uplevel() calling goto &uplevel'; local $@; eval { sub { my $outer_cxt = HERE; sub { my $inner_cxt = HERE; sub { uplevel { is HERE, $inner_cxt, "$desc: context inside first uplevel"; is "@_", '1 2 3', "$desc: arguments inisde first uplevel"; unshift @_, 0; push @_, 4; unshift @_, sub { is HERE, $outer_cxt, "$desc: context inside second uplevel"; is "@_", '0 1 2 3 4', "$desc: arguments inisde second uplevel"; }; push @_, UP; goto \&uplevel; } 1 .. 3 => UP; }->(); }->(); }->(); }; is $@, '', "$desc: no error"; } # uplevel() to uplevel() { my $desc = '\&uplevel as the uplevel() callback'; local $@; eval { sub { my $cxt = HERE; sub { sub { # Note that an XS call does not need a context, so after the first uplevel # call UP will point to the scope above the first target. uplevel(\&uplevel => (sub { is "@_", '1 2 3', "$desc: arguments inisde"; is HERE, $cxt, "$desc: context inside"; } => 1 .. 3 => UP) => UP); }->(10 .. 19); }->(sub { die 'wut' } => HERE); }->('dummy'); }; is $@, '', "$desc: no error"; } # Magic { package Scope::Upper::TestMagic; sub TIESCALAR { my ($class, $cb) = @_; bless { cb => $cb }, $class; } sub FETCH { $_[0]->{cb}->(@_) } sub STORE { die "Read only magic scalar" } } tie my $mg, 'Scope::Upper::TestMagic', sub { $$ }; sub { uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE }->('dummy'); tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg }; sub { uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE }->('dummy'); # Destruction { package Scope::Upper::TestTimelyDestruction; sub new { my ($class, $flag) = @_; $$flag = 0; bless { flag => $flag }, $class; } sub DESTROY { ${$_[0]->{flag}}++; } } SKIP: { skip 'This fails even with a plain subroutine call on 5.8.0' => 6 if "$]" <= 5.008; my $destroyed; { my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed); is $destroyed, 0, 'destruction: not yet 1'; sub { is $destroyed, 0, 'destruction: not yet 2'; uplevel { is $destroyed, 0, 'destruction: not yet 3'; } $z, HERE; is $destroyed, 0, 'destruction: not yet 4'; }->('dummy'); is $destroyed, 0, 'destruction: not yet 5'; } is $destroyed, 1, 'destruction: destroyed'; } Scope-Upper-0.29/t/62-uplevel-return.t000644 000765 000024 00000014614 12500306324 020266 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => (13 + 5 + 4) * 2 + 1 + (3 + 3 + 1) + 2 + 4 + 11; use Scope::Upper qw; # Basic sub check (&$$) { my ($code, $exp_in, $desc) = @_; local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; my $exp_out = [ 'A', map("X$_", @$exp_in), 'Z' ]; my @ret_in; my @ret_out = sub { @ret_in = &uplevel($code, HERE); is_deeply \@ret_in, $exp_in, "$desc: inside"; @$exp_out; }->('dummy'); is_deeply \@ret_out, $exp_out, "$desc: outside"; @ret_in; } check { return } [ ], 'empty explicit return'; check { () } [ ], 'empty implicit return'; check { return 1 } [ 1 ], 'one const scalar explicit return'; check { 2 } [ 2 ], 'one const scalar implicit return'; { my $x = 3; check { return $x } [ 3 ], 'one lexical scalar explicit return'; } { my $x = 4; check { $x } [ 4 ], 'one lexical scalar implicit return'; } { our $x = 3; check { return $x } [ 3 ], 'one global scalar explicit return'; } { our $x = 4; check { $x } [ 4 ], 'one global scalar implicit return'; } check { return 1 .. 5 } [ 1 .. 5 ], 'five const scalar explicit return'; check { 6 .. 10 } [ 6 .. 10 ], 'five const scalar implicit return'; check { 'a' .. 'z' } [ 'a' .. 'z' ], '26 const scalar implicit return'; check { [ qw ] } [ [ qw ] ],'one array reference implicit return'; my $cb = sub { 123 }; my ($ret) = check { $cb } [ $cb ], 'one anonymous sub implicit return'; is $ret->(), $cb->(), 'anonymous sub returned by uplevel still works'; for my $run (1 .. 3) { my ($cb) = sub { uplevel { my $id = 123; sub { ++$id }; }; }->('dummy'); is $cb->(), 124, "near closure returned by uplevel still works"; } { my $id = 456; for my $run (1 .. 3) { my ($cb) = sub { uplevel { my $step = 2; sub { $id += $step }; }; }->('dummy'); is $cb->(), 456 + 2 * $run, "far closure returned by uplevel still works"; } is $id, 456 + 2 * 3, 'captured lexical has the right value at the end'; } # Mark { my $desc = 'one scalar explict return between two others, without args'; my @ret = sub { my @ret = (1, uplevel(sub { return 2 }), 3); is_deeply \@ret, [ 1 .. 3 ], "$desc: inside"; qw; }->('dummy'); is_deeply \@ret, [ qw ], "$desc: outside"; } { my $desc = 'one scalar implict return between two others, without args'; my @ret = sub { my @ret = (4, uplevel(sub { 5 }), 6); is_deeply \@ret, [ 4 .. 6 ], "$desc: inside"; qw; }->('dummy'); is_deeply \@ret, [ qw ], "$desc: outside"; } { my $desc = 'one scalar explict return between two others, with args'; my @ret = sub { my @ret = (1, uplevel(sub { return 2 }, 7 .. 9, HERE), 3); is_deeply \@ret, [ 1 .. 3 ], "$desc: inside"; qw; }->('dummy'); is_deeply \@ret, [ qw ], "$desc: outside"; } { my $desc = 'one scalar implict return between two others, with args'; my @ret = sub { my @ret = (4, uplevel(sub { 5 }, 7 .. 9, HERE), 6); is_deeply \@ret, [ 4 .. 6 ], "$desc: inside"; qw; }->('dummy'); is_deeply \@ret, [ qw ], "$desc: outside"; } { my $desc = 'complex chain of calls'; sub one { "<", two("{", @_, "}"), ">" } sub two { "(", three("[", @_, "]"), ")" } sub three { (uplevel { "A", "B", four(@_) } @_, UP), "Z" } sub four { is_deeply \@_, [ qw|[ { * } ]| ], "$desc: inside"; @_ } my @ret = one('*'); is_deeply \@ret, [ qw|< ( A B [ { * } ] Z ) >| ], "$desc: outside"; } # goto SKIP: { skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => 2 if "$]" < 5.008; { my $desc = 'values returned from goto'; local $@; my $cb = sub { 'hello' }; my @ret = eval { 'a', sub { 'b', sub { 'c', &uplevel(sub { 'd', (goto $cb), 'w' } => UP), 'x' }->(), 'y' }->(), 'z' }; is $@, '', "$desc: did not croak"; is_deeply \@ret, [ qw ], "$desc: returned values"; } } # uplevel() to uplevel() { my $desc = '\&uplevel as the uplevel() callback'; local $@; eval { my @ret = sub { my $cxt = HERE; my @ret = sub { my @ret = sub { # Note that an XS call does not need a context, so after the first uplevel # call UP will point to the scope above the first target. 'a', uplevel(\&uplevel => (sub { return qw; } => UP) => UP), 'b'; }->(); is "@ret", 'a x y z b', "$desc: returned from uplevel"; return qw; }->(); is "@ret", 'u v w', "$desc: returned from the first target"; return qw; }->(); is "@ret", 'm n', "$desc: returned from the second target"; }; is $@, '', "$desc: no error"; } # Magic { package Scope::Upper::TestMagic; sub TIESCALAR { my ($class, $cb) = @_; bless { cb => $cb }, $class; } sub FETCH { $_[0]->{cb}->(@_) } sub STORE { die "Read only magic scalar" } } { tie my $mg, 'Scope::Upper::TestMagic', sub { $$ }; check { return $mg } [ $$ ], 'one magical scalar explicit return'; check { $mg } [ $$ ], 'one magical scalar implicit return'; tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg }; check { return $mg2 } [ $$ ], 'one double magical scalar explicit return'; check { $mg2 } [ $$ ], 'one double magical scalar implicit return'; } # Destruction { package Scope::Upper::TestTimelyDestruction; sub new { my ($class, $flag) = @_; $$flag = 0; bless { flag => $flag }, $class; } sub DESTROY { ${$_[0]->{flag}}++; } } { my $destroyed; { sub { my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed); is $destroyed, 0, 'destruction 1: not yet 1'; uplevel { is $destroyed, 0, 'destruction 1: not yet 2'; $z; }, do { is $destroyed, 0, 'destruction 1: not yet 3'; () } }->('dummy'); is $destroyed, 1, 'destruction 1: destroyed 1'; } is $destroyed, 1, 'destruction 1: destroyed 2'; } SKIP: { skip 'This fails even with a plain subroutine call on 5.8.x' => 6 if "$]" < 5.009; my $destroyed; { my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed); is $destroyed, 0, 'destruction 2: not yet 1'; sub { is $destroyed, 0, 'destruction 2: not yet 2'; (uplevel { is $destroyed, 0, 'destruction 2: not yet 3'; return $z; }), do { is $destroyed, 0, 'destruction 2: not yet 4'; () } }->('dummy'); is $destroyed, 0, 'destruction 2: not yet 5'; } is $destroyed, 1, 'destruction 2: destroyed'; } Scope-Upper-0.29/t/63-uplevel-ctl.t000644 000765 000024 00000017071 12500306324 017532 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7) + 1; use Scope::Upper qw; sub depth { my $depth = 0; while (1) { my @c = caller($depth); last unless @c; ++$depth; } return $depth - 1; } is depth(), 0, 'check top depth'; is sub { depth() }->(), 1, 'check subroutine call depth'; is do { local $@; eval { depth() } }, 1, 'check eval block depth'; { my $desc = 'exception with no eval in between 1'; local $@; eval { sub { is depth(), 2, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 2"; die 'cabbage'; }; fail "$desc: not reached 1"; }->(); fail "$desc: not reached 2"; }; my $line = __LINE__-6; like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception"; } { my $desc = 'exception with no eval in between 2'; local $@; eval { sub { is depth(), 2, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 2"; sub { is depth(), 3, "$desc: correct depth 3"; die 'lettuce'; }->(); }; fail "$desc: not reached 1"; }->(); fail "$desc: not reached 2"; }; my $line = __LINE__-7; like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception"; } { my $desc = 'exception with no eval in between 3'; local $@; eval q[ sub { is depth(), 2, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 2"; sub { is depth(), 3, "$desc: correct depth 3"; die 'onion'; }->(); }; fail "$desc: not reached 1"; }->(); fail "$desc: not reached 2"; ]; my $loc = $^P ? "[$0:" . (__LINE__-14) . ']' : ''; like $@, qr/^onion at \(eval \d+\)\Q$loc\E line 8/, "$desc: correct exception"; } { my $desc = 'exception with an eval in between 1'; local $@; eval { sub { eval { is depth(), 3, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 2"; die 'macaroni'; } SUB; fail "$desc: not reached 1"; }; fail "$desc: not reached 2"; }->(); fail "$desc: not reached 3"; }; my $line = __LINE__-8; like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception"; } { my $desc = 'exception with an eval in between 2'; local $@; eval { sub { eval { is depth(), 3, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 1"; sub { is depth(), 3, "$desc: correct depth 1"; die 'spaghetti'; }->(); } SUB; fail "$desc: not reached 1"; }; fail "$desc: not reached 2"; }->(); fail "$desc: not reached 3"; }; my $line = __LINE__-9; like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception"; } { my $desc = 'exception with an eval in between 3'; local $@; eval { sub { eval q[ is depth(), 3, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 1"; sub { is depth(), 3, "$desc: correct depth 1"; die 'ravioli'; }->(); } SUB; fail "$desc: not reached 1"; ]; fail "$desc: not reached 2"; }->(); fail "$desc: not reached 3"; }; my $loc = $^P ? "[$0:" . (__LINE__-15) . ']' : ''; like $@, qr/^ravioli at \(eval \d+\)\Q$loc\E line 7/, "$desc: correct exception"; } our $hurp; SKIP: { skip "Causes failures during global destruction on perl 5.8.[0-6]" => 5 if "$]" >= 5.008 and "$]" <= 5.008_006; my $desc = 'exception with an eval and a local $@ in between'; local $hurp = 'durp'; local $@; my $x = (eval { sub { local $@; eval { sub { is depth(), 4, "$desc: correct depth 1"; uplevel { is depth(), 2, "$desc: correct depth 2"; die 'lasagna' } CALLER(2); fail "$desc: not reached 1"; }->(); fail "$desc: not reached 2"; }; fail "$desc: not reached 3"; }->(); fail "$desc: not reached 4"; }, $@); my $line = __LINE__-10; like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception"; like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset"; is $hurp, 'durp', "$desc: force save stack flushing didn't go too far"; } { my $desc = 'several exceptions in a row'; local $@; eval { sub { is depth(), 2, "$desc (first): correct depth"; uplevel { is depth(), 2, "$desc (first): correct depth"; die 'carrot'; }; fail "$desc (first): not reached 1"; }->(); fail "$desc (first): not reached 2"; }; my $line = __LINE__-6; like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception"; eval { sub { is depth(), 2, "$desc (second): correct depth 1"; uplevel { is depth(), 2, "$desc (second): correct depth 2"; die 'potato'; }; fail "$desc (second): not reached 1"; }->(); fail "$desc (second): not reached 2"; }; $line = __LINE__-6; like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception"; eval { sub { is depth(), 2, "$desc (third): correct depth 1"; uplevel { is depth(), 2, "$desc (third): correct depth 2"; die 'tomato'; }; fail "$desc (third): not reached 1"; }->(); fail "$desc (third): not reached 2"; }; $line = __LINE__-6; like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception"; } my $has_B = do { local $@; eval { require B; 1 } }; sub check_depth { my ($code, $expected, $desc) = @_; SKIP: { skip 'B.pm is needed to check CV depth' => 1 unless $has_B; local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; my $depth = B::svref_2object($code)->DEPTH; is $depth, $expected, $desc; } } sub bonk { my ($code, $n, $cxt) = @_; $cxt = SUB unless defined $cxt; if ($n) { bonk($code, $n - 1, $cxt); } else { &uplevel($code, $cxt); } } { my $desc = "an exception unwinding several levels of the same sub 1"; local $@; check_depth \&bonk, 0, "$desc: depth at the beginning"; my $rec = 7; sub { eval { bonk(sub { check_depth \&bonk, $rec + 1, "$desc: depth inside"; die 'pepperoni'; }, $rec); } }->(); my $line = __LINE__-4; like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception"; check_depth \&bonk, 0, "$desc: depth at the end"; } sub clash { my ($pre, $rec, $desc, $cxt, $m, $n) = @_; $m = 0 unless defined $m; if ($m < $pre) { clash($pre, $rec, $desc, $cxt, $m + 1, $n); } elsif ($m == $pre) { check_depth \&clash, $pre + 1, "$desc: depth after prepending frames"; eval { clash($pre, $rec, $desc, $cxt, $pre + 1, $n); }; my $line = __LINE__+11; like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception"; check_depth \&clash, $pre + 1, "$desc: depth after unwinding"; } else { $n = 0 unless defined $n; $cxt = SUB unless defined $cxt; if ($n < $rec) { clash($pre, $rec, $desc, $cxt, $m, $n + 1); } else { uplevel { check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside"; die 'garlic'; } $cxt; } } } { my $desc = "an exception unwinding several levels of the same sub 2"; local $@; check_depth \&clash, 0, "$desc: depth at the beginning"; my $pre = 5; my $rec = 10; sub { eval { clash($pre, $rec, $desc); } }->(); is $@, '', "$desc: no exception outside"; check_depth \&clash, 0, "$desc: depth at the beginning"; } # XS { my $desc = 'exception thrown from XS'; local $@; eval { sub { &uplevel(\&uplevel => \1, HERE); }->(); }; my $line = $^P ? '\d+' : __LINE__-2; # The error happens at the target frame. my $file = $^P ? '\S+' : quotemeta $0; like $@, qr/^First argument to uplevel must be a code reference at $file line $line/, "$desc: correct error"; } Scope-Upper-0.29/t/64-uplevel-caller.t000644 000765 000024 00000006056 12500306324 020214 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => ((3 * 4) / 2) * 2 * 2 + 8; use Scope::Upper qw; sub callstack { my ($check_args) = @_; my $i = 1; my @stack; while (1) { my @c = $check_args ? do { package DB; caller($i++) } : caller($i++); last unless @c; if ($check_args) { my $args = $c[4] ? [ @DB::args ] : undef; push @c, $args; } push @stack, \@c; } return \@stack; } my @stacks; sub three { my ($depth, $code) = @_; $stacks[0] = callstack(1); &uplevel($code, 'three', CALLER($depth)); } my $two = sub { $stacks[1] = callstack(1); three(@_, 'two'); }; sub one { $stacks[2] = callstack(1); $two->(@_, 'one'); } sub tester_sub { callstack(1) } my $tester_anon = sub { callstack(1) }; my @subs = (\&three, $two, \&one); for my $height (0 .. 2) { my $base = $subs[$height]; for my $anon (0, 1) { my $code = $anon ? $tester_anon : \&tester_sub; for my $depth (0 .. $height) { my $desc = "callstack at depth $depth/$height"; $desc .= $anon ? ' (anonymous callback)' : ' (named callback)'; local $@; my $result = eval { $base->($depth, $code, 'zero') }; is $@, '', "$desc: no error"; is_deeply $result, $stacks[$depth], "$desc: correct call stack"; } } } sub four { my $cb = shift; &uplevel($cb, 1, HERE); } { my $desc = "recalling in the coderef passed to uplevel (anonymous)"; my $cb; $cb = sub { $_[0] ? $cb->(0) : callstack(0) }; local $@; my ($expected, $got) = eval { $cb->(1), four($cb) }; is $@, '', "$desc: no error"; $expected->[1]->[3] = 'main::four'; is_deeply $got, $expected, "$desc: correct call stack"; } sub test_named_recall { $_[0] ? test_named_recall(0) : callstack(0) } { my $desc = "recalling in the coderef passed to uplevel (named)"; local $@; my ($expected, $got) = eval { test_named_recall(1),four(\&test_named_recall) }; is $@, '', "$desc: no error"; $expected->[1]->[3] = 'main::four'; is_deeply $got, $expected, "$desc: correct call stack"; } my $mixed_recall_1; sub test_mixed_recall_1 { if ($_[0]) { $mixed_recall_1->(0) } else { callstack(0) } } $mixed_recall_1 = \&test_mixed_recall_1; { my $desc = "recalling in the coderef passed to uplevel (mixed 1)"; local $@; my ($expected, $got) = eval { test_mixed_recall_1(1), four($mixed_recall_1) }; is $@, '', "$desc: no error"; $expected->[1]->[3] = 'main::four'; is_deeply $got, $expected, "$desc: correct call stack"; } my $mixed_recall_2_bis = do { my $mixed_recall_2; { my $fake1; eval q{ my $fake2; { my $fake3; sub test_mixed_recall_2 { $fake1++; $fake2++; $fake3++; if ($_[0]) { $mixed_recall_2->(0) } else { callstack(0) } } } }; } $mixed_recall_2 = \&test_mixed_recall_2; }; { my $desc = "recalling in the coderef passed to uplevel (mixed 2)"; local $@; my ($expected, $got) = eval { test_mixed_recall_2(1), four($mixed_recall_2_bis) }; is $@, '', "$desc: no error"; $expected->[1]->[3] = 'main::four'; is_deeply $got, $expected, "$desc: correct call stack"; } Scope-Upper-0.29/t/65-uplevel-multi.t000644 000765 000024 00000004457 12500306324 020110 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3 + 7 * 2 + 8; use Scope::Upper qw; sub depth { my $depth = 0; while (1) { my @c = caller($depth); last unless @c; ++$depth; } return $depth - 1; } is depth(), 0, 'check top depth'; is sub { depth() }->(), 1, 'check subroutine call depth'; is do { local $@; eval { depth() } }, 1, 'check eval block depth'; { my $desc = 'uplevel in uplevel : lower frame'; local $@; my @ret = eval { 1, sub { is depth(), 2, "$desc: correct depth 1"; 2, uplevel(sub { is depth(), 2, "$desc: correct depth 2"; 3, sub { is depth(), 3, "$desc: correct depth 3"; 4, uplevel(sub { is depth(), 3, "$desc: correct depth 4"; return 5, @_; }, 6, @_, HERE); }->(7, @_); }, 8, @_, HERE); }->(9); }; is $@, '', "$desc: no error"; is depth(), 0, "$desc: correct depth outside"; is_deeply \@ret, [ 1 .. 9 ], "$desc: correct return value" } { my $desc = 'uplevel in uplevel : same frame'; local $@; my @ret = eval { 11, sub { is depth(), 2, "$desc: correct depth 1"; 12, uplevel(sub { is depth(), 2, "$desc: correct depth 2"; 13, sub { is depth(), 3, "$desc: correct depth 3"; 14, uplevel(sub { is depth(), 2, "$desc: correct depth 4"; return 15, @_; }, 16, @_, UP); }->(17, @_); }, 18, @_, HERE); }->(19); }; is $@, '', "$desc: no error"; is depth(), 0, "$desc: correct depth outside"; is_deeply \@ret, [ 11 .. 19 ], "$desc: correct return value" } { my $desc = 'uplevel in uplevel : higher frame'; local $@; my @ret = eval { 20, sub { is depth(), 2, "$desc: correct depth 1"; 21, sub { is depth(), 3, "$desc: correct depth 2"; 22, uplevel(sub { is depth(), 3, "$desc: correct depth 3"; 23, sub { is depth(), 4, "$desc: correct depth 4"; 24, uplevel(sub { is depth(), 2, "$desc: correct depth 5"; return 25, @_; }, 26, @_, UP UP); }->(27, @_); }, 28, @_, HERE); }->(29, @_); }->('2A'); }; is $@, '', "$desc: no error"; is depth(), 0, "$desc: correct depth outside"; is_deeply \@ret, [ 20 .. 29, '2A' ], "$desc: correct return value" } Scope-Upper-0.29/t/66-uplevel-context.t000644 000765 000024 00000001733 12500306324 020435 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 6; use Scope::Upper qw; { my $want; my @res = sub { uplevel { $want = wantarray; }; return; }->(); is $want, undef, 'static void context'; } { my $want; my @res = sub { my $res = uplevel { $want = wantarray; }; return; }->(); is $want, '', 'static scalar context'; } { my $want; my $res = sub { my @res = uplevel { $want = wantarray; }; return; }->(); is $want, 1, 'static list context'; } { my $want; my @res = sub { sub { uplevel { $want = wantarray; } UP; }->(); return; }->(); is $want, undef, 'dynamic void context'; } { my $want; my @res = sub { my $res = sub { uplevel { $want = wantarray; } UP; }->(); return; }->(); is $want, '', 'dynamic scalar context'; } { my $want; my $res = sub { my @res = sub { uplevel { $want = wantarray; } UP; }->(); return; }->(); is $want, 1, 'dynamic list context'; } Scope-Upper-0.29/t/67-uplevel-scope.t000644 000765 000024 00000003300 12500306324 020053 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 2 + 2 * 6 + 3 * 2; use Scope::Upper qw; { our $x = 1; sub { local $x = 2; sub { local $x = 3; uplevel { is $x, 3, 'global variables scoping 1' } HERE; }->(); }->(); } { our $x = 4; sub { local $x = 5; sub { local $x = 6; uplevel { is $x, 6, 'global variables scoping 2' } UP; }->(); }->(); } sub { 'abc' =~ /(.)/; is $1, 'a', 'match variables scoping 1: before 1'; sub { 'uvw' =~ /(.)/; is $1, 'u', 'match variables scoping 1: before 2'; uplevel { is $1, 'u', 'match variables scoping 1: before 3'; 'xyz' =~ /(.)/; is $1, 'x', 'match variables scoping 1: after 1'; } HERE; is $1, 'u', 'match variables scoping 1: after 2'; }->(); is $1, 'a', 'match variables scoping 1: after 3'; }->(); sub { 'abc' =~ /(.)/; is $1, 'a', 'match variables scoping 2: before 1'; sub { 'uvw' =~ /(.)/; is $1, 'u', 'match variables scoping 2: before 2'; uplevel { is $1, 'u', 'match variables scoping 2: before 3'; 'xyz' =~ /(.)/; is $1, 'x', 'match variables scoping 2: after 1'; } UP; is $1, 'u', 'match variables scoping 2: after 2'; }->(); is $1, 'a', 'match variables scoping 2: after 3'; }->(); SKIP: { skip 'No state variables before perl 5.10' => 3 * 2 unless "$]" >= 5.010; my $desc = 'state variables'; { local $@; eval 'use feature "state"; sub herp { state $id = 123; return ++$id }'; die $@ if $@; } sub derp { sub { &uplevel(\&herp => UP); }->(); } for my $run (1 .. 3) { local $@; my $ret = eval { derp() }; is $@, '', "$desc: run $run did not croak"; is $ret, 123 + $run, "$desc: run $run returned the correct value"; } } Scope-Upper-0.29/t/69-uplevel-threads.t000644 000765 000024 00000002272 12557756555 020440 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'Scope::Upper' => 'Scope::Upper::SU_THREADSAFE()' ], 'usleep', ); use Test::Leaner; use Scope::Upper qw; sub depth { my $depth = 0; while (1) { my @c = caller($depth); last unless @c; ++$depth; } return $depth - 1; } is depth(), 0, 'check top depth'; is sub { depth() }->(), 1, 'check subroutine call depth'; is do { local $@; eval { depth() } }, 1, 'check eval block depth'; our $z; sub cb { my $d = splice @_, 1, 1; my $p = shift; my $tid = pop; is depth(), $d - 1, "$p: correct depth inside"; $tid, @_, $tid + 2 } sub up1 { my $tid = threads->tid(); local $z = $tid; my $p = "[$tid] up1"; usleep rand(2.5e5); my @res = ( -2, sub { my @dummy = ( -1, sub { my $d = depth(); my @ret = &uplevel(\&cb => ($p, $d, $tid + 1, $tid) => UP); is depth(), $d, "$p: correct depth after uplevel"; @ret; }->(), 1 ); }->(), 2 ); is_deeply \@res, [ -2, -1, $tid .. $tid + 2, 1, 2 ], "$p: returns correctly"; } my @threads = map spawn(\&up1), 1 .. 30; $_->join for @threads; done_testing; Scope-Upper-0.29/t/70-uid-target.t000644 000765 000024 00000003261 12557712023 017346 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3 + 6 + 4 + 1 + 5; use Scope::Upper qw; { local $@; eval { my $here = uid; }; is $@, '', 'uid() does not croak'; } { local $@; eval { my $here = uid HERE; }; is $@, '', 'uid(HERE) does not croak'; } { local $@; eval { my $up = uid UP; }; is $@, '', 'uid(UP) does not croak'; } { my $here = uid; is $here, uid(), '$here eq uid()'; is $here, uid(HERE), '$here eq uid(HERE)'; { is $here, uid(UP), '$here eq uid(UP) (in block)'; } sub { is $here, uid(UP), '$here eq uid(UP) (in sub)'; }->(); local $@; eval { is $here, uid(UP), '$here eq uid(UP) (in eval block)'; }; eval q{ is $here, uid(UP), '$here eq uid(UP) (in eval string)'; }; } { my $here; { { $here = uid(UP); isnt $here, uid(), 'uid(UP) != uid(HERE)'; } is $here, uid(), '$here defined in an older block is now OK'; } isnt $here, uid(), '$here defined in an older block is no longer OK'; { isnt $here, uid(), '$here defined in an older block has been overwritten'; } } { my $first; for (1, 2) { if ($_ == 1) { $first = uid(); } else { isnt $first, uid(), 'a new UID for each loop iteration'; } } } { my $top; my $uid; sub Scope::Upper::TestUIDDestructor::DESTROY { $uid = uid; isnt $uid, $top, '$uid is not the outside UID'; { is uid(UP), $uid, 'uid(UP) in block in destructor is correct'; } } { my $guard = bless [], 'Scope::Upper::TestUIDDestructor'; $top = uid; } isnt $uid, undef, '$uid was set in the destructor'; { isnt $uid, uid(), '$uid is no longer valid (in block)'; sub { isnt $uid, uid(), '$uid is no longer valid (in sub in block)'; }->(); } } Scope-Upper-0.29/t/74-uid-validate.t000644 000765 000024 00000005565 12500306324 017655 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 6 + 5 + 4 + 1 + 9; use Scope::Upper qw; { local $@; my $here = uid; eval { validate_uid($here); }; is $@, '', 'validate_uid(uid) does not croak'; } { local $@; my $here = uid; eval { validate_uid('123'); }; my $line = __LINE__-2; like $@, qr/^UID contains only one part at \Q$0\E line $line/, 'validate_uid("123") croaks'; } for my $wrong ('1.23-4', 'abc-5') { local $@; my $here = uid; eval { validate_uid($wrong); }; my $line = __LINE__-2; like $@, qr/^First UID part is not an unsigned integer at \Q$0\E line $line/, "validate_uid(\"$wrong\") croaks"; } for my $wrong ('67-8.9', '001-def') { local $@; my $here = uid; eval { validate_uid($wrong); }; my $line = __LINE__-2; like $@, qr/^Second UID part is not an unsigned integer at \Q$0\E line $line/, "validate_uid(\"$wrong\") croaks"; } { my $here = uid; ok validate_uid($here), '$here is valid (same scope)'; { ok validate_uid($here), '$here is valid (in block)'; } sub { ok validate_uid($here), '$here is valid (in sub)'; }->(); local $@; eval { ok validate_uid($here), '$here is valid (in eval block)'; }; eval q{ ok validate_uid($here), '$here is valid (in eval string)'; }; } { my $here; { { $here = uid(UP); ok validate_uid($here), '$here is valid (below)'; } ok validate_uid($here), '$here is valid (exact)'; } ok !validate_uid($here), '$here is invalid (above)'; { ok !validate_uid($here), '$here is invalid (new block)'; } } { my $first; for (1, 2) { if ($_ == 1) { $first = uid(); } else { ok !validate_uid($first), 'a new UID for each loop iteration'; } } } { my $top; my $uid; sub Scope::Upper::TestUIDDestructor::DESTROY { ok !validate_uid($top), '$top defined after the guard is not valid in destructor'; $uid = uid; ok validate_uid($uid), '$uid is valid in destructor'; my $up; { $up = uid; ok validate_uid($up), '$up is valid in destructor'; } ok !validate_uid($up), '$up is no longer valid in destructor'; } { my $guard = bless [], 'Scope::Upper::TestUIDDestructor'; $top = uid; ok validate_uid($top), '$top defined after the guard is valid in block'; } ok !validate_uid($top), '$top is no longer valid outside of the block'; ok !validate_uid($uid), '$uid is no longer valid outside of the destructor'; sub Scope::Upper::TestUIDDestructor2::DESTROY { ok validate_uid($top), '$top defined before the guard is valid in destructor'; } SKIP: { skip 'Destructors are always last before perl 5.8' => 2 if "$]" < 5.008; $top = uid; my $guard = bless [], 'Scope::Upper::TestUIDDestructor2'; ok validate_uid($top), '$top defined before the guard is valid in block'; } } Scope-Upper-0.29/t/75-uid-uplevel.t000644 000765 000024 00000013522 12500306324 017531 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 2 * 32 + 2 * 21; use Scope::Upper qw; for my $run (1, 2) { sub { my $above_uid = uid; my $there = "in the sub above the target (run $run)"; my $uplevel_uid = sub { my $target_uid = uid; my $there = "in the target sub (run $run)"; my $uplevel_uid = sub { my $between_uid = uid; my $there = "in the sub between the target and the source (run $run)"; my $uplevel_uid = sub { my $source_uid = uid; my $there = "in the source sub (run $run)"; my $uplevel_uid = uplevel { my $uplevel_uid = uid; my $there = "in the uplevel callback (run $run)"; my $invalid = 'temporarily invalid'; ok validate_uid($uplevel_uid), "\$uplevel_uid is valid $there"; ok !validate_uid($source_uid), "\$source_uid is $invalid $there"; ok !validate_uid($between_uid), "\$between_uid is $invalid $there"; ok !validate_uid($target_uid), "\$target_uid is $invalid $there"; ok validate_uid($above_uid), "\$above_uid is valid $there"; isnt $uplevel_uid, $source_uid, "\$uplevel_uid != \$source_uid $there"; isnt $uplevel_uid, $between_uid, "\$uplevel_uid != \$between_uid $there"; isnt $uplevel_uid, $target_uid, "\$uplevel_uid != \$target_uid $there"; isnt $uplevel_uid, $above_uid, "\$uplevel_uid != \$above_uid $there"; { my $here = uid; isnt $here, $source_uid, "\$here != \$source_uid in block $there"; isnt $here, $between_uid, "\$here != \$between_uid in block $there"; isnt $here, $target_uid, "\$here != \$target_uid in block $there"; isnt $here, $above_uid, "\$here != \$above_uid in block $there"; } is uid(UP), $above_uid, "uid(UP) == \$above_uid $there"; return $uplevel_uid; } UP UP; ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; ok validate_uid($source_uid), "\$source_uid is valid again $there"; ok validate_uid($between_uid), "\$between_uid is valid again $there"; ok validate_uid($target_uid), "\$target_uid is valid again $there"; ok validate_uid($above_uid), "\$above_uid is still valid $there"; return $uplevel_uid; }->(); ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; ok validate_uid($between_uid), "\$between_uid is valid again $there"; ok validate_uid($target_uid), "\$target_uid is valid again $there"; ok validate_uid($above_uid), "\$above_uid is still valid $there"; return $uplevel_uid; }->(); ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; ok validate_uid($target_uid), "\$target_uid is valid again $there"; ok validate_uid($above_uid), "\$above_uid is still valid $there"; return $uplevel_uid; }->(); ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; ok validate_uid($above_uid), "\$above_uid is still valid $there"; sub { my $here = uid; my $there = "in a new sub at replacing the target"; ok !validate_uid($uplevel_uid), "\$uplevel_uid is no longer valid $there"; ok validate_uid($above_uid), "\$above_uid is still valid $there"; isnt $here, $uplevel_uid, "\$here != \$uplevel_uid $there"; is uid(UP), $above_uid, "uid(UP) == \$above_uid $there"; }->(); }->(); } for my $run (1, 2) { sub { my $first_sub = uid; my $there = "in the first sub (run $run)"; my $invalid = 'temporarily invalid'; uplevel { my $first_uplevel = uid; my $there = "in the first uplevel (run $run)"; ok !validate_uid($first_sub), "\$first_sub is $invalid $there"; ok validate_uid($first_uplevel), "\$first_uplevel is valid $there"; isnt $first_uplevel, $first_sub, "\$first_uplevel != \$first_sub $there"; isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there"; my ($second_sub, $second_uplevel) = sub { my $second_sub = uid; my $there = "in the second sub (run $run)"; my $second_uplevel = uplevel { my $second_uplevel = uid; my $there = "in the second uplevel (run $run)"; ok !validate_uid($first_sub), "\$first_sub is $invalid $there"; ok validate_uid($first_uplevel), "\$first_uplevel is valid $there"; ok !validate_uid($second_sub), "\$second_sub is $invalid $there"; ok validate_uid($second_uplevel), "\$second_uplevel is valid $there"; isnt $second_uplevel, $second_sub, "\$second_uplevel != \$second_sub $there"; is uid(UP), $first_uplevel, "uid(UP) == \$first_uplevel $there"; return $second_uplevel; }; return $second_sub, $second_uplevel; }->(); ok validate_uid($first_uplevel), "\$first_uplevel is still valid $there"; ok !validate_uid($second_sub), "\$second_sub is no longer valid $there"; ok !validate_uid($second_uplevel), "\$second_uplevel is no longer valid $there"; uplevel { my $third_uplevel = uid; my $there = "in the third uplevel (run $run)"; ok !validate_uid($first_uplevel), "\$first_uplevel is $invalid $there"; ok !validate_uid($second_sub), "\$second_sub is no longer valid $there"; ok !validate_uid($second_uplevel), "\$second_uplevel is no longer valid $there"; ok validate_uid($third_uplevel), "\$third_uplevel is valid $there"; isnt $third_uplevel, $first_uplevel, "\$third_uplevel != \$first_uplevel $there"; isnt $third_uplevel, $second_sub, "\$third_uplevel != \$second_sub $there"; isnt $third_uplevel, $second_uplevel, "\$third_uplevel != \$second_uplevel $there"; isnt uid(UP), $first_sub, "uid(UP) != \$first_sub $there"; } } }->(); } Scope-Upper-0.29/t/79-uid-threads.t000644 000765 000024 00000001701 12557756555 017542 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'Scope::Upper' => 'Scope::Upper::SU_THREADSAFE()' ], 'usleep', ); use Test::Leaner; use Scope::Upper qw; my $top = uid; sub cb { my $tid = threads->tid(); my $here = uid; my $up; { $up = uid HERE; is uid(UP), $here, "uid(UP) == \$here in block (in thread $tid)"; } is uid(UP), $top, "uid(UP) == \$top (in thread $tid)"; usleep rand(2.5e5); ok validate_uid($here), "\$here is valid (in thread $tid)"; ok !validate_uid($up), "\$up is no longer valid (in thread $tid)"; return $here; } my %uids; my $threads = 0; for my $thread (map spawn(\&cb), 1 .. 30) { my $tid = $thread->tid; my $uid = $thread->join; if (defined $uid) { ++$threads; ++$uids{$uid}; ok !validate_uid($uid), "\$here is no longer valid (out of thread $tid)"; } } is scalar(keys %uids), $threads, 'all the UIDs were different'; done_testing; Scope-Upper-0.29/t/81-stress-level.t000644 000765 000024 00000001474 12500306324 017726 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; use Scope::Upper::TestGenerator; local $Scope::Upper::TestGenerator::call = sub { my ($height, $level, $i) = @_; $level = $level ? 'UP ' x $level : 'HERE'; return [ "reap \\&check => $level;\n" ]; }; local $Scope::Upper::TestGenerator::test = sub { my ($height, $level, $i) = @_; my $j = $i < $height - $level ? 1 : 'undef'; return "verbose_is(\$main::y, $j, 'y h=$height, l=$level, i=$i');\n"; }; our ($x, $y, $testcase); sub check { $y = 0 unless defined $y; ++$y } for my $level (0 .. 4) { for my $height ($level + 1 .. $level + 2) { my $tests = Scope::Upper::TestGenerator::gen($height, $level); for $testcase (@$tests) { $x = $y = undef; eval $testcase; diag $@ if $@; } } } Scope-Upper-0.29/t/84-stress-unwind.t000644 000765 000024 00000005600 12500306324 020121 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; # @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in # scalar context on perl 5.8.5 and below. sub list { wantarray ? @_ : $_[$#_] } my @blocks = ( [ 'sub { my $next = shift;', '}->($next, @_)' ], [ 'eval {', '}' ], ); my @contexts = ( [ '', '; ()', 'v' ], [ 'scalar(', ')', 's' ], [ 'list(', ')', 'l' ], ); sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ } our @stack; our @pre; # Don't put closures in empty pads on 5.6. my $dummy; my $capture_outer_pad = "$]" < 5.008 ? "++\$dummy;" : ''; my @test_frames; for my $block (@blocks) { for my $context (@contexts) { my $source = <<"FRAME"; sub { my \$next = shift; $capture_outer_pad $block->[0] unshift \@stack, HERE; $context->[0] (\@{shift \@pre}, \$next->[0]->(\@_)) $context->[1] $block->[1] } FRAME my $code; { local $@; $code = do { no warnings 'void'; eval $source; }; my $err = $@; chomp $err; die "$err. Source was :\n$source\n" if $@; } push @test_frames, [ $code, $source, $context->[2] ]; } } my @targets = ( [ sub { my $depth = pop; unshift @stack, HERE; unwind(@_ => $stack[$depth]); }, 'target context from HERE' ], [ sub { my $depth = pop; unwind(@_ => SCOPE($depth == 0 ? 0 : (2 * ($depth - 1) + 1))); }, 'target context from SCOPE' ], ); my $seed = 0; for my $args ([ ], [ 'A' ], [ qw ]) { my @args = @$args; for my $frame0 (@test_frames) { for my $frame1 (@test_frames) { for my $frame2 (@test_frames) { my $max_depth = 3; $seed += 5; # Coprime with $max_depth my @prepend; for (1 .. $max_depth) { ++$seed; my $i = $seed + $_; my $l = $seed % $max_depth - 1; push @prepend, [ $i .. ($i + $l) ]; } my $prepend_str = join ' ', map { '[' . join(' ', @$_) . ']' } @prepend; for my $depth (0 .. $max_depth) { my $exp = do { my @cxts = map $_->[2], $frame0, $frame1, $frame2; my @exp = @args; for (my $i = $depth + 1; $i <= $max_depth; ++$i) { my $c = $cxts[$max_depth - $i]; if ($c eq 'v') { @exp = (); } elsif ($c eq 's') { @exp = @exp ? $exp[-1] : undef; } else { unshift @exp, @{$prepend[$max_depth - $i]}; } } linearize @exp; }; for my $target (@targets) { local @stack; local @pre = @prepend; my @res = $frame0->[0]->($frame1, $frame2, $target, @args, $depth); my $got = linearize @res; if ($got ne $exp) { diag <[1] $frame1->[1] $frame2->[1] $target->[1] ==== vvvvv Errors vvvvvv === DIAG } is $got, $exp, "unwind to depth $depth with args [@args] and prepending $prepend_str"; } } } } } } Scope-Upper-0.29/t/85-stress-yield.t000644 000765 000024 00000005756 12557733452 017762 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; # @_[0 .. $#_] also ought to work, but it sometimes evaluates to nonsense in # scalar context on perl 5.8.5 and below. sub list { wantarray ? @_ : $_[$#_] } my @blocks = ( [ 'do {', '}' ], [ '(list map {', # map in scalar context yields the number of elements '} 1)' ], [ 'sub { my $next = shift;', '}->($next, @_)' ], [ 'eval {', '}' ], ); my @contexts = ( [ '', '; ()', 'v' ], [ 'scalar(', ')', 's' ], [ 'list(', ')', 'l' ], ); sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ } our @stack; our @pre; # Don't put closures in empty pads on 5.6. my $dummy; my $capture_outer_pad = "$]" < 5.008 ? "++\$dummy;" : ''; my @test_frames; for my $block (@blocks) { for my $context (@contexts) { my $source = <<"FRAME"; sub { my \$next = shift; $capture_outer_pad $block->[0] unshift \@stack, HERE; $context->[0] (\@{shift \@pre}, \$next->[0]->(\@_)) $context->[1] $block->[1] } FRAME my $code; { local $@; $code = do { no warnings 'void'; eval $source; }; my $err = $@; chomp $err; die "$err. Source was :\n$source\n" if $@; } push @test_frames, [ $code, $source, $context->[2] ]; } } my @targets = ( [ sub { my $depth = pop; unshift @stack, HERE; yield(@_ => $stack[$depth]); }, 'target context from HERE' ], [ sub { my $depth = pop; yield(@_ => SCOPE($depth == 0 ? 0 : (2 * ($depth - 1) + 1))); }, 'target context from SCOPE' ], ); my $seed = 0; for my $args ([ ], [ 'A' ], [ qw ]) { my @args = @$args; for my $frame0 (@test_frames) { for my $frame1 (@test_frames) { for my $frame2 (@test_frames) { my $max_depth = 3; $seed += 5; # Coprime with $max_depth my @prepend; for (1 .. $max_depth) { ++$seed; my $i = $seed + $_; my $l = $seed % $max_depth - 1; push @prepend, [ $i .. ($i + $l) ]; } my $prepend_str = join ' ', map { '[' . join(' ', @$_) . ']' } @prepend; for my $depth (0 .. $max_depth) { my $exp = do { my @cxts = map $_->[2], $frame0, $frame1, $frame2; my @exp = @args; for (my $i = $depth + 1; $i <= $max_depth; ++$i) { my $c = $cxts[$max_depth - $i]; if ($c eq 'v') { @exp = (); } elsif ($c eq 's') { @exp = @exp ? $exp[-1] : undef; } else { unshift @exp, @{$prepend[$max_depth - $i]}; } } linearize @exp; }; for my $target (@targets) { local @stack; local @pre = @prepend; my @res = $frame0->[0]->($frame1, $frame2, $target, @args, $depth); my $got = linearize @res; if ($got ne $exp) { diag <[1] $frame1->[1] $frame2->[1] $target->[1] ==== vvvvv Errors vvvvvv === DIAG } is $got, $exp, "yield to depth $depth with args [@args] and prepending $prepend_str"; } } } } } } Scope-Upper-0.29/t/86-stress-uplevel.t000644 000765 000024 00000005503 12500306324 020275 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner; use Scope::Upper qw; my $n = 1_000; plan tests => 3 + $n * (6 + 3); my $period1 = 100; my $period2 = 10; my $shift = 10; my $amp = 10; sub PI () { CORE::atan2(0, -1) } sub depth { my $depth = 0; while (1) { my @c = caller($depth); last unless @c; ++$depth; } return $depth - 1; } sub cap { my ($depth, $top) = @_; $depth <= 0 ? 1 : $depth >= $top ? $top - 1 : $depth; } sub base_depth { cap($shift + int($amp * sin(2 * PI * $_[0] / $period1)), 2 * $shift + 1); } sub uplevel_depth { my ($base_depth, $i) = @_; my $h = int($base_depth / 2); cap($h + int($h * sin(2 * PI * $i / $period2)), $base_depth); } sub rec_basic { my ($base_depth, $uplevel_depth, $desc, $i) = @_; if ($i < $base_depth) { $i, rec_basic($base_depth, $uplevel_depth, $desc, $i + 1); } else { is depth(), $base_depth+1, "$desc: depth before uplevel"; my $ret = uplevel { is depth(), $base_depth+1-$uplevel_depth, "$desc: depth inside uplevel"; is "@_", "$base_depth $uplevel_depth", "$desc: arguments"; -$uplevel_depth; } @_[0, 1], CALLER($uplevel_depth); is depth(), $base_depth+1, "$desc: depth after uplevel"; $ret; } } sub rec_die { my ($base_depth, $uplevel_depth, $desc, $i) = @_; if ($i < $base_depth) { local $@; my $ret; if ($i % 2) { $ret = eval q< rec_die($base_depth, $uplevel_depth, $desc, $i + 1) > } else { $ret = eval { rec_die($base_depth, $uplevel_depth, $desc, $i + 1) } } return $@ ? $@ : $ret ? $ret : undef; } else { my $cxt = SUB; { my $n = $uplevel_depth; while ($n) { $cxt = SUB UP $cxt; $n--; } } my $ret = uplevel { is HERE, $cxt, "$desc: context inside uplevel"; die "XXX @_"; } @_[0, 1], $cxt; $ret; } } my $die_line = __LINE__-6; is depth(), 0, 'check top depth'; is sub { depth() }->(), 1, 'check subroutine call depth'; is do { local $@; eval { depth() } }, 1, 'check eval block depth'; for my $i (1 .. $n) { my $base_depth = base_depth($i); my $uplevel_depth = uplevel_depth($base_depth, $i); { my $desc = "basic $base_depth $uplevel_depth"; my @ret = rec_basic($base_depth, $uplevel_depth, $desc, 0); is depth(), 0, "$desc: depth outside"; is_deeply \@ret, [ 0 .. $base_depth-1, -$uplevel_depth ], "$desc: returned values"; } { ++$base_depth; my $desc = "die $base_depth $uplevel_depth"; my $err = rec_die($base_depth, $uplevel_depth, $desc, 0); is depth(), 0, "$desc: depth outside"; like $err, qr/^XXX $base_depth $uplevel_depth at \Q$0\E line $die_line/, "$desc: correct error"; } } Scope-Upper-0.29/t/87-stress-uid.t000644 000765 000024 00000002126 12557727761 017431 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner 'no_plan'; use Scope::Upper qw; my $max_level = 10; our $inner_uplevels; sub rec { my $n = shift; my $level = shift; my $target = shift; my @uids = @_; if ($n > 0) { my @args = ($n - 1 => ($level, $target) => @uids); if ($inner_uplevels) { return uplevel { rec(@args, uid()); }; } else { return rec(@args, uid()); } } my $desc = "level=$level, target=$target, inner_uplevels=$inner_uplevels"; uplevel { for my $i (1 .. $target) { my $j = $level - $i; ok !validate_uid($uids[$j]), "UID $j is invalid for $desc"; } for my $i ($target + 1 .. $level) { my $j = $level - $i; ok validate_uid($uids[$j]), "UID $j is valid for $desc"; } } CALLER($target); } { local $inner_uplevels = 0; for my $level (1 .. $max_level) { for my $target (1 .. $level) { rec($level => ($level, $target)); } } } { local $inner_uplevels = 1; for my $level (1 .. $max_level) { for my $target (1 .. $level) { rec($level => ($level, $target)); } } } Scope-Upper-0.29/t/lib/000755 000765 000024 00000000000 12725253617 015442 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/t/lib/Scope/000755 000765 000024 00000000000 12725253617 016513 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/t/lib/Test/000755 000765 000024 00000000000 12725253617 016361 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/t/lib/VPIT/000755 000765 000024 00000000000 12725253617 016224 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000034356 12557756555 021053 0ustar00vincentstaff000000 000000 package VPIT::TestHelpers; use strict; use warnings; use Config (); =head1 NAME VPIT::TestHelpers =head1 SYNTAX use VPIT::TestHelpers ( feature1 => \@feature1_args, feature2 => \@feature2_args, ); =cut sub export_to_pkg { my ($subs, $pkg) = @_; while (my ($name, $code) = each %$subs) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } return 1; } sub sanitize_prefix { my $prefix = shift; if (defined $prefix) { if (length $prefix and $prefix !~ /_$/) { $prefix .= '_'; } } else { $prefix = ''; } return $prefix; } my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); my %features = ( threads => \&init_threads, usleep => \&init_usleep, run_perl => \&init_run_perl, capture => \&init_capture, ); sub import { shift; my @opts = @_; my %exports = %default_exports; for (my $i = 0; $i <= $#opts; ++$i) { my $feature = $opts[$i]; next unless defined $feature; my $args; if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { ++$i; $args = $opts[$i]; } else { $args = [ ]; } my $handler = $features{$feature}; die "Unknown feature '$feature'" unless defined $handler; my %syms = $handler->(@$args); $exports{$_} = $syms{$_} for sort keys %syms; } export_to_pkg \%exports => scalar caller; } my $test_sub = sub { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return $glob ? *$glob{CODE} : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } =head1 FEATURES =head2 C =over 4 =item * Import : use VPIT::TestHelpers run_perl => [ $p ] where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : none =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub fresh_perl_env (&) { my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; my $ld_name = $Config::Config{ldlibpthname}; my $ldlibpth = $ENV{$ld_name}; local %ENV; $ENV{$ld_name} = $ldlibpth if defined $ldlibpth; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; my $perl = $^X; unless (-e $perl and -x $perl) { $perl = $Config::Config{perlpath}; unless (-e $perl and -x $perl) { return undef; } } return $handler->($perl, '-T', map("-I$_", @INC)); } sub init_run_perl { my $p = sanitize_prefix(shift); return ( run_perl => \&run_perl, "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, ); } sub run_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, '-e', $code; }; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers capture => [ $p ]; where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - Neither VMS nor OS/2 =item - L =item - L =item - L =item - On MSWin32 : L =back =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub init_capture { my $p = sanitize_prefix(shift); skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; load_or_skip_all 'IO::Handle', '0', [ ]; load_or_skip_all 'IO::Select', '0', [ ]; load_or_skip_all 'IPC::Open3', '0', [ ]; if ($^O eq 'MSWin32') { load_or_skip_all 'Socket', '0', [ ]; } return ( capture => \&capture, "${p}CAPTURE_FAILED" => \&capture_failed_msg, capture_perl => \&capture_perl, "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } # Inspired from IPC::Cmd sub capture { my @cmd = @_; my $want = wantarray; my $fail = sub { my $err = $!; my $ext_err = $^O eq 'MSWin32' ? $^E : undef; my $syscall = shift; my $args = join ', ', @_; my $msg = "$syscall($args) failed: "; if (defined $err) { no warnings 'numeric'; my ($err_code, $err_str) = (int $err, "$err"); $msg .= "$err_str ($err_code)"; } if (defined $ext_err) { no warnings 'numeric'; my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); $msg .= ", $ext_err_str ($ext_err_code)"; } die "$msg\n"; }; my ($status, $content_out, $content_err); local $@; my $ok = eval { my ($pid, $out, $err); if ($^O eq 'MSWin32') { my $pipe = sub { socketpair $_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC or $fail->(qw); shutdown $_[0], 1 or $fail->(qw); shutdown $_[1], 0 or $fail->(qw); return 1; }; local (*IN_R, *IN_W); local (*OUT_R, *OUT_W); local (*ERR_R, *ERR_W); $pipe->(*IN_R, *IN_W); $pipe->(*OUT_R, *OUT_W); $pipe->(*ERR_R, *ERR_W); $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); close *IN_W or $fail->(qw); $out = *OUT_R; $err = *ERR_R; } else { my $in = IO::Handle->new; $out = IO::Handle->new; $out->autoflush(1); $err = IO::Handle->new; $err->autoflush(1); $pid = IPC::Open3::open3($in, $out, $err, @cmd); close $in; } # Forward signals to the child (except SIGKILL) my %sig_handlers; foreach my $s (keys %SIG) { $sig_handlers{$s} = sub { kill "$s" => $pid; $SIG{$s} = $sig_handlers{$s}; }; } local $SIG{$_} = $sig_handlers{$_} for keys %SIG; unless ($want) { close $out or $fail->(qw); close $err or $fail->(qw); waitpid $pid, 0; $status = $?; return 1; } my $sel = IO::Select->new(); $sel->add($out, $err); my $fd_out = fileno $out; my $fd_err = fileno $err; my %contents; $contents{$fd_out} = ''; $contents{$fd_err} = ''; while (my @ready = $sel->can_read) { for my $fh (@ready) { my $buf; my $bytes_read = sysread $fh, $buf, 4096; if (not defined $bytes_read) { $fail->('sysread', 'fd(' . fileno($fh) . ')'); } elsif ($bytes_read) { $contents{fileno($fh)} .= $buf; } else { $sel->remove($fh); close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); last unless $sel->count; } } } waitpid $pid, 0; $status = $?; if ($^O eq 'MSWin32') { # Manual CRLF translation that couldn't be done with sysread. s/\x0D\x0A/\n/g for values %contents; } $content_out = $contents{$fd_out}; $content_err = $contents{$fd_err}; 1; }; if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err and $content_err =~ /^open3/) { # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 # could be reported to STDERR instead of being propagated, so work around # this. $ok = 0; $@ = $content_err; } if ($ok) { return ($status, $content_out, $content_err); } else { my $err = $@; chomp $err; return (undef, $err); } } sub capture_failed_msg { my $details = shift; my $msg = 'Could not capture command output'; $msg .= " ($details)" if defined $details; return $msg; } sub capture_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my @perl = @_; capture @perl, '-e', $code; }; } sub capture_perl_failed_msg { my $details = shift; my $msg = 'Could not capture perl output'; $msg .= " ($details)" if defined $details; return $msg; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers threads => [ $pkg, $threadsafe_var, $force_var ]; where : =over 8 =item - C<$pkg> is the target package name that will be exercised by this test ; =item - C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; =item - C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). =back =item * Dependencies : =over 8 =item - C 5.13.4 =item - L =item - L 1.67 =item - L 1.14 =back =item * Exports : =over 8 =item - C =back =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; 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; Scope-Upper-0.29/t/lib/Test/Leaner.pm000644 000765 000024 00000045374 12557732357 020150 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 Scope-Upper-0.29/t/lib/Scope/Upper/000755 000765 000024 00000000000 12725253617 017606 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/t/lib/Scope/Upper/TestGenerator.pm000644 000765 000024 00000004340 12553745561 022736 0ustar00vincentstaff000000 000000 package Scope::Upper::TestGenerator; use strict; use warnings; our ($call, $test, $allblocks); our $local_var = '$x'; our $local_decl = sub { my $x = $_[3]; return "local $local_var = $x;\n"; }; our $local_cond = sub { my $x = $_[3]; return defined $x ? "($local_var eq $x)" : "(!defined($local_var))"; }; our $local_test = sub { my ($height, $level, $i, $x) = @_; my $cond = $local_cond->(@_); return "ok($cond, 'local h=$height, l=$level, i=$i');\n"; }; my @blocks = ( [ '{', '}' ], [ 'sub {', '}->();' ], [ 'do {', '};' ], [ 'eval {', '};' ], [ 'for (1) {', '}' ], [ 'eval q[', '];' ], ); push @blocks, [ 'given (1) {', '}' ] if "$]" >= 5.010_001; my %exports = ( verbose_is => \&verbose_is, ); sub import { if ("$]" >= 5.017_011) { require warnings; warnings->unimport('experimental::smartmatch'); } if ("$]" >= 5.010_001) { require feature; feature->import('switch'); } my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } @blocks = map [ map "$_\n", @$_ ], @blocks; sub verbose_is ($$;$) { my ($a, $b, $desc) = @_; if (defined $::testcase and (defined $b) ? (not defined $a or $a ne $b) : defined $a) { Test::Leaner::diag(< $#blocks or $j < 0; return [ map "$_\n", @{$blocks[$j]} ]; } sub gen { my ($height, $level, $i, $x) = @_; if (@_ == 2) { $i = 0; push @_, $i; } return $call->(@_) if $height < $i; my @res; my @blks = $allblocks ? @blocks : _block(@_); my $up = gen($height, $level, $i + 1, $x); my $t = $test->(@_); my $loct = $local_test->(@_); for my $base (@$up) { for my $blk (@blks) { push @res, join '', $blk->[0], $base, $t, $loct, $blk->[1]; } } $_[3] = $x = $i + 1; $up = gen($height, $level, $i + 1, $x); $t = $test->(@_); my $locd = $local_decl->(@_); $loct = $local_test->(@_); for my $base (@$up) { for my $blk (@blks) { push @res, join '', $blk->[0], $locd, $base, $t, $loct, $blk->[1]; } } return \@res; } 1; Scope-Upper-0.29/samples/bench_uplevel.pl000644 000765 000024 00000002712 12500306324 021230 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use blib; use Benchmark qw; use Scope::Upper qw<:words>; BEGIN { *uplevel_xs = \&Scope::Upper::uplevel } use Sub::Uplevel; BEGIN { *uplevel_pp = \&Sub::Uplevel::uplevel } sub void { } sub foo_t { void { } } sub foo_pp { uplevel_pp(0, sub { }) } sub foo_xs { uplevel_xs { } } print "\nuplevel to current scope:\n"; cmpthese -1, { tare => sub { foo_t() }, pp => sub { foo_pp() }, xs => sub { foo_xs() }, }; sub bar_1_t { bar_2_t() } sub bar_2_t { void() } sub bar_1_pp { bar_2_pp() } sub bar_2_pp { uplevel_pp(1, sub { }) } sub bar_1_xs { bar_2_xs() } sub bar_2_xs { uplevel_xs { } UP } print "\nuplevel to one scope above:\n"; cmpthese -1, { tare => sub { bar_2_t() }, pp => sub { bar_2_pp() }, xs => sub { bar_2_xs() }, }; sub hundred { 1 .. 100 } sub baz_t { hundred() } sub baz_pp { uplevel_pp(0, sub { 1 .. 100 }) } sub baz_xs { uplevel_xs { 1 .. 100 } } print "\nreturning 100 values:\n"; cmpthese -1, { tare => sub { my @r = baz_t() }, pp => sub { my @r = baz_pp() }, xs => sub { my @r = baz_xs() }, }; my $n = 10_000; my $tare_code = "sub { my \@c; \@c = caller(0) for 1 .. $n }->()"; print "\ncaller() slowdown:\n"; cmpthese 30, { tare => sub { system { $^X } $^X, '-e', "use blib; use List::Util; $tare_code" }, pp => sub { system { $^X } $^X, '-e', "use blib; use Sub::Uplevel; $tare_code" }, xs => sub { system { $^X } $^X, '-e', "use blib; use Scope::Upper; $tare_code" }, } Scope-Upper-0.29/samples/tag.pl000644 000765 000024 00000002370 12500306324 017170 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use blib; package Scope; use Scope::Upper qw; sub new { my ($class, $name) = @_; localize '$tag' => bless({ name => $name }, $class) => UP; reap { print Scope->tag->name, ": end\n" } UP; } # Get the tag stored in the caller namespace sub tag { my $l = 0; my $pkg = __PACKAGE__; $pkg = caller $l++ while $pkg eq __PACKAGE__; no strict 'refs'; ${$pkg . '::tag'}; } sub name { shift->{name} } # Locally capture warnings and reprint them with the name prefixed sub catch { localize_elem '%SIG', '__WARN__' => sub { print Scope->tag->name, ': ', @_; } => UP; } # Locally clear @INC sub private { for (reverse 0 .. $#INC) { # First UP is the for loop, second is the sub boundary localize_delete '@INC', $_ => UP UP; } } package UserLand; { Scope->new("top"); # initializes $UserLand::tag { Scope->catch; my $one = 1 + undef; # prints "top: Use of uninitialized value..." { Scope->private; eval { delete $INC{"Cwd.pm"}; require Cwd }; # blib loads Cwd print $@; # prints "Can't locate Cwd.pm in @INC (@INC contains:) at..." } require Cwd; # loads Cwd.pm } } # prints "top: done" Scope-Upper-0.29/samples/try.pl000644 000765 000024 00000001435 12500306324 017234 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use blib; use Scope::Upper qw; sub try (&) { my @result = shift->(); my $cx = SUB UP; # Point to the sub above this one unwind +(want_at($cx) ? @result : scalar @result) => $cx; } sub zap { try { my @things = qw; return @things; # returns to try() and then outside zap() }; print "NOT REACHED\n"; } my @stuff = zap(); # @stuff contains qw my $stuff = zap(); # $stuff contains 3 print "zap() returns @stuff in list context and $stuff in scalar context\n"; { package Uplevel; use Scope::Upper qw; sub target { faker(@_); } sub faker { uplevel { my $sub = (caller 0)[3]; print "$_[0] from $sub()\n"; } @_ => CALLER(1); } target('hello'); # "hello from Uplevel::target()" } Scope-Upper-0.29/lib/Scope/000755 000765 000024 00000000000 12725253617 016250 5ustar00vincentstaff000000 000000 Scope-Upper-0.29/lib/Scope/Upper.pm000644 000765 000024 00000063321 12725253371 017703 0ustar00vincentstaff000000 000000 package Scope::Upper; use 5.006_001; use strict; use warnings; =head1 NAME Scope::Upper - Act on upper scopes. =head1 VERSION Version 0.29 =cut our $VERSION; BEGIN { $VERSION = '0.29'; } =head1 SYNOPSIS L, L, L, L and L : package Scope; use Scope::Upper qw< reap localize localize_elem localize_delete :words >; sub new { my ($class, $name) = @_; localize '$tag' => bless({ name => $name }, $class) => UP; reap { print Scope->tag->name, ": end\n" } UP; } # Get the tag stored in the caller namespace sub tag { my $l = 0; my $pkg = __PACKAGE__; $pkg = caller $l++ while $pkg eq __PACKAGE__; no strict 'refs'; ${$pkg . '::tag'}; } sub name { shift->{name} } # Locally capture warnings and reprint them with the name prefixed sub catch { localize_elem '%SIG', '__WARN__' => sub { print Scope->tag->name, ': ', @_; } => UP; } # Locally clear @INC sub private { for (reverse 0 .. $#INC) { # First UP is the for loop, second is the sub boundary localize_delete '@INC', $_ => UP UP; } } ... package UserLand; { Scope->new("top"); # initializes $UserLand::tag { Scope->catch; my $one = 1 + undef; # prints "top: Use of uninitialized value..." { Scope->private; eval { require Cwd }; print $@; # prints "Can't locate Cwd.pm in @INC } # (@INC contains:) at..." require Cwd; # loads Cwd.pm } } # prints "top: done" L and L : package Try; use Scope::Upper qw; sub try (&) { my @result = shift->(); my $cx = SUB UP; # Point to the sub above this one unwind +(want_at($cx) ? @result : scalar @result) => $cx; } ... sub zap { try { my @things = qw; return @things; # returns to try() and then outside zap() # not reached }; # not reached } my @stuff = zap(); # @stuff contains qw my $stuff = zap(); # $stuff contains 3 L : package Uplevel; use Scope::Upper qw; sub target { faker(@_); } sub faker { uplevel { my $sub = (caller 0)[3]; print "$_[0] from $sub()"; } @_ => CALLER(1); } target('hello'); # "hello from Uplevel::target()" L and L : use Scope::Upper qw; my $uid; { $uid = uid(); { if ($uid eq uid(UP)) { # yes ... } if (validate_uid($uid)) { # yes ... } } } if (validate_uid($uid)) { # no ... } =head1 DESCRIPTION This module lets you defer actions I that will take place when the control flow returns into an upper scope. Currently, you can: =over 4 =item * hook an upper scope end with L ; =item * localize variables, array/hash values or deletions of elements in higher contexts with respectively L, L and L ; =item * return values immediately to an upper level with L, L and L ; =item * gather information about an upper context with L and L ; =item * execute a subroutine in the setting of an upper subroutine stack frame with L ; =item * uniquely identify contexts with L and L. =back =head1 FUNCTIONS In all those functions, C<$context> refers to the target scope. You have to use one or a combination of L to build the C<$context> passed to these functions. This is needed in order to ensure that the module still works when your program is ran in the debugger. The only thing you can assume is that it is an I indicator of the frame, which means that you can safely store it at some point and use it when needed, and it will still denote the original scope. =cut BEGIN { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); } =head2 C reap { ... }; reap { ... } $context; &reap($callback, $context); Adds a destructor that calls C<$callback> (in void context) when the upper scope represented by C<$context> ends. =head2 C localize $what, $value; localize $what, $value, $context; Introduces a C delayed to the time of first return into the upper scope denoted by C<$context>. C<$what> can be : =over 4 =item * A glob, in which case C<$value> can either be a glob or a reference. L follows then the same syntax as C. For example, if C<$value> is a scalar reference, then the C slot of the glob will be set to C<$$value> - just like C sets C<$x> to C<1>. =item * A string beginning with a sigil, representing the symbol to localize and to assign to. If the sigil is C<'$'>, L follows the same syntax as C, i.e. C<$value> isn't dereferenced. For example, localize '$x', \'foo' => HERE; will set C<$x> to a reference to the string C<'foo'>. Other sigils (C<'@'>, C<'%'>, C<'&'> and C<'*'>) require C<$value> to be a reference of the corresponding type. When the symbol is given by a string, it is resolved when the actual localization takes place and not when L is called. Thus, if the symbol name is not qualified, it will refer to the variable in the package where the localization actually takes place and not in the one where the L call was compiled. For example, { package Scope; sub new { localize '$tag', $_[0] => UP } } { package Tool; { Scope->new; ... } } will localize C<$Tool::tag> and not C<$Scope::tag>. If you want the other behaviour, you just have to specify C<$what> as a glob or a qualified name. Note that if C<$what> is a string denoting a variable that wasn't declared beforehand, the relevant slot will be vivified as needed and won't be deleted from the glob when the localization ends. This situation never arises with C because it only compiles when the localized variable is already declared. Although I believe it shouldn't be a problem as glob slots definedness is pretty much an implementation detail, this behaviour may change in the future if proved harmful. =back =head2 C localize_elem $what, $key, $value; localize_elem $what, $key, $value, $context; Introduces a C or C delayed to the time of first return into the upper scope denoted by C<$context>. Unlike L, C<$what> must be a string and the type of localization is inferred from its sigil. The two only valid types are array and hash ; for anything besides those, L will throw an exception. C<$key> is either an array index or a hash key, depending of which kind of variable you localize. If C<$what> is a string pointing to an undeclared variable, the variable will be vivified as soon as the localization occurs and emptied when it ends, although it will still exist in its glob. =head2 C localize_delete $what, $key; localize_delete $what, $key, $context; Introduces the deletion of a variable or an array/hash element delayed to the time of first return into the upper scope denoted by C<$context>. C<$what> can be: =over 4 =item * A glob, in which case C<$key> is ignored and the call is equivalent to C. =item * A string beginning with C<'@'> or C<'%'>, for which the call is equivalent to respectively C and C. =item * A string beginning with C<'&'>, which more or less does C in the upper scope. It's actually more powerful, as C<&func> won't even C anymore. C<$key> is ignored. =back =head2 C unwind; unwind @values, $context; Returns C<@values> I the subroutine, eval or format context pointed by or just above C<$context>, and immediately restarts the program flow at this point - thus effectively returning C<@values> to an upper scope. If C<@values> is empty, then the C<$context> parameter is optional and defaults to the current context (making the call equivalent to a bare C) ; otherwise it is mandatory. The upper context isn't coerced onto C<@values>, which is hence always evaluated in list context. This means that my $num = sub { my @a = ('a' .. 'z'); unwind @a => HERE; # not reached }->(); will set C<$num> to C<'z'>. You can use L to handle these cases. =head2 C yield; yield @values, $context; Returns C<@values> I the context pointed by or just above C<$context>, and immediately restarts the program flow at this point. If C<@values> is empty, then the C<$context> parameter is optional and defaults to the current context ; otherwise it is mandatory. L differs from L in that it can target I upper scope (besides a C substitution context) and not necessarily a sub, an eval or a format. Hence you can use it to return values from a C or a C block : my $now = do { local $@; eval { require Time::HiRes } or yield time() => HERE; Time::HiRes::time(); }; my @uniq = map { yield if $seen{$_}++; # returns the empty list from the block ... } @things; Like for L, the upper context isn't coerced onto C<@values>. You can use the fifth value returned by L to handle context coercion. =head2 C leave; leave @values; Immediately returns C<@values> from the current block, whatever it may be (besides a C substitution context). C is actually a synonym for C, while C is a synonym for C. Like for L, you can use the fifth value returned by L to handle context coercion. =head2 C my $want = want_at; my $want = want_at $context; Like L, but for the subroutine, eval or format context located at or just above C<$context>. It can be used to revise the example showed in L : my $num = sub { my @a = ('a' .. 'z'); unwind +(want_at(HERE) ? @a : scalar @a) => HERE; # not reached }->(); will rightfully set C<$num> to C<26>. =head2 C my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = context_info $context; Gives information about the context denoted by C<$context>, akin to what L provides but not limited only to subroutine, eval and format contexts. When C<$context> is omitted, it defaults to the current context. The returned values are, in order : =over 4 =item * I<(index 0)> : the namespace in use when the context was created ; =item * I<(index 1)> : the name of the file at the point where the context was created ; =item * I<(index 2)> : the line number at the point where the context was created ; =item * I<(index 3)> : the name of the subroutine called for this context, or C if this is not a subroutine context ; =item * I<(index 4)> : a boolean indicating whether a new instance of C<@_> was set up for this context, or C if this is not a subroutine context ; =item * I<(index 5)> : the context (in the sense of L) in which the context (in our sense) is executed ; =item * I<(index 6)> : the contents of the string being compiled for this context, or C if this is not an eval context ; =item * I<(index 7)> : a boolean indicating whether this eval context was created by C, or C if this is not an eval context ; =item * I<(index 8)> : the value of the lexical hints in use when the context was created ; =item * I<(index 9)> : a bit string representing the warnings in use when the context was created ; =item * I<(index 10)> : a reference to the lexical hints hash in use when the context was created (only on perl 5.10 or greater). =back =head2 C my @ret = uplevel { ...; return @ret }; my @ret = uplevel { my @args = @_; ...; return @ret } @args, $context; my @ret = &uplevel($callback, @args, $context); Executes the code reference C<$callback> with arguments C<@args> as if it were located at the subroutine stack frame pointed by C<$context>, effectively fooling C and C into believing that the call actually happened higher in the stack. The code is executed in the context of the C call, and what it returns is returned as-is by C. sub target { faker(@_); } sub faker { uplevel { map { 1 / $_ } @_; } @_ => CALLER(1); } my @inverses = target(1, 2, 4); # @inverses contains (0, 0.5, 0.25) my $count = target(1, 2, 4); # $count is 3 Note that if C<@args> is empty, then the C<$context> parameter is optional and defaults to the current context ; otherwise it is mandatory. L also implements a pure-Perl version of C. Both are identical, with the following caveats : =over 4 =item * The L implementation of C may execute a code reference in the context of B upper stack frame. The L version can only uplevel to a B stack frame, and will croak if you try to target an C or a format. =item * Exceptions thrown from the code called by this version of C will not be caught by C blocks between the target frame and the uplevel call, while they will for L's version. This means that : eval { sub { local $@; eval { sub { uplevel { die 'wut' } CALLER(2); # for Scope::Upper # uplevel(3, sub { die 'wut' }) # for Sub::Uplevel }->(); }; print "inner block: $@"; $@ and exit; }->(); }; print "outer block: $@"; will print "inner block: wut..." with L and "outer block: wut..." with L. =item * L globally overrides the Perl keyword C, while L does not. =back A simple wrapper lets you mimic the interface of L : use Scope::Upper; sub uplevel { my $frame = shift; my $code = shift; my $cxt = Scope::Upper::CALLER($frame); &Scope::Upper::uplevel($code => @_ => $cxt); } Albeit the three exceptions listed above, it passes all the tests of L. =head2 C my $uid = uid; my $uid = uid $context; Returns an unique identifier (UID) for the context (or dynamic scope) pointed by C<$context>, or for the current context if C<$context> is omitted. This UID will only be valid for the life time of the context it represents, and another UID will be generated next time the same scope is executed. my $uid; { $uid = uid; if ($uid eq uid()) { # yes, this is the same context ... } { if ($uid eq uid()) { # no, we are one scope below ... } if ($uid eq uid(UP)) { # yes, UP points to the same scope as $uid ... } } } # $uid is now invalid { if ($uid eq uid()) { # no, this is another block ... } } For example, each loop iteration gets its own UID : my %uids; for (1 .. 5) { my $uid = uid; $uids{$uid} = $_; } # %uids has 5 entries The UIDs are not guaranteed to be numbers, so you must use the C operator to compare them. To check whether a given UID is valid, you can use the L function. =head2 C my $is_valid = validate_uid $uid; Returns true if and only if C<$uid> is the UID of a currently valid context (that is, it designates a scope that is higher than the current one in the call stack). my $uid; { $uid = uid(); if (validate_uid($uid)) { # yes ... } { if (validate_uid($uid)) { # yes ... } } } if (validate_uid($uid)) { # no ... } =head1 CONSTANTS =head2 C True iff the module could have been built when thread-safety features. =head1 WORDS =head2 Constants =head3 C my $top_context = TOP; Returns the context that currently represents the highest scope. =head3 C my $current_context = HERE; The context of the current scope. =head2 Getting a context from a context For any of those functions, C<$from> is expected to be a context. When omitted, it defaults to the current context. =head3 C my $upper_context = UP; my $upper_context = UP $from; The context of the scope just above C<$from>. If C<$from> points to the top-level scope in the current stack, then a warning is emitted and C<$from> is returned (see L for details). =head3 C my $sub_context = SUB; my $sub_context = SUB $from; The context of the closest subroutine above C<$from>. If C<$from> already designates a subroutine context, then it is returned as-is ; hence C. If no subroutine context is present in the call stack, then a warning is emitted and the current context is returned (see L for details). =head3 C my $eval_context = EVAL; my $eval_context = EVAL $from; The context of the closest eval above C<$from>. If C<$from> already designates an eval context, then it is returned as-is ; hence C. If no eval context is present in the call stack, then a warning is emitted and the current context is returned (see L for details). =head2 Getting a context from a level Here, C<$level> should denote a number of scopes above the current one. When omitted, it defaults to C<0> and those functions return the same context as L. =head3 C my $context = SCOPE; my $context = SCOPE $level; The C<$level>-th upper context, regardless of its type. If C<$level> points above the top-level scope in the current stack, then a warning is emitted and the top-level context is returned (see L for details). =head3 C my $context = CALLER; my $context = CALLER $level; The context of the C<$level>-th upper subroutine/eval/format. It kind of corresponds to the context represented by C, but while e.g. C refers to the caller context, C will refer to the top scope in the current context. If C<$level> points above the top-level scope in the current stack, then a warning is emitted and the top-level context is returned (see L for details). =head2 Examples Where L fires depending on the C<$cxt> : sub { eval { sub { { reap \&cleanup => $cxt; ... } # $cxt = SCOPE(0) = HERE ... }->(); # $cxt = SCOPE(1) = UP = SUB = CALLER(0) ... }; # $cxt = SCOPE(2) = UP UP = UP SUB = EVAL = CALLER(1) ... }->(); # $cxt = SCOPE(3) = SUB UP SUB = SUB EVAL = CALLER(2) ... Where L, L and L act depending on the C<$cxt> : sub { eval { sub { { localize '$x' => 1 => $cxt; # $cxt = SCOPE(0) = HERE ... } # $cxt = SCOPE(1) = UP = SUB = CALLER(0) ... }->(); # $cxt = SCOPE(2) = UP UP = UP SUB = EVAL = CALLER(1) ... }; # $cxt = SCOPE(3) = SUB UP SUB = SUB EVAL = CALLER(2) ... }->(); # $cxt = SCOPE(4), UP SUB UP SUB = UP SUB EVAL = UP CALLER(2) = TOP ... Where L, L, L, L and L point to depending on the C<$cxt>: sub { eval { sub { { unwind @things => $cxt; # or yield @things => $cxt # or uplevel { ... } $cxt ... } ... }->(); # $cxt = SCOPE(0) = SCOPE(1) = HERE = UP = SUB = CALLER(0) ... }; # $cxt = SCOPE(2) = UP UP = UP SUB = EVAL = CALLER(1) (*) ... }->(); # $cxt = SCOPE(3) = SUB UP SUB = SUB EVAL = CALLER(2) ... # (*) Note that uplevel() will croak if you pass that scope frame, # because it cannot target eval scopes. =head1 DIAGNOSTICS =head2 C This warning is emitted when L, L or L end up pointing to a context that is above the top-level context of the current stack. It indicates that you tried to go higher than the main scope, or to point across a C method, a signal handler, an overloaded or tied method call, a C statement or a C callback. In this case, the resulting context is the highest reachable one. =head2 C This warning is emitted when you ask for an L or L context and no such scope can be found in the call stack. The resulting context is the current one. =head1 EXPORT The functions L, L, L, L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. The constant L is also only exported on request, individually or by the tags C<':consts'> and C<':all'>. Same goes for the words L, L, L, L, L, L and L that are only exported on request, individually or by the tags C<':words'> and C<':all'>. =cut use base qw; our @EXPORT = (); our %EXPORT_TAGS = ( funcs => [ qw< reap localize localize_elem localize_delete unwind yield leave want_at context_info uplevel uid validate_uid > ], words => [ qw ], consts => [ qw ], ); our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; =head1 CAVEATS It is not possible to act upon a scope that belongs to another perl 'stack', i.e. to target a scope across a C method, a signal handler, an overloaded or tied method call, a C statement or a C callback. Be careful that local variables are restored in the reverse order in which they were localized. Consider those examples: local $x = 0; { reap sub { print $x } => HERE; local $x = 1; ... } # prints '0' ... { local $x = 1; reap sub { $x = 2 } => HERE; ... } # $x is 0 The first case is "solved" by moving the C before the C, and the second by using L instead of L. The effects of L, L and L can't cross C blocks, hence calling those functions in C is deemed to be useless. This is an hopeless case because C blocks are executed once while localizing constructs should do their job at each run. However, it's possible to hook the end of the current scope compilation with L. Some rare oddities may still happen when running inside the debugger. It may help to use a perl higher than 5.8.9 or 5.10.0, as they contain some context-related fixes. Calling C to replace an L'd code frame does not work : =over 4 =item * for a C older than the 5.8 series ; =item * for a C C run with debugging flags set (as in C) ; =item * when the runloop callback is replaced by another module. =back In those three cases, L will look for a C statement in its callback and, if there is one, throw an exception before executing the code. Moreover, in order to handle C statements properly, L 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 the code executed as the result of the L call (including subroutine calls inside the callback) when a C statement is found in the L callback. Despite this shortcoming, this XS version of L should still run way faster than the pure-Perl version from L. Starting from C 5.19.4, it is unfortunately no longer possible to reliably throw exceptions from L'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 5.6.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 (core since perl 5.6.0). =head1 SEE ALSO L, L. L, L, L, L. L. L is a thin wrapper around L that gives you a continuation passing style interface to L. It's easier to use, but it requires you to have control over the scope where you want to return. 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 Scope::Upper =head1 ACKNOWLEDGEMENTS Inspired by Ricardo Signes. The reimplementation of a large part of this module for perl 5.24 was provided by David Mitchell. His work was sponsored by the Perl 5 Core Maintenance Grant from The Perl Foundation. Thanks to Shawn M. Moore for motivation. =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 Scope::Upper