Scope-Upper-0.24/ 0000750 0001750 0001750 00000000000 12213574333 012571 5 ustar vince vince Scope-Upper-0.24/lib/ 0000750 0001750 0001750 00000000000 12213574333 013337 5 ustar vince vince Scope-Upper-0.24/lib/Scope/ 0000750 0001750 0001750 00000000000 12213574333 014410 5 ustar vince vince Scope-Upper-0.24/lib/Scope/Upper.pm 0000644 0001750 0001750 00000057262 12213574141 016057 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.24
=cut
our $VERSION;
BEGIN {
$VERSION = '0.24';
}
=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 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
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.
=head1 DEPENDENCIES
L 5.6.1.
A C compiler.
This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
L (core since perl 5.6.0).
=head1 SEE ALSO
L, L.
L, L, L, L.
L.
L is a thin wrapper around L that gives you a continuation passing style interface to L.
It's easier to use, but it requires you to have control over the scope where you want to return.
L.
=head1 AUTHOR
Vincent Pit, C<< >>, L.
You can contact me by mail or on C (vincent).
=head1 BUGS
Please report any bugs or feature requests to C, or through the web interface at L.
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Scope::Upper
Tests code coverage report is available at L.
=head1 ACKNOWLEDGEMENTS
Inspired by Ricardo Signes.
Thanks to Shawn M. Moore for motivation.
=head1 COPYRIGHT & LICENSE
Copyright 2008,2009,2010,2011,2012,2013 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=cut
1; # End of Scope::Upper
Scope-Upper-0.24/t/ 0000750 0001750 0001750 00000000000 12213574333 013034 5 ustar vince vince Scope-Upper-0.24/t/55-yield-target.t 0000644 0001750 0001750 00000006354 12207502364 016055 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.24/t/61-uplevel-args.t 0000644 0001750 0001750 00000017777 12213373630 016100 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.24/t/86-stress-uplevel.t 0000644 0001750 0001750 00000005503 11642420332 016453 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.24/t/07-context_info.t 0000644 0001750 0001750 00000010214 12211064713 016141 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 => 19 + 6;
use Scope::Upper qw;
sub HINT_BLOCK_SCOPE () { 0x100 }
sub expected {
my ($type, $line, $want) = @_;
my $top;
my @caller = caller 1;
my @here = caller 0;
unless (@caller) {
@caller = @here;
$top++;
}
my $pkg = $here[0];
my ($file, $eval, $require, $hints, $warnings, $hinthash)
= @caller[1, 6, 7, 8, 9, 10];
$line = $caller[2] unless defined $line;
my ($sub, $hasargs);
if ($type eq 'sub' or $type eq 'eval' or $type eq 'format') {
$sub = $caller[3];
$hasargs = $caller[4];
$want = $caller[5];
$want = '' if defined $want and not $want;
}
if ($top) {
$want = "$]" < 5.015_001 ? '' : undef;
$hints &= ~HINT_BLOCK_SCOPE if $Config{usesitecustomize};
$hints |= HINT_BLOCK_SCOPE if "$]" >= 5.019003;
$warnings = sub { use warnings; (caller 0)[9] }->() if "$]" < 5.007
and not $^W;
}
my @exp = (
$pkg,
$file,
$line,
$sub,
$hasargs,
$want,
$eval,
$require,
$hints,
$warnings,
);
push @exp, $hinthash if "$]" >= 5.010;
return \@exp;
}
sub setup () {
my $pkg = caller;
for my $sub (qw) {
no strict 'refs';
*{"${pkg}::$sub"} = \&{"main::$sub"};
}
}
is_deeply [ context_info ], $exp0, 'main : context_info';
is_deeply [ context_info(HERE) ], $exp0, 'main : context_info HERE';
is_deeply [ context_info(UP) ], $exp0, 'main : context_info UP';
is_deeply [ context_info(-1) ], $exp0, 'main : context_info -1';
package Scope::Upper::TestPkg::A; BEGIN { ::setup }
my @a = sub {
my $exp1 = expected('sub', undef);
is_deeply [ context_info ], $exp1, 'sub0 : context_info';
package Scope::Upper::TestPkg::B; BEGIN { ::setup }
{
my $exp2 = expected('block', __LINE__, 1);
is_deeply [ context_info ], $exp2, 'sub : context_info';
is_deeply [ context_info(UP) ], $exp1, 'sub : context_info UP';
package Scope::Upper::TestPkg::C; BEGIN { ::setup }
for (1) {
my $exp3 = expected('loop', __LINE__ - 1, undef);
is_deeply [ context_info ], $exp3, 'for : context_info';
is_deeply [ context_info(UP) ], $exp2, 'for : context_info UP';
is_deeply [ context_info(UP UP) ], $exp1, 'for : context_info UP UP';
}
package Scope::Upper::TestPkg::D; BEGIN { ::setup }
my $eval_line = __LINE__+1;
eval <<'CODE';
my $exp4 = expected('eval', $eval_line);
is_deeply [ context_info ], $exp4, 'eval string : context_info';
is_deeply [ context_info(UP) ], $exp2, 'eval string : context_info UP';
is_deeply [ context_info(UP UP) ], $exp1, 'eval string : context_info UP UP';
CODE
die $@ if $@;
package Scope::Upper::TestPkg::E; BEGIN { ::setup }
my $x = eval {
my $exp5 = expected('eval', __LINE__ - 1);
package Scope::Upper::TestPkg::F; BEGIN { ::setup }
do {
my $exp6 = expected('block', __LINE__ - 1, undef);
is_deeply [ context_info ], $exp6, 'do : context_info';
is_deeply [ context_info(UP) ], $exp5, 'do : context_info UP';
is_deeply [ context_info(UP UP) ], $exp2, 'do : context_info UP UP';
};
is_deeply [ context_info ], $exp5, 'eval : context_info';
is_deeply [ context_info(UP) ], $exp2, 'eval : context_info UP';
is_deeply [ context_info(UP UP) ], $exp1, 'eval : context_info UP UP';
};
}
}->(1);
package main;
sub first {
do {
second(@_);
}
}
my $fourth;
sub second {
my $x = eval {
my @y = $fourth->();
};
die $@ if $@;
}
$fourth = sub {
my $z = do {
my $dummy;
eval q[
call(@_);
];
die $@ if $@;
}
};
sub call {
for my $depth (0 .. 5) {
my @got = context_info(CALLER $depth);
my @exp = caller $depth;
defined and not $_ and $_ = '' for $exp[5];
is_deeply \@got, \@exp, "context_info vs caller $depth";
}
}
first();
Scope-Upper-0.24/t/65-uplevel-multi.t 0000644 0001750 0001750 00000004457 11642420332 016266 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.24/t/51-unwind-multi.t 0000644 0001750 0001750 00000003416 11642420332 016103 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.24/t/50-unwind-target.t 0000644 0001750 0001750 00000001012 12022476013 016224 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.24/t/44-localize_delete-magic.t 0000644 0001750 0001750 00000003554 12001621776 017663 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.24/t/lib/ 0000750 0001750 0001750 00000000000 12213574333 013602 5 ustar vince vince Scope-Upper-0.24/t/lib/VPIT/ 0000750 0001750 0001750 00000000000 12213574333 014364 5 ustar vince vince Scope-Upper-0.24/t/lib/VPIT/TestHelpers.pm 0000644 0001750 0001750 00000003767 12153106114 017175 0 ustar vince vince package VPIT::TestHelpers;
use strict;
use warnings;
my %exports = (
load_or_skip => \&load_or_skip,
load_or_skip_all => \&load_or_skip_all,
skip_all => \&skip_all,
);
sub import {
my $pkg = caller;
while (my ($name, $code) = each %exports) {
no strict 'refs';
*{$pkg.'::'.$name} = $code;
}
}
my $test_sub = sub {
my $sub = shift;
my $stash;
if ($INC{'Test/Leaner.pm'}) {
$stash = \%Test::Leaner::;
} else {
require Test::More;
$stash = \%Test::More::;
}
my $glob = $stash->{$sub};
return $glob ? *$glob{CODE} : undef;
};
sub skip { $test_sub->('skip')->(@_) }
sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) }
sub diag {
my $diag = $test_sub->('diag');
$diag->($_) for @_;
}
our $TODO;
local $TODO;
sub load {
my ($pkg, $ver, $imports) = @_;
my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg;
my $err;
local $@;
if (eval "use $spec (); 1") {
$ver = do { no strict 'refs'; ${"${pkg}::VERSION"} };
$ver = 'undef' unless defined $ver;
if ($imports) {
my @imports = @$imports;
my $caller = (caller 1)[0];
local $@;
my $res = eval <<"IMPORTER";
package
$caller;
BEGIN { \$pkg->import(\@imports) }
1;
IMPORTER
$err = "Could not import '@imports' from $pkg $ver: $@" unless $res;
}
} else {
(my $file = "$pkg.pm") =~ s{::}{/}g;
delete $INC{$file};
$err = "Could not load $spec";
}
if ($err) {
return wantarray ? (0, $err) : 0;
} else {
diag "Using $pkg $ver";
return 1;
}
}
sub load_or_skip {
my ($pkg, $ver, $imports, $tests) = @_;
die 'You must specify how many tests to skip' unless defined $tests;
my ($loaded, $err) = load($pkg, $ver, $imports);
skip $err => $tests unless $loaded;
return $loaded;
}
sub load_or_skip_all {
my ($pkg, $ver, $imports) = @_;
my ($loaded, $err) = load($pkg, $ver, $imports);
skip_all $err unless $loaded;
return $loaded;
}
package VPIT::TestHelpers::Guard;
sub new {
my ($class, $code) = @_;
bless { code => $code }, $class;
}
sub DESTROY { $_[0]->{code}->() }
1;
Scope-Upper-0.24/t/lib/Scope/ 0000750 0001750 0001750 00000000000 12213574333 014653 5 ustar vince vince Scope-Upper-0.24/t/lib/Scope/Upper/ 0000750 0001750 0001750 00000000000 12213574333 015746 5 ustar vince vince Scope-Upper-0.24/t/lib/Scope/Upper/TestGenerator.pm 0000644 0001750 0001750 00000004340 12207502364 021076 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.24/t/lib/Scope/Upper/TestThreads.pm 0000644 0001750 0001750 00000002722 12153106114 020535 0 ustar vince vince package Scope::Upper::TestThreads;
use strict;
use warnings;
use Config qw<%Config>;
use Scope::Upper qw;
use VPIT::TestHelpers;
sub diag {
require Test::Leaner;
Test::Leaner::diag(@_);
}
sub import {
shift;
skip_all 'This Scope::Upper isn\'t thread safe' unless SU_THREADSAFE;
my $force = $ENV{PERL_SCOPE_UPPER_TEST_THREADS} ? 1 : !1;
skip_all 'This perl wasn\'t built to support threads'
unless $Config{useithreads};
skip_all 'perl 5.13.4 required to test thread safety'
unless $force or "$]" >= 5.013_004;
load_or_skip_all('threads', $force ? '0' : '1.67', [ ]);
my %exports = (
spawn => \&spawn,
);
my $usleep;
if (do { local $@; eval { require Time::HiRes; 1 } }) {
defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION;
$exports{usleep} = \&Time::HiRes::usleep;
} else {
diag 'Using fallback usleep';
$exports{usleep} = sub {
my $s = int($_[0] / 2.5e5);
sleep $s if $s;
};
}
my $pkg = caller;
while (my ($name, $code) = each %exports) {
no strict 'refs';
*{$pkg.'::'.$name} = $code;
}
}
sub spawn {
local $@;
my @diag;
my $thread = eval {
local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
threads->create(@_);
};
push @diag, "Thread creation error: $@" if $@;
if (@diag) {
require Test::Leaner;
Test::Leaner::diag($_) for @diag;
}
return $thread ? $thread : ();
}
1;
Scope-Upper-0.24/t/lib/Test/ 0000750 0001750 0001750 00000000000 12213574333 014521 5 ustar vince vince Scope-Upper-0.24/t/lib/Test/Leaner.pm 0000644 0001750 0001750 00000045374 12207502364 016305 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