Closure-Explicit
view release on metacpan or search on metacpan
lib/Closure/Explicit.pod
t/00-check-deps.t
t/00-compile.t
t/00-report-prereqs.dd
t/00-report-prereqs.t
t/basic.t
t/cleanup.t
t/coderef.t
t/nested-scope.t
t/refcount.t
t/weaken.t
xt/author/mojibake.t
xt/author/pod-syntax.t
xt/author/synopsis.t
xt/author/test-version.t
xt/release/common_spelling.t
SHA1 2244b6fd3c640536bca4bcca822203ccd76b5283 lib/Closure/Explicit.pod
SHA1 7217af7ee03c0952a6426dfe86d12ef8f9fe14eb t/00-check-deps.t
SHA1 4a01e4701cc7afd4bd1f5fa8f7326cc4dc703ef7 t/00-compile.t
SHA1 9125b9877a246ef5b2d99db4a455b5325872f672 t/00-report-prereqs.dd
SHA1 d102b9c45639416472b593947cb72390e24f8e93 t/00-report-prereqs.t
SHA1 a32d59d972e62cf888ea897cca439e344cb9bb55 t/basic.t
SHA1 74411af9916259c2f71ef74dc71b8a88ad175e3b t/cleanup.t
SHA1 be4e3c8736e77d1d797c99bd5fb1c4522a045a30 t/coderef.t
SHA1 20e5b2f7d6eedadf85f69c72dcf2dec31c1ac252 t/nested-scope.t
SHA1 ee90363c7cd8760b3b0897ff30670979ed8ba622 t/refcount.t
SHA1 6f0c1bf1be0128873e53dd36f09883176f873845 t/weaken.t
SHA1 f2c40e917e02088703731272f86cbb906ab19eb3 xt/author/mojibake.t
SHA1 f0c18c75922a1516ae7a5ec5d391b31fd757f0bd xt/author/pod-syntax.t
SHA1 34513f89a70b96f6412fe2ef0ad4d475e8cac66c xt/author/synopsis.t
SHA1 187e6d98759176eb6fd4fb386871b0ebc51cf289 xt/author/test-version.t
SHA1 198d1665317c3d91e3bb81f0a3b8dad8d4d66f20 xt/release/common_spelling.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1
iQIcBAEBAgAGBQJY9MbrAAoJEG2WkcbynxAl9MYQALofNH1BZYp+Gcwi8p8HmhjJ
9J+wDr4WC9DYQKCiWKf+UDSh0L6K3jw06O8IuK8BujHmX+lE3XsjfnylUFoZgHQU
lib/Closure/Explicit.pm view on Meta::CPAN
# This will raise an exception due to the reference to $self
eval {
my $code = callback {
$self->method;
};
};
# This will not raise the exception because $self is whitelisted
my $code = callback {
$self->method;
} [qw($self)];
# This will wrap the coderef so we can pass a weakened copy of $self
my $code = callback {
my $self = shift;
$self->method;
} weaken => [qw($self)];
=head1 DESCRIPTION
Attempts to provide some very basic protection against unintentional
capturing of lexicals in a closure.
For example, code such as the following risks creating cycles which
mean the top-level object is never freed:
sub some_method {
lib/Closure/Explicit.pm view on Meta::CPAN
However, it is highly likely that a future version will also start exporting
a differently-named function with a better interface.
=cut
use parent qw(Exporter);
our @EXPORT_OK = qw(callback);
# This is not documented, because turning it off will break
# the weaken behaviour.
use constant CLOSURE_CHECKS => exists($ENV{PERL_CLOSURE_EXPLICIT_CHECKS}) ? $ENV{PERL_CLOSURE_EXPLICIT_CHECKS} : 1;
=head1 EXPORTS
=cut
=head2 callback
Checks the given coderef for potential closure issues, raising an exception if any
are found and returning the coderef (or a wrapped version of it) if everything is
lib/Closure/Explicit.pm view on Meta::CPAN
Remaining parameters are optional - you can either pass a single array, containing
a list of the B<names> of the variables that are safe to capture:
callback { print "$x\n" } [qw($x)];
or a list of named parameters:
=over 4
=item * weaken => [...] - list of B<variable names> which will be copied, weakened
via L<Scalar::Util/weaken>, then prepended to the parameter list available in @_
in your code block
=item * allowed => [...] - list of B<variable names> to ignore if used in the code,
same behaviour as passing a single arrayref
=back
For example, a method call might look like this:
my $code = callback {
my $self = shift;
$self->method(@_);
} weaken => [qw($self)];
although L<curry::weak> would be a much cleaner alternative there:
my $code = $self->curry::weak::method;
You can mix C<weaken> and C<allowed>:
my $x = 1;
my $code = callback {
shift->method(++$x);
} weaken => [qw($self)], allowed => [qw($x)];
=cut
sub callback(&;@) {
if(CLOSURE_CHECKS) {
my $code = shift;
my %spec = (@_ > 1) ? (@_) : (allowed => shift);
# warn "Have " . join ',', keys %spec;
if(my @err = lint( $code => %spec )) {
warn "$_\n" for @err;
die "Had " . @err . " error(s) in closure";
}
return $code
} else {
return $_[0] unless grep $_ eq 'weaken', @_;
my $code = shift;
my %spec = @_;
if($spec{weaken}) {
my $scope = peek_my(1);
my @extra = map ${ $scope->{$_} }, @{$spec{weaken}};
Scalar::Util::weaken($_) for @extra;
return sub { $code->(@extra, @_) };
}
}
}
=head2 lint
Runs checks on the given coderef. This is used internally and not exported,
but if you just want to get a list of potential problems for a coderef,
call this:
my @errors = lint($code, allowed => [qw($x)]);
It's unlikely that the C<weaken> parameter will work when calling this
function directly - this may be fixed in a future version.
=cut
sub lint {
my ($code, %spec) = @_;
my $cv = B::svref_2object($code);
my $details = sprintf '%s(%s:%d)', $cv->STASH->NAME, $cv->FILE, $cv->GV->LINE;
my %closed = %{closed_over($code)};
my %closed_by_value = map {
ref($closed{$_}) eq 'REF'
? (${$closed{$_}} => $_)
: ()
} keys %closed;
# This is everything we declare in the sub
my @lexicals = grep !exists $closed{$_}, keys %{ peek_sub $code };
if($spec{weaken}) {
# warn "weaken request: " . join ',', @{$spec{weaken}};
my $scope = peek_my(2);
my $real_code = $code;
my @extra = map ${ $scope->{$_} }, @{$spec{weaken}};
Scalar::Util::weaken($_) for @extra;
$code = $_[0] = sub { $real_code->(@extra, @_) };
shift;
}
# That's it for the data collection, now run the tests
my @errors;
foreach my $var (@{$spec{declares}}) {
push @errors, "no $var declared in padlist" unless grep $_ eq $var, @lexicals;
}
# say " * We are capturing $_" for sort keys %closed;
lib/Closure/Explicit.pod view on Meta::CPAN
# This will raise an exception due to the reference to $self
eval {
my $code = callback {
$self->method;
};
};
# This will not raise the exception because $self is whitelisted
my $code = callback {
$self->method;
} [qw($self)];
# This will wrap the coderef so we can pass a weakened copy of $self
my $code = callback {
my $self = shift;
$self->method;
} weaken => [qw($self)];
=head1 DESCRIPTION
Attempts to provide some very basic protection against unintentional
capturing of lexicals in a closure.
For example, code such as the following risks creating cycles which
mean the top-level object is never freed:
sub some_method {
lib/Closure/Explicit.pod view on Meta::CPAN
Remaining parameters are optional - you can either pass a single array, containing
a list of the B<names> of the variables that are safe to capture:
callback { print "$x\n" } [qw($x)];
or a list of named parameters:
=over 4
=item * weaken => [...] - list of B<variable names> which will be copied, weakened
via L<Scalar::Util/weaken>, then prepended to the parameter list available in @_
in your code block
=item * allowed => [...] - list of B<variable names> to ignore if used in the code,
same behaviour as passing a single arrayref
=back
For example, a method call might look like this:
my $code = callback {
my $self = shift;
$self->method(@_);
} weaken => [qw($self)];
although L<curry::weak> would be a much cleaner alternative there:
my $code = $self->curry::weak::method;
You can mix C<weaken> and C<allowed>:
my $x = 1;
my $code = callback {
shift->method(++$x);
} weaken => [qw($self)], allowed => [qw($x)];
=head2 lint
Runs checks on the given coderef. This is used internally and not exported,
but if you just want to get a list of potential problems for a coderef,
call this:
my @errors = lint($code, allowed => [qw($x)]);
It's unlikely that the C<weaken> parameter will work when calling this
function directly - this may be fixed in a future version.
=head1 SEE ALSO
=over 4
=item * L<curry> - provides a convenient interface for creating callbacks
=item * L<PadWalker> - does most of the real work behind this module
}
}, 'raise exception on capture');
# Can we whitelist captures
is(exception {
callback {
$self->method;
} [qw($self)];
}, undef, 'no exception when lexical is whitelisted');
# Can we weaken captures
is(exception {
callback {
my $self = shift;
$self->method;
} weaken => [qw($self)];
}, undef, 'no exception when requesting a weakref');
done_testing();
t/cleanup.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use Test::Fatal;
use Test::Refcount;
use Scalar::Util qw(weaken);
use Closure::Explicit qw(callback);
{
my $x = [];
my $y = 123;
my $weak_copy;
{
my $code = callback {
my $x = shift;
die "wrong value" unless $x && ref $x;
print "$y\n";
} weaken => [qw($x)], allowed => [qw($y)];
$weak_copy = $code;
}
ok($weak_copy, 'have a copy');
weaken $weak_copy;
ok(!$weak_copy, 'no more copy');
}
done_testing();
t/coderef.t view on Meta::CPAN
&callback($code);
}, 'raise exception on capture');
# Can we whitelist captures
is(exception {
# really don't do this in real code
my $code = sub { $self->method };
&callback($code, [qw($self)]);
}, undef, 'no exception when lexical is whitelisted');
# Can we weaken captures
is(exception {
# this is not recommended at all
my $code = sub { my $self = shift; $self->method };
&callback($code, weaken => [qw($self)]);
}, undef, 'no exception when requesting a weakref');
done_testing();
t/nested-scope.t view on Meta::CPAN
}, 'lexical in nested scope does not prevent us flagging capture at top-level');
# Can we whitelist captures
is(exception {
(callback {
for my $self (1..4) { 1 }
$self->method;
} [qw($self)])->();
}, undef, 'no exception when lexical is whitelisted');
# Can we weaken captures
is(exception {
(callback {
my $self = shift;
$self->method;
} weaken => [qw($self)])->();
}, undef, 'no exception when requesting a weakref');
done_testing();
t/refcount.t view on Meta::CPAN
ok((my $code = callback {
$self->method;
} [qw($self)]
), 'get callback');
is_oneref($self, 'still with a single ref');
}
{
ok((my $code = callback {
my $self = shift;
$self->method;
} weaken => [qw($self)]
), 'get callback');
is_oneref($self, 'still with a single ref');
}
done_testing();
use Test::Fatal;
use Test::Refcount;
use Scalar::Util ();
use Closure::Explicit qw(callback);
{
package Example;
use Test::More;
our $GLOBAL_SELF;
sub new { my $class = shift; my $self = bless {}, $class; Scalar::Util::weaken($GLOBAL_SELF = $self); $self }
sub method { my $self = shift; is($self, $GLOBAL_SELF, 'have correct $self') }
}
local $SIG{__WARN__} = sub { note "had warning: @_" };
my $self = new_ok('Example');
is_oneref($self, 'start with a single ref');
{
ok(exception {
my $code = callback {
$self->method;
}
$self->method;
} [qw($self)]
), 'get callback');
is_oneref($self, 'still with a single ref');
$code->();
}
{
ok((my $code = callback {
my $self = shift;
$self->method;
} weaken => [qw($self)]
), 'get callback');
is_oneref($self, 'still with a single ref');
$code->();
}
done_testing();
( run in 0.401 second using v1.01-cache-2.11-cpan-a9ef4e587e4 )