Scope-Upper-0.33/ 0000755 0001750 0001750 00000000000 14160163353 012575 5 ustar vince vince Scope-Upper-0.33/Changes 0000644 0001750 0001750 00000040712 14160163127 014073 0 ustar vince vince Revision history for Scope-Upper
0.33 2021-12-20 20:30 UTC
+ Fix : [RT #114816] resources/remote/url points to web interface
META files now follow version 2.0 of the CPAN META spec.
Thanks Kent Fredric for reporting.
+ Fix : [RT #139823] : Perl 5 blead breads t/07-context_info.t
t/07-context_info.t has been hardened against warning bits
changes.
Thanks Jim Keenan and Tony Cook for reporting and contributing
a fix.
0.32 2019-07-08 12:50 UTC
+ Fix : [RT #129539] : fails with v5.27.3 and later with DEBUGGING
The module has been amended to accomodate with a change of
behaviour of a core macro.
+ Upd : Contact info.
0.31 2018-08-26 19:50 UTC
+ Fix : [RT #125931] : localized SCALAR doesn't get imported
localize '$Foo::x' => $var now properly imports $x into Foo.
Thanks Vernon Lyon for reporting.
0.30 2017-11-04 15:55 UTC
+ Fix : [RT #123481] : Compatibility with CV-in-stash optimisation
Thanks Father Chrysostomos for reporting and contributing a
patch.
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.33/lib/ 0000755 0001750 0001750 00000000000 14160163352 013342 5 ustar vince vince Scope-Upper-0.33/lib/Scope/ 0000755 0001750 0001750 00000000000 14160163352 014413 5 ustar vince vince Scope-Upper-0.33/lib/Scope/Upper.pm 0000644 0001750 0001750 00000063302 14160163315 016047 0 ustar vince vince package Scope::Upper;
use 5.006_001;
use strict;
use warnings;
=head1 NAME
Scope::Upper - Act on upper scopes.
=head1 VERSION
Version 0.33
=cut
our $VERSION;
BEGIN {
$VERSION = '0.33';
}
=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 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<< >>.
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,2017,2018,2019,2021 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
Scope-Upper-0.33/Makefile.PL 0000644 0001750 0001750 00000011275 14160162306 014552 0 ustar vince vince use 5.006_001;
use strict;
use warnings;
use ExtUtils::MakeMaker;
use Config;
if ($Config{d_cplusplus}) {
print STDERR <<'FAILPLUSPLUS';
Configuration aborted: C++ compilers are not supported
Your perl has been built with a C++ compiler, which is then handed to
XS extensions as if it were a proper C compiler. This extension is
written in C, and naturally only supports C compilers, so it cannot be
built with your perl.
Note that building perl with a C++ compiler is only supposed to be done
by core developers in order to check that the perl headers can be
included from C++ code. Its use in the wild is not supported by the
perl5 porters. If your vendor has built its perl binary with a C++
compiler, please consider reporting this issue to them.
This text will be displayed 10 seconds, and then the configuration
script will exit.
FAILPLUSPLUS
sleep 10;
exit 0;
}
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 $bug_web = "http://rt.cpan.org/Dist/Display.html?Name=$dist",
my $bug_mailto = 'bug-' . lc($dist) . '@rt.cpan.org';
my $repo_host = 'git.vpit.fr';
my @repo_path = ('perl', 'modules', "$dist.git");
my $repo_url = join '/', 'http:', '', $repo_host, @repo_path, '';
my $repo_web = "http://$repo_host/?p=" . join('%2F', @repo_path);
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 = (
'meta-spec' => {
version => '2',
url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
},
configure_requires => {
'Config' => 0,
'ExtUtils::MakeMaker' => 0,
},
build_requires => {
%BUILD_REQUIRES,
},
dynamic_config => 1,
resources => {
bugtracker => {
web => $bug_web,
mailto => $bug_mailto,
},
homepage => "http://search.cpan.org/dist/$dist/",
license => 'http://dev.perl.org/licenses/',
repository => {
type => 'git',
url => $repo_url,
web => $repo_web,
},
},
);
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.33/MANIFEST 0000644 0001750 0001750 00000002630 14160143454 013727 0 ustar vince vince 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/mem.h
xsh/threads.h
xsh/util.h
Scope-Upper-0.33/META.json 0000644 0001750 0001750 00000003231 14160163353 014215 0 ustar vince vince {
"abstract" : "Act on upper scopes.",
"author" : [
"Vincent Pit "
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010",
"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" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Exporter" : "0",
"XSLoader" : "0",
"base" : "0",
"perl" : "5.006001"
}
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"mailto" : "bug-scope-upper@rt.cpan.org",
"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" : {
"type" : "git",
"url" : "http://git.vpit.fr/perl/modules/Scope-Upper.git/",
"web" : "http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git"
}
},
"version" : "0.33",
"x_serialization_backend" : "JSON::PP version 4.06"
}
Scope-Upper-0.33/META.yml 0000644 0001750 0001750 00000001620 14160163352 014044 0 ustar vince vince ---
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:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010'
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.vpit.fr/perl/modules/Scope-Upper.git/
version: '0.33'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
Scope-Upper-0.33/README 0000644 0001750 0001750 00000065176 14160163353 013474 0 ustar vince vince NAME
Scope::Upper - Act on upper scopes.
VERSION
Version 0.33
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,2017,2018,2019,2021 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.33/samples/ 0000755 0001750 0001750 00000000000 14160163352 014240 5 ustar vince vince Scope-Upper-0.33/samples/bench_uplevel.pl 0000644 0001750 0001750 00000002712 14160162242 017407 0 ustar vince vince #!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.33/samples/tag.pl 0000644 0001750 0001750 00000002370 14160162242 015347 0 ustar vince vince #!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.33/samples/try.pl 0000644 0001750 0001750 00000001435 14160162242 015413 0 ustar vince vince #!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.33/t/ 0000755 0001750 0001750 00000000000 14160163352 013037 5 ustar vince vince Scope-Upper-0.33/t/00-load.t 0000644 0001750 0001750 00000000255 14160162242 014357 0 ustar vince vince #!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.33/t/01-import.t 0000644 0001750 0001750 00000001415 14160162242 014752 0 ustar vince vince #!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.33/t/05-words.t 0000644 0001750 0001750 00000041212 14160162242 014601 0 ustar vince vince #!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.33/t/06-want_at.t 0000644 0001750 0001750 00000002443 14160162242 015104 0 ustar vince vince #!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.33/t/07-context_info.t 0000644 0001750 0001750 00000010405 14160162242 016144 0 ustar vince vince #!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;
}
if (defined $warnings and $warnings =~ m/^\x55*$/) {
$warnings = $warnings::Bits{all};
}
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];
if (defined $exp[9] and $exp[9] =~ m/^\x55*$/) {
$exp[9] = $warnings::Bits{all};
}
is_deeply \@got, \@exp, "context_info vs caller $depth";
}
}
first();
Scope-Upper-0.33/t/09-load-threads.t 0000644 0001750 0001750 00000016773 14160162242 016034 0 ustar vince vince #!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.33/t/11-reap-level.t 0000644 0001750 0001750 00000001474 14160162242 015502 0 ustar vince vince #!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.33/t/12-reap-block.t 0000644 0001750 0001750 00000002115 14160162242 015457 0 ustar vince vince #!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.33/t/13-reap-ctl.t 0000644 0001750 0001750 00000020605 14160162242 015154 0 ustar vince vince #!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.33/t/15-reap-multi.t 0000644 0001750 0001750 00000006474 14160162242 015536 0 ustar vince vince #!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.33/t/16-reap-numerous.t 0000644 0001750 0001750 00000000507 14160162242 016251 0 ustar vince vince #!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.33/t/20-localize-target.t 0000644 0001750 0001750 00000020254 14160162242 016531 0 ustar vince vince #!perl -T
use strict;
use warnings;
use Test::More tests => 70 + 2 * 5 + 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]');
}
# Import
sub is_imported {
my ($pkg, $sig, $val) = @_;
my $exp = $sig eq '$' ? \$val : $val;
my $var = 'daffodil'; # don't use 'x' or eval will capture $main::x
my $spec = $sig . $pkg . '::' . $var;
localize $spec, $val => HERE;
{
my $desc = "localize imported ${sig}${var} to $val";
my $got = eval "package $pkg; \\${sig}${var}";
if ($@) {
fail "$desc test did not compile: $@";
} else {
is_deeply $got, $exp, $desc;
}
}
{
my $desc = "localize defined ${sig}${var} to $val";
my $got = eval "\\${sig}${pkg}::${var}";
if ($@) {
fail "$desc test did not compile: $@";
} else {
is_deeply $got, $exp, $desc;
}
}
}
{
is_imported 'Scope::Upper::Test::Mock10', '$', 0;
is_imported 'Scope::Upper::Test::Mock11', '$', \1;
is_imported 'Scope::Upper::Test::Mock12', '@', [ 2, 3 ];
is_imported 'Scope::Upper::Test::Mock13', '%', { a => 4 };
is_imported 'Scope::Upper::Test::Mock14', '&', sub { 5 };
}
# 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.33/t/21-localize-level.t 0000644 0001750 0001750 00000001441 14160162242 016350 0 ustar vince vince #!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.33/t/22-localize-block.t 0000644 0001750 0001750 00000001572 14160162242 016341 0 ustar vince vince #!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.33/t/23-localize-ctl.t 0000644 0001750 0001750 00000017011 14160162242 016025 0 ustar vince vince #!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.33/t/24-localize-magic.t 0000644 0001750 0001750 00000000764 14160162242 016333 0 ustar vince vince #!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.33/t/25-localize-multi.t 0000644 0001750 0001750 00000002062 14160162242 016377 0 ustar vince vince #!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.33/t/26-localize-numerous.t 0000644 0001750 0001750 00000000551 14160162242 017124 0 ustar vince vince #!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.33/t/30-localize_elem-target.t 0000644 0001750 0001750 00000011543 14160162242 017535 0 ustar vince vince #!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.33/t/31-localize_elem-level.t 0000644 0001750 0001750 00000002720 14160162242 017354 0 ustar vince vince #!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.33/t/32-localize_elem-block.t 0000644 0001750 0001750 00000003146 14160162242 017343 0 ustar vince vince #!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.33/t/34-localize_elem-magic.t 0000644 0001750 0001750 00000003131 14160162242 017325 0 ustar vince vince #!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.33/t/36-localize_elem-numerous.t 0000644 0001750 0001750 00000000715 14160162242 020131 0 ustar vince vince #!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.33/t/40-localize_delete-target.t 0000644 0001750 0001750 00000015456 14160162242 020065 0 ustar vince vince #!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.33/t/41-localize_delete-level.t 0000644 0001750 0001750 00000002765 14160162242 017706 0 ustar vince vince #!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.33/t/44-localize_delete-magic.t 0000644 0001750 0001750 00000003554 14160162242 017657 0 ustar vince vince #!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.33/t/46-localize_delete-numerous.t 0000644 0001750 0001750 00000000661 14160162242 020452 0 ustar vince vince #!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.33/t/50-unwind-target.t 0000644 0001750 0001750 00000001012 14160162242 016225 0 ustar vince vince #!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.33/t/51-unwind-multi.t 0000644 0001750 0001750 00000003416 14160162242 016104 0 ustar vince vince #!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.33/t/52-unwind-context.t 0000644 0001750 0001750 00000012735 14160162242 016443 0 ustar vince vince #!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.33/t/53-unwind-misc.t 0000644 0001750 0001750 00000002270 14160162242 015704 0 ustar vince vince #!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.33/t/54-unwind-threads.t 0000644 0001750 0001750 00000001407 14160162242 016405 0 ustar vince vince #!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.33/t/55-yield-target.t 0000644 0001750 0001750 00000006354 14160162242 016052 0 ustar vince vince #!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.33/t/57-yield-context.t 0000644 0001750 0001750 00000012554 14160162242 016251 0 ustar vince vince #!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.33/t/58-yield-misc.t 0000644 0001750 0001750 00000007124 14160162242 015516 0 ustar vince vince #!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.33/t/59-yield-threads.t 0000644 0001750 0001750 00000001377 14160162242 016222 0 ustar vince vince #!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.33/t/60-uplevel-target.t 0000644 0001750 0001750 00000014172 14160162242 016411 0 ustar vince vince #!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.33/t/61-uplevel-args.t 0000644 0001750 0001750 00000017777 14160162242 016076 0 ustar vince vince #!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.33/t/62-uplevel-return.t 0000644 0001750 0001750 00000014614 14160162242 016445 0 ustar vince vince #!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.33/t/63-uplevel-ctl.t 0000644 0001750 0001750 00000017071 14160162242 015711 0 ustar vince vince #!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.33/t/64-uplevel-caller.t 0000644 0001750 0001750 00000006056 14160162242 016373 0 ustar vince vince #!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.33/t/65-uplevel-multi.t 0000644 0001750 0001750 00000004457 14160162242 016267 0 ustar vince vince #!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.33/t/66-uplevel-context.t 0000644 0001750 0001750 00000001733 14160162242 016614 0 ustar vince vince #!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.33/t/67-uplevel-scope.t 0000644 0001750 0001750 00000003300 14160162242 016232 0 ustar vince vince #!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.33/t/69-uplevel-threads.t 0000644 0001750 0001750 00000002272 14160162242 016564 0 ustar vince vince #!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.33/t/70-uid-target.t 0000644 0001750 0001750 00000003261 14160162242 015514 0 ustar vince vince #!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.33/t/74-uid-validate.t 0000644 0001750 0001750 00000005565 14160162242 016034 0 ustar vince vince #!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.33/t/75-uid-uplevel.t 0000644 0001750 0001750 00000013522 14160162242 015710 0 ustar vince vince #!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.33/t/79-uid-threads.t 0000644 0001750 0001750 00000001701 14160162242 015666 0 ustar vince vince #!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.33/t/81-stress-level.t 0000644 0001750 0001750 00000001474 14160162242 016105 0 ustar vince vince #!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.33/t/84-stress-unwind.t 0000644 0001750 0001750 00000005600 14160162242 016300 0 ustar vince vince #!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.33/t/85-stress-yield.t 0000644 0001750 0001750 00000005756 14160162242 016117 0 ustar vince vince #!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.33/t/86-stress-uplevel.t 0000644 0001750 0001750 00000005503 14160162242 016454 0 ustar vince vince #!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.33/t/87-stress-uid.t 0000644 0001750 0001750 00000002126 14160162242 015560 0 ustar vince vince #!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.33/t/lib/ 0000755 0001750 0001750 00000000000 14160163352 013605 5 ustar vince vince Scope-Upper-0.33/t/lib/Scope/ 0000755 0001750 0001750 00000000000 14160163352 014656 5 ustar vince vince Scope-Upper-0.33/t/lib/Scope/Upper/ 0000755 0001750 0001750 00000000000 14160163352 015751 5 ustar vince vince Scope-Upper-0.33/t/lib/Scope/Upper/TestGenerator.pm 0000644 0001750 0001750 00000004340 14160162242 021073 0 ustar vince vince 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.33/t/lib/Test/ 0000755 0001750 0001750 00000000000 14160163352 014524 5 ustar vince vince Scope-Upper-0.33/t/lib/Test/Leaner.pm 0000644 0001750 0001750 00000045336 14160163015 016277 0 ustar vince vince 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