[libmoo-perl] 31/43: move Sub::Quote/Sub::Defer to separate dist
gregor herrmann
gregoa at debian.org
Mon Dec 26 17:56:16 UTC 2016
This is an automated email from the git hooks/post-receive script.
gregoa pushed a commit to branch master
in repository libmoo-perl.
commit dafb860f91ab7c4ccf2604e7cf5de53abeb404ad
Author: Graham Knop <haarg at haarg.org>
Date: Thu Dec 8 18:29:16 2016 -0500
move Sub::Quote/Sub::Defer to separate dist
---
Makefile.PL | 2 +
lib/Sub/Defer.pm | 202 ----------------
lib/Sub/Quote.pm | 454 -----------------------------------
t/croak-locations.t | 26 --
t/sub-defer-no-subname.t | 9 -
t/sub-defer-threads.t | 41 ----
t/sub-defer.t | 161 -------------
t/sub-quote-threads.t | 52 ----
t/sub-quote.t | 612 -----------------------------------------------
9 files changed, 2 insertions(+), 1557 deletions(-)
diff --git a/Makefile.PL b/Makefile.PL
index dc83e90..5e7d1ff 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -30,6 +30,8 @@ my %META = (
'Scalar::Util' => 0,
'perl' => 5.006,
'Exporter' => 5.57, # Import 'import'
+ 'Sub::Quote' => 2.003000,
+ 'Sub::Defer' => 2.003000,
},
recommends => {
'Class::XSAccessor' => 1.18,
diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm
deleted file mode 100644
index 750eedd..0000000
--- a/lib/Sub/Defer.pm
+++ /dev/null
@@ -1,202 +0,0 @@
-package Sub::Defer;
-
-use Moo::_strictures;
-use Exporter qw(import);
-use Moo::_Utils qw(_getglob _install_coderef);
-use Scalar::Util qw(weaken);
-use Carp qw(croak);
-
-our $VERSION = '2.002005';
-$VERSION = eval $VERSION;
-
-our @EXPORT = qw(defer_sub undefer_sub undefer_all);
-our @EXPORT_OK = qw(undefer_package defer_info);
-
-our %DEFERRED;
-
-sub undefer_sub {
- my ($deferred) = @_;
- my ($target, $maker, $undeferred_ref) = @{
- $DEFERRED{$deferred}||return $deferred
- };
- return ${$undeferred_ref}
- if ${$undeferred_ref};
- ${$undeferred_ref} = my $made = $maker->();
-
- # make sure the method slot has not changed since deferral time
- if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
- no warnings 'redefine';
-
- # I believe $maker already evals with the right package/name, so that
- # _install_coderef calls are not necessary --ribasushi
- *{_getglob($target)} = $made;
- }
- $DEFERRED{$made} = $DEFERRED{$deferred};
- weaken $DEFERRED{$made}
- unless $target;
-
- return $made;
-}
-
-sub undefer_all {
- undefer_sub($_) for keys %DEFERRED;
- return;
-}
-
-sub undefer_package {
- my $package = shift;
- undefer_sub($_)
- for grep {
- my $name = $DEFERRED{$_} && $DEFERRED{$_}[0];
- $name && $name =~ /^${package}::[^:]+$/
- } keys %DEFERRED;
- return;
-}
-
-sub defer_info {
- my ($deferred) = @_;
- my $info = $DEFERRED{$deferred||''} or return undef;
- [ @$info ];
-}
-
-sub defer_sub {
- my ($target, $maker, $options) = @_;
- my $package;
- my $subname;
- ($package, $subname) = $target =~ /^(.*)::([^:]+)$/
- or croak "$target is not a fully qualified sub name!"
- if $target;
- $package ||= $options && $options->{package} || caller;
- my @attributes = @{$options && $options->{attributes} || []};
- my $deferred;
- my $undeferred;
- my $deferred_info = [ $target, $maker, \$undeferred ];
- if (@attributes || $target && !Moo::_Utils::_CAN_SUBNAME) {
- my $code
- = q[#line ].(__LINE__+2).q[ "].__FILE__.qq["\n]
- . qq[package $package;\n]
- . ($target ? "sub $subname" : '+sub') . join(' ', map ":$_", @attributes)
- . q[ {
- package Sub::Defer;
- # uncoverable subroutine
- # uncoverable statement
- $undeferred ||= undefer_sub($deferred_info->[3]);
- goto &$undeferred; # uncoverable statement
- $undeferred; # fake lvalue return
- }]."\n"
- . ($target ? "\\&$subname" : '');
- my $e;
- $deferred = do {
- no warnings qw(redefine closure);
- local $@;
- eval $code or $e = $@; # uncoverable branch true
- };
- die $e if defined $e; # uncoverable branch true
- }
- else {
- # duplicated from above
- $deferred = sub {
- $undeferred ||= undefer_sub($deferred_info->[3]);
- goto &$undeferred;
- };
- _install_coderef($target, $deferred)
- if $target;
- }
- weaken($deferred_info->[3] = $deferred);
- weaken($DEFERRED{$deferred} = $deferred_info);
- return $deferred;
-}
-
-sub CLONE {
- %DEFERRED = map { defined $_ && $_->[3] ? ($_->[3] => $_) : () } values %DEFERRED;
- foreach my $info (values %DEFERRED) {
- weaken($info)
- unless $info->[0] && ${$info->[2]};
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Sub::Defer - defer generation of subroutines until they are first called
-
-=head1 SYNOPSIS
-
- use Sub::Defer;
-
- my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
- my $t = time;
- sub { time - $t };
- };
-
- Logger->time_since_first_log; # returns 0 and replaces itself
- Logger->time_since_first_log; # returns time - $t
-
-=head1 DESCRIPTION
-
-These subroutines provide the user with a convenient way to defer creation of
-subroutines and methods until they are first called.
-
-=head1 SUBROUTINES
-
-=head2 defer_sub
-
- my $coderef = defer_sub $name => sub { ... };
-
-This subroutine returns a coderef that encapsulates the provided sub - when
-it is first called, the provided sub is called and is -itself- expected to
-return a subroutine which will be goto'ed to on subsequent calls.
-
-If a name is provided, this also installs the sub as that name - and when
-the subroutine is undeferred will re-install the final version for speed.
-
-Exported by default.
-
-=head2 undefer_sub
-
- my $coderef = undefer_sub \&Foo::name;
-
-If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
-If the passed coderef has not been deferred, this will just return it.
-
-If this is confusing, take a look at the example in the L</SYNOPSIS>.
-
-Exported by default.
-
-=head2 undefer_all
-
- undefer_all();
-
-This will undefer all deferred subs in one go. This can be very useful in a
-forking environment where child processes would each have to undefer the same
-subs. By calling this just before you start forking children you can undefer
-all currently deferred subs in the parent so that the children do not have to
-do it. Note this may bake the behavior of some subs that were intended to
-calculate their behavior later, so it shouldn't be used midway through a
-module load or class definition.
-
-Exported by default.
-
-=head2 undefer_package
-
- undefer_package($package);
-
-This undefers all deferred subs in a package.
-
-Not exported by default.
-
-=head1 SUPPORT
-
-See L<Moo> for support and contact information.
-
-=head1 AUTHORS
-
-See L<Moo> for authors.
-
-=head1 COPYRIGHT AND LICENSE
-
-See L<Moo> for the copyright and license.
-
-=cut
diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm
deleted file mode 100644
index 7adf9f5..0000000
--- a/lib/Sub/Quote.pm
+++ /dev/null
@@ -1,454 +0,0 @@
-package Sub::Quote;
-
-sub _clean_eval { eval $_[0] }
-
-use Moo::_strictures;
-
-use Sub::Defer qw(defer_sub);
-use Moo::_Utils qw(_install_coderef);
-use Scalar::Util qw(weaken);
-use Exporter qw(import);
-use Carp qw(croak);
-BEGIN { our @CARP_NOT = qw(Sub::Defer) }
-use B ();
-BEGIN {
- *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
-}
-
-our $VERSION = '2.002005';
-$VERSION = eval $VERSION;
-
-our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
-our @EXPORT_OK = qw(quotify capture_unroll inlinify sanitize_identifier);
-
-our %QUOTED;
-
-sub quotify {
- no warnings 'numeric';
- ! defined $_[0] ? 'undef()'
- # numeric detection
- : (length( (my $dummy = '') & $_[0] )
- && 0 + $_[0] eq $_[0]
- && $_[0] * 0 == 0
- ) ? $_[0]
- : _HAVE_PERLSTRING ? B::perlstring($_[0])
- : qq["\Q$_[0]\E"];
-}
-
-sub sanitize_identifier {
- my $name = shift;
- $name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
- $name;
-}
-
-sub capture_unroll {
- my ($from, $captures, $indent) = @_;
- join(
- '',
- map {
- /^([\@\%\$])/
- or croak "capture key should start with \@, \% or \$: $_";
- (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
- } keys %$captures
- );
-}
-
-sub inlinify {
- my ($code, $args, $extra, $local) = @_;
- my $do = 'do { '.($extra||'');
- if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
- $do .= $1;
- }
- if ($code =~ s{
- \A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
- (^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
- }{}xms) {
- my ($pre, $indent, $code_args) = ($1, $2, $3);
- $do .= $pre;
- if ($code_args ne $args) {
- $do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
- }
- }
- elsif ($local || $args ne '@_') {
- $do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
- }
- $do.$code.' }';
-}
-
-sub quote_sub {
- # HOLY DWIMMERY, BATMAN!
- # $name => $code => \%captures => \%options
- # $name => $code => \%captures
- # $name => $code
- # $code => \%captures => \%options
- # $code
- my $options =
- (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
- ? pop
- : {};
- my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
- undef($captures) if $captures && !keys %$captures;
- my $code = pop;
- my $name = $_[0];
- if ($name) {
- my $subname = $name;
- my $package = $subname =~ s/(.*)::// ? $1 : caller;
- $name = join '::', $package, $subname;
- croak qq{package name "$package" too long!}
- if length $package > 252;
- croak qq{package name "$package" is not valid!}
- unless $package =~ /^[^\d\W]\w*(?:::\w+)*$/;
- croak qq{sub name "$subname" too long!}
- if length $subname > 252;
- croak qq{sub name "$subname" is not valid!}
- unless $subname =~ /^[^\d\W]\w*$/;
- }
- my @caller = caller(0);
- my $attributes = $options->{attributes};
- my $quoted_info = {
- name => $name,
- code => $code,
- captures => $captures,
- package => (exists $options->{package} ? $options->{package} : $caller[0]),
- hints => (exists $options->{hints} ? $options->{hints} : $caller[8]),
- warning_bits => (exists $options->{warning_bits} ? $options->{warning_bits} : $caller[9]),
- hintshash => (exists $options->{hintshash} ? $options->{hintshash} : $caller[10]),
- ($attributes ? (attributes => $attributes) : ()),
- };
- my $unquoted;
- weaken($quoted_info->{unquoted} = \$unquoted);
- if ($options->{no_defer}) {
- my $fake = \my $var;
- local $QUOTED{$fake} = $quoted_info;
- my $sub = unquote_sub($fake);
- _install_coderef($name, $sub) if $name && !$options->{no_install};
- return $sub;
- }
- else {
- my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
- $unquoted if 0;
- unquote_sub($quoted_info->{deferred});
- }, ($attributes ? { attributes => $attributes } : ());
- weaken($quoted_info->{deferred} = $deferred);
- weaken($QUOTED{$deferred} = $quoted_info);
- return $deferred;
- }
-}
-
-sub _context {
- my $info = shift;
- $info->{context} ||= do {
- my ($package, $hints, $warning_bits, $hintshash)
- = @{$info}{qw(package hints warning_bits hintshash)};
-
- $info->{context}
- ="# BEGIN quote_sub PRELUDE\n"
- ."package $package;\n"
- ."BEGIN {\n"
- ." \$^H = ".quotify($hints).";\n"
- ." \${^WARNING_BITS} = ".quotify($warning_bits).";\n"
- ." \%^H = (\n"
- . join('', map
- " ".quotify($_)." => ".quotify($hintshash->{$_}).",\n",
- keys %$hintshash)
- ." );\n"
- ."}\n"
- ."# END quote_sub PRELUDE\n";
- };
-}
-
-sub quoted_from_sub {
- my ($sub) = @_;
- my $quoted_info = $QUOTED{$sub||''} or return undef;
- my ($name, $code, $captures, $unquoted, $deferred)
- = @{$quoted_info}{qw(name code captures unquoted deferred)};
- $code = _context($quoted_info) . $code;
- $unquoted &&= $$unquoted;
- if (($deferred && $deferred eq $sub)
- || ($unquoted && $unquoted eq $sub)) {
- return [ $name, $code, $captures, $unquoted, $deferred ];
- }
- return undef;
-}
-
-sub unquote_sub {
- my ($sub) = @_;
- my $quoted_info = $QUOTED{$sub} or return undef;
- my $unquoted = $quoted_info->{unquoted};
- unless ($unquoted && $$unquoted) {
- my ($name, $code, $captures, $package, $attributes)
- = @{$quoted_info}{qw(name code captures package attributes)};
-
- ($package, $name) = $name =~ /(.*)::(.*)/
- if $name;
-
- my %captures = $captures ? %$captures : ();
- $captures{'$_UNQUOTED'} = \$unquoted;
- $captures{'$_QUOTED'} = \$quoted_info;
-
- my $make_sub
- = "{\n"
- . capture_unroll("\$_[1]", \%captures, 2)
- . " package ${package};\n"
- . (
- $name
- # disable the 'variable $x will not stay shared' warning since
- # we're not letting it escape from this scope anyway so there's
- # nothing trying to share it
- ? " no warnings 'closure';\n sub ${name} "
- : " \$\$_UNQUOTED = sub "
- )
- . ($attributes ? join('', map ":$_ ", @$attributes) : '') . "{\n"
- . " (\$_QUOTED,\$_UNQUOTED) if 0;\n"
- . _context($quoted_info)
- . $code
- . " }".($name ? "\n \$\$_UNQUOTED = \\&${name}" : '') . ";\n"
- . "}\n"
- . "1;\n";
- $ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
- {
- no strict 'refs';
- local *{"${package}::${name}"} if $name;
- my ($success, $e);
- {
- local $@;
- $success = _clean_eval($make_sub, \%captures);
- $e = $@;
- }
- unless ($success) {
- croak "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
- }
- weaken($QUOTED{$$unquoted} = $quoted_info);
- }
- }
- $$unquoted;
-}
-
-sub qsub ($) {
- goto "e_sub;
-}
-
-sub CLONE {
- %QUOTED = map { defined $_ ? (
- $_->{unquoted} && ${$_->{unquoted}} ? (${ $_->{unquoted} } => $_) : (),
- $_->{deferred} ? ($_->{deferred} => $_) : (),
- ) : () } values %QUOTED;
- weaken($_) for values %QUOTED;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Sub::Quote - efficient generation of subroutines via string eval
-
-=head1 SYNOPSIS
-
- package Silly;
-
- use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
-
- quote_sub 'Silly::kitty', q{ print "meow" };
-
- quote_sub 'Silly::doggy', q{ print "woof" };
-
- my $sound = 0;
-
- quote_sub 'Silly::dagron',
- q{ print ++$sound % 2 ? 'burninate' : 'roar' },
- { '$sound' => \$sound };
-
-And elsewhere:
-
- Silly->kitty; # meow
- Silly->doggy; # woof
- Silly->dagron; # burninate
- Silly->dagron; # roar
- Silly->dagron; # burninate
-
-=head1 DESCRIPTION
-
-This package provides performant ways to generate subroutines from strings.
-
-=head1 SUBROUTINES
-
-=head2 quote_sub
-
- my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
-
-Arguments: ?$name, $code, ?\%captures, ?\%options
-
-C<$name> is the subroutine where the coderef will be installed.
-
-C<$code> is a string that will be turned into code.
-
-C<\%captures> is a hashref of variables that will be made available to the
-code. The keys should be the full name of the variable to be made available,
-including the sigil. The values should be references to the values. The
-variables will contain copies of the values. See the L</SYNOPSIS>'s
-C<Silly::dagron> for an example using captures.
-
-Exported by default.
-
-=head3 options
-
-=over 2
-
-=item C<no_install>
-
-B<Boolean>. Set this option to not install the generated coderef into the
-passed subroutine name on undefer.
-
-=item C<no_defer>
-
-B<Boolean>. Prevents a Sub::Defer wrapper from being generated for the quoted
-sub. If the sub will most likely be called at some point, setting this is a
-good idea. For a sub that will most likely be inlined, it is not recommended.
-
-=item C<package>
-
-The package that the quoted sub will be evaluated in. If not specified, the
-sub calling C<quote_sub> will be used.
-
-=back
-
-=head2 unquote_sub
-
- my $coderef = unquote_sub $sub;
-
-Forcibly replace subroutine with actual code.
-
-If $sub is not a quoted sub, this is a no-op.
-
-Exported by default.
-
-=head2 quoted_from_sub
-
- my $data = quoted_from_sub $sub;
-
- my ($name, $code, $captures, $compiled_sub) = @$data;
-
-Returns original arguments to quote_sub, plus the compiled version if this
-sub has already been unquoted.
-
-Note that $sub can be either the original quoted version or the compiled
-version for convenience.
-
-Exported by default.
-
-=head2 inlinify
-
- my $prelude = capture_unroll '$captures', {
- '$x' => 1,
- '$y' => 2,
- }, 4;
-
- my $inlined_code = inlinify q{
- my ($x, $y) = @_;
-
- print $x + $y . "\n";
- }, '$x, $y', $prelude;
-
-Takes a string of code, a string of arguments, a string of code which acts as a
-"prelude", and a B<Boolean> representing whether or not to localize the
-arguments.
-
-=head2 quotify
-
- my $quoted_value = quotify $value;
-
-Quotes a single (non-reference) scalar value for use in a code string. Numbers
-aren't treated specially and will be quoted as strings, but undef will quoted as
-C<undef()>.
-
-=head2 capture_unroll
-
- my $prelude = capture_unroll '$captures', {
- '$x' => 1,
- '$y' => 2,
- }, 4;
-
-Arguments: $from, \%captures, $indent
-
-Generates a snippet of code which is suitable to be used as a prelude for
-L</inlinify>. C<$from> is a string will be used as a hashref in the resulting
-code. The keys of C<%captures> are the names of the variables and the values
-are ignored. C<$indent> is the number of spaces to indent the result by.
-
-=head2 qsub
-
- my $hash = {
- coderef => qsub q{ print "hello"; },
- other => 5,
- };
-
-Arguments: $code
-
-Works exactly like L</quote_sub>, but includes a prototype to only accept a
-single parameter. This makes it easier to include in hash structures or lists.
-
-Exported by default.
-
-=head2 sanitize_identifier
-
- my $var_name = '$variable_for_' . sanitize_identifier('@name');
- quote_sub qq{ print \$${var_name} }, { $var_name => \$value };
-
-Arguments: $identifier
-
-Sanitizes a value so that it can be used in an identifier.
-
-=head1 CAVEATS
-
-Much of this is just string-based code-generation, and as a result, a few
-caveats apply.
-
-=head2 return
-
-Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
-Instead of returning from the code you defined in C<quote_sub>, it will return
-from the overall function it is composited into.
-
-So when you pass in:
-
- quote_sub q{ return 1 if $condition; $morecode }
-
-It might turn up in the intended context as follows:
-
- sub foo {
-
- <important code a>
- do {
- return 1 if $condition;
- $morecode
- };
- <important code b>
-
- }
-
-Which will obviously return from foo, when all you meant to do was return from
-the code context in quote_sub and proceed with running important code b.
-
-=head2 pragmas
-
-C<Sub::Quote> preserves the environment of the code creating the
-quoted subs. This includes the package, strict, warnings, and any
-other lexical pragmas. This is done by prefixing the code with a
-block that sets up a matching environment. When inlining C<Sub::Quote>
-subs, care should be taken that user pragmas won't effect the rest
-of the code.
-
-=head1 SUPPORT
-
-See L<Moo> for support and contact information.
-
-=head1 AUTHORS
-
-See L<Moo> for authors.
-
-=head1 COPYRIGHT AND LICENSE
-
-See L<Moo> for the copyright and license.
-
-=cut
diff --git a/t/croak-locations.t b/t/croak-locations.t
index 616c95b..3370a2a 100644
--- a/t/croak-locations.t
+++ b/t/croak-locations.t
@@ -10,32 +10,6 @@ use Moo::_Utils qw(_load_module);
_load_module("This::Module::Does::Not::Exist::". int rand 50000);
END_CODE
-location_ok <<'END_CODE', 'Sub::Defer::defer_sub - unqualified name';
-use Sub::Defer qw(defer_sub);
-defer_sub 'welp' => sub { sub { 1 } };
-END_CODE
-
-location_ok <<'END_CODE', 'Sub::Defer::defer_sub - unqualified name in Moo class';
-use Moo;
-use Sub::Defer qw(defer_sub);
-defer_sub 'welp' => sub { sub { 1 } };
-END_CODE
-
-location_ok <<'END_CODE', 'Sub::Quote::quote_sub - long package';
-use Sub::Quote qw(quote_sub);
-quote_sub +("x" x 500).'::x', '1';
-END_CODE
-
-location_ok <<'END_CODE', 'Sub::Quote::unquote_sub - bad captures';
-use Sub::Quote qw(unquote_sub quote_sub);
-unquote_sub quote_sub '1', { '&foo' => sub { 1 } };
-END_CODE
-
-location_ok <<'END_CODE', 'Sub::Quote::unquote_sub - compile error';
-use Sub::Quote qw(unquote_sub quote_sub);
-unquote_sub quote_sub ' { ] } ';
-END_CODE
-
location_ok <<'END_CODE', 'Moo - import into role';
use Moo::Role;
use Moo ();
diff --git a/t/sub-defer-no-subname.t b/t/sub-defer-no-subname.t
deleted file mode 100644
index 273a39b..0000000
--- a/t/sub-defer-no-subname.t
+++ /dev/null
@@ -1,9 +0,0 @@
-use Moo::_strictures;
-use lib 't/lib';
-use InlineModule
- 'Sub::Name' => undef,
- 'Sub::Util' => undef,
-;
-do './t/sub-defer.t';
-die $@
- if $@;
diff --git a/t/sub-defer-threads.t b/t/sub-defer-threads.t
deleted file mode 100644
index aacbf6e..0000000
--- a/t/sub-defer-threads.t
+++ /dev/null
@@ -1,41 +0,0 @@
-use Config;
-BEGIN {
- unless ($Config{useithreads}) {
- print "1..0 # SKIP your perl does not support ithreads\n";
- exit 0;
- }
- if ("$]" <= 5.008_004) {
- print "1..0 # SKIP threads not reliable enough on perl <= 5.8.4\n";
- exit 0;
- }
-}
-use threads;
-use Moo::_strictures;
-use Test::More;
-
-use Sub::Defer;
-
-my %made;
-
-my $one_defer = defer_sub 'Foo::one' => sub {
- die "remade - wtf" if $made{'Foo::one'};
- $made{'Foo::one'} = sub { 'one' };
-};
-
-ok(threads->create(sub {
- my $info = Sub::Defer::defer_info($one_defer);
- my $name = $info && $info->[0] || '[undef]';
- my $ok = $name eq 'Foo::one';
- if (!$ok) {
- print STDERR "# Bad sub name when undeferring: $name\n";
- }
- return $ok ? 1234 : 0;
-})->join == 1234, 'able to retrieve info in thread');
-
-ok(threads->create(sub {
- undefer_sub($one_defer);
- my $ok = $made{'Foo::one'} && $made{'Foo::one'} == \&Foo::one;
- return $ok ? 1234 : 0;
-})->join == 1234, 'able to undefer in thread');
-
-done_testing;
diff --git a/t/sub-defer.t b/t/sub-defer.t
deleted file mode 100644
index 94f664f..0000000
--- a/t/sub-defer.t
+++ /dev/null
@@ -1,161 +0,0 @@
-use Moo::_strictures;
-use Test::More;
-use Test::Fatal;
-use Sub::Defer qw(defer_sub undefer_sub undefer_all undefer_package);
-
-my %made;
-
-my $one_defer = defer_sub 'Foo::one' => sub {
- die "remade - wtf" if $made{'Foo::one'};
- $made{'Foo::one'} = sub { 'one' }
-};
-
-my $two_defer = defer_sub 'Foo::two' => sub {
- die "remade - wtf" if $made{'Foo::two'};
- $made{'Foo::two'} = sub { 'two' }
-};
-
-is($one_defer, \&Foo::one, 'one defer installed');
-is($two_defer, \&Foo::two, 'two defer installed');
-
-is($one_defer->(), 'one', 'one defer runs');
-
-is($made{'Foo::one'}, \&Foo::one, 'one made');
-
-is($made{'Foo::two'}, undef, 'two not made');
-
-is($one_defer->(), 'one', 'one (deferred) still runs');
-
-is(Foo->one, 'one', 'one (undeferred) runs');
-
-like exception { defer_sub 'welp' => sub { sub { 1 } } },
- qr/^welp is not a fully qualified sub name!/,
- 'correct error for defer_sub with unqualified name';
-
-is(my $two_made = undefer_sub($two_defer), $made{'Foo::two'}, 'make two');
-
-is exception { undefer_sub($two_defer) }, undef,
- "repeated undefer doesn't regenerate";
-
-is($two_made, \&Foo::two, 'two installed');
-
-is($two_defer->(), 'two', 'two (deferred) still runs');
-
-is($two_made->(), 'two', 'two (undeferred) runs');
-
-my $three = sub { 'three' };
-
-is(undefer_sub($three), $three, 'undefer non-deferred is a no-op');
-
-my $four_defer = defer_sub 'Foo::four' => sub {
- sub { 'four' }
-};
-is($four_defer, \&Foo::four, 'four defer installed');
-
-# somebody somewhere wraps up around the deferred installer
-no warnings qw/redefine/;
-my $orig = Foo->can('four');
-*Foo::four = sub {
- $orig->() . ' with a twist';
-};
-
-is(Foo->four, 'four with a twist', 'around works');
-is(Foo->four, 'four with a twist', 'around has not been destroyed by first invocation');
-
-my $one_all_defer = defer_sub 'Foo::one_all' => sub {
- $made{'Foo::one_all'} = sub { 'one_all' }
-};
-
-my $two_all_defer = defer_sub 'Foo::two_all' => sub {
- $made{'Foo::two_all'} = sub { 'two_all' }
-};
-
-is( $made{'Foo::one_all'}, undef, 'one_all not made' );
-is( $made{'Foo::two_all'}, undef, 'two_all not made' );
-
-undefer_all();
-
-is( $made{'Foo::one_all'}, \&Foo::one_all, 'one_all made by undefer_all' );
-is( $made{'Foo::two_all'}, \&Foo::two_all, 'two_all made by undefer_all' );
-
-defer_sub 'Bar::one' => sub {
- $made{'Bar::one'} = sub { 'one' }
-};
-defer_sub 'Bar::two' => sub {
- $made{'Bar::two'} = sub { 'two' }
-};
-defer_sub 'Bar::Baz::one' => sub {
- $made{'Bar::Baz::one'} = sub { 'one' }
-};
-
-undefer_package('Bar');
-
-is( $made{'Bar::one'}, \&Bar::one, 'one made by undefer_package' );
-is( $made{'Bar::two'}, \&Bar::two, 'two made by undefer_package' );
-
-is( $made{'Bar::Baz::one'}, undef, 'sub-package not undefered by undefer_package' );
-
-{
- my $foo = defer_sub undef, sub { sub { 'foo' } };
- my $foo_string = "$foo";
- undef $foo;
-
- is Sub::Defer::defer_info($foo_string), undef,
- "deferred subs don't leak";
-
- Sub::Defer->CLONE;
- ok !exists $Sub::Defer::DEFERRED{$foo_string},
- 'CLONE cleans out expired entries';
-}
-
-{
- my $foo = defer_sub undef, sub { sub { 'foo' } };
- my $foo_string = "$foo";
- Sub::Defer->CLONE;
- undef $foo;
-
- is Sub::Defer::defer_info($foo_string), undef,
- "CLONE doesn't strengthen refs";
-}
-
-{
- my $foo = defer_sub undef, sub { sub { 'foo' } };
- my $foo_string = "$foo";
- my $foo_info = Sub::Defer::defer_info($foo_string);
- undef $foo;
-
- is exception { Sub::Defer->CLONE }, undef,
- 'CLONE works when quoted info saved externally';
- ok exists $Sub::Defer::DEFERRED{$foo_string},
- 'CLONE keeps entries that had info saved externally';
-}
-
-{
- my $foo = defer_sub undef, sub { sub { 'foo' } };
- my $foo_string = "$foo";
- my $foo_info = $Sub::Defer::DEFERRED{$foo_string};
- undef $foo;
-
- is exception { Sub::Defer->CLONE }, undef,
- 'CLONE works when quoted info kept alive externally';
- ok !exists $Sub::Defer::DEFERRED{$foo_string},
- 'CLONE removes expired entries that were kept alive externally';
-}
-
-{
- my $foo = defer_sub undef, sub { sub { 'foo' } };
- my $foo_string = "$foo";
- undef $foo;
- Sub::Defer::undefer_package 'Unused';
- is exception { undefer_sub $foo_string }, undef,
- "undeferring expired sub (or reused refaddr) after undefer_package lives";
-}
-
-{
- my $foo;
- my $sub = defer_sub undef, sub { +sub :lvalue { $foo } }, { attributes => [ 'lvalue' ]};
- $sub->() = 'foo';
- is $foo, 'foo', 'attributes are applied to deferred subs';
-}
-
-done_testing;
diff --git a/t/sub-quote-threads.t b/t/sub-quote-threads.t
deleted file mode 100644
index c7dd796..0000000
--- a/t/sub-quote-threads.t
+++ /dev/null
@@ -1,52 +0,0 @@
-use Config;
-BEGIN {
- unless ($Config{useithreads}) {
- print "1..0 # SKIP your perl does not support ithreads\n";
- exit 0;
- }
- if ("$]" <= 5.008_004) {
- print "1..0 # SKIP threads not reliable enough on perl <= 5.8.4\n";
- exit 0;
- }
-}
-use threads;
-use Moo::_strictures;
-use Test::More;
-
-use Sub::Quote;
-
-my $one = quote_sub q{
- BEGIN { $::EVALED{'one'} = 1 }
- 42
-};
-my $one_code = quoted_from_sub($one)->[1];
-
-my $two = quote_sub q{
- BEGIN { $::EVALED{'two'} = 1 }
- 3 + $x++
-} => { '$x' => \do { my $x = 0 } };
-
-is(threads->create(sub {
- my $quoted = quoted_from_sub($one);
- $quoted && $quoted->[1];
-})->join, $one_code, 'able to retrieve quoted sub in thread');
-
-my $u_one = unquote_sub $one;
-
-is(threads->create(sub { $one->() })->join, 42, 'One (quoted version)');
-
-is(threads->create(sub { $u_one->() })->join, 42, 'One (unquoted version)');
-
-my $r = threads->create(sub {
- my @r;
- push @r, $two->();
- push @r, unquote_sub($two)->();
- push @r, $two->();
- \@r;
-})->join;
-
-is($r->[0], 3, 'Two in thread (quoted version)');
-is($r->[1], 4, 'Two in thread (unquoted version)');
-is($r->[2], 5, 'Two in thread (quoted version again)');
-
-done_testing;
diff --git a/t/sub-quote.t b/t/sub-quote.t
deleted file mode 100644
index 4da5598..0000000
--- a/t/sub-quote.t
+++ /dev/null
@@ -1,612 +0,0 @@
-BEGIN {
- %^H = ();
- my %clear_hints = sub { %{(caller(0))[10]||{}} }->();
- $INC{'ClearHintsHash.pm'} = __FILE__;
- package ClearHintsHash;
- sub hints { %clear_hints }
- sub import {
- $^H |= 0x020000;
- %^H = hints;
- }
-}
-
-use Moo::_strictures;
-use Test::More;
-use Test::Fatal;
-
-use Sub::Quote qw(
- quote_sub
- quoted_from_sub
- unquote_sub
- qsub
- capture_unroll
- inlinify
- sanitize_identifier
-);
-
-our %EVALED;
-
-my $one = quote_sub q{
- BEGIN { $::EVALED{'one'} = 1 }
- 42
-};
-
-my $two = quote_sub q{
- BEGIN { $::EVALED{'two'} = 1 }
- 3 + $x++
-} => { '$x' => \do { my $x = 0 } };
-
-ok(!keys %EVALED, 'Nothing evaled yet');
-
-is unquote_sub(sub {}), undef,
- 'unquote_sub returns undef for unknown subs';
-
-my $u_one = unquote_sub $one;
-
-is_deeply(
- [ sort keys %EVALED ], [ qw(one) ],
- 'subs one evaled'
-);
-
-is($one->(), 42, 'One (quoted version)');
-
-is($u_one->(), 42, 'One (unquoted version)');
-
-is($two->(), 3, 'Two (quoted version)');
-is(unquote_sub($two)->(), 4, 'Two (unquoted version)');
-is($two->(), 5, 'Two (quoted version again)');
-
-my $three = quote_sub 'Foo::three' => q{
- $x = $_[1] if $_[1];
- die +(caller(0))[3] if @_ > 2;
- return $x;
-} => { '$x' => \do { my $x = 'spoon' } };
-
-is(Foo->three, 'spoon', 'get ok (named method)');
-is(Foo->three('fork'), 'fork', 'set ok (named method)');
-is(Foo->three, 'fork', 're-get ok (named method)');
-like(
- exception { Foo->three(qw(full cutlery set)) }, qr/Foo::three/,
- 'exception contains correct name'
-);
-
-quote_sub 'Foo::four' => q{
- return 5;
-};
-
-my $quoted = quoted_from_sub(\&Foo::four);
-like $quoted->[1], qr/return 5;/,
- 'can get quoted from installed sub';
-Foo::four();
-my $quoted2 = quoted_from_sub(\&Foo::four);
-like $quoted2->[1], qr/return 5;/,
- "can still get quoted from installed sub after undefer";
-undef $quoted;
-
-{
- package Bar;
- ::quote_sub blorp => q{ 1; };
-}
-ok defined &Bar::blorp,
- 'bare sub name installed in current package';
-
-my $long = "a" x 251;
-is exception {
- (quote_sub "${long}a::${long}", q{ return 1; })->();
-}, undef,
- 'long names work if package and sub are short enough';
-
-like exception {
- quote_sub "${long}${long}::${long}", q{ return 1; };
-}, qr/^package name "$long$long" too long/,
- 'over long package names error';
-
-like exception {
- quote_sub "${long}::${long}${long}", q{ return 1; };
-}, qr/^sub name "$long$long" too long/,
- 'over long sub names error';
-
-like exception {
- quote_sub "got a space::gorp", q{ return 1; };
-}, qr/^package name "got a space" is not valid!/,
- 'packages with spaces are invalid';
-
-like exception {
- quote_sub "Gorp::got a space", q{ return 1; };
-}, qr/^sub name "got a space" is not valid!/,
- 'sub names with spaces are invalid';
-
-like exception {
- quote_sub "0welp::gorp", q{ return 1; };
-}, qr/^package name "0welp" is not valid!/,
- 'package names starting with numbers are not valid';
-
-like exception {
- quote_sub "Gorp::0welp", q{ return 1; };
-}, qr/^sub name "0welp" is not valid!/,
- 'sub names starting with numbers are not valid';
-
-my $broken_quoted = quote_sub q{
- return 5<;
-};
-
-like(
- exception { $broken_quoted->() }, qr/Eval went very, very wrong/,
- "quoted sub with syntax error dies when called"
-);
-
-sub in_main { 1 }
-is exception { quote_sub(q{ in_main(); })->(); }, undef,
- 'package preserved from context';
-
-{
- package Arf;
- sub in_arf { 1 }
-}
-
-is exception { quote_sub(q{ in_arf(); }, {}, { package => 'Arf' })->(); }, undef,
- 'package used from options';
-
-{
- use strict;
- no strict 'subs';
- local $TODO = "hints from caller not available on perl < 5.8"
- if "$]" < 5.008_000;
- like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} })->(); },
- qr/strict refs/,
- 'hints preserved from context';
-}
-
-{
- my $hints;
- {
- use strict;
- no strict 'subs';
- BEGIN { $hints = $^H }
- }
- like exception { quote_sub(q{ my $f = SomeBareword; ${"string_ref"} }, {}, { hints => $hints })->(); },
- qr/strict refs/,
- 'hints used from options';
-}
-
-{
- my $sub = do {
- no warnings;
- unquote_sub quote_sub(q{ 0 + undef });
- };
- my @warnings;
- local $SIG{__WARN__} = sub { push @warnings, @_ };
- $sub->();
- is scalar @warnings, 0,
- '"no warnings" preserved from context';
-}
-
-{
- my $sub = do {
- no warnings;
- use warnings;
- unquote_sub quote_sub(q{ 0 + undef });
- };
- my @warnings;
- local $SIG{__WARN__} = sub { push @warnings, @_ };
- $sub->();
- like $warnings[0],
- qr/uninitialized/,
- '"use warnings" preserved from context';
-}
-
-{
- my $warn_bits;
- eval q{
- use warnings FATAL => 'uninitialized';
- BEGIN { $warn_bits = ${^WARNING_BITS} }
- 1;
- } or die $@;
- no warnings 'uninitialized';
- like exception { quote_sub(q{ 0 + undef }, {}, { warning_bits => $warn_bits })->(); },
- qr/uninitialized/,
- 'warnings used from options';
-}
-
-BEGIN {
- package UseHintHash;
- $INC{'UseHintHash.pm'} = 1;
-
- sub import {
- $^H |= 0x020000;
- $^H{__PACKAGE__.'/enabled'} = 1;
- }
-}
-
-{
- my %hints;
- {
- use ClearHintsHash;
- use UseHintHash;
- BEGIN { %hints = %^H }
- }
-
- {
- local $TODO = 'hints hash from context not available on perl 5.8'
- if "$]" < 5.010_000;
-
- use ClearHintsHash;
- use UseHintHash;
- is_deeply quote_sub(q{
- our %temp_hints_hash;
- BEGIN { %temp_hints_hash = %^H }
- \%temp_hints_hash;
- })->(), \%hints,
- 'hints hash preserved from context';
- }
-
- is_deeply quote_sub(q{
- our %temp_hints_hash;
- BEGIN { %temp_hints_hash = %^H }
- \%temp_hints_hash;
- }, {}, { hintshash => \%hints })->(), \%hints,
- 'hints hash used from options';
-}
-
-{
- use ClearHintsHash;
- my $sub = quote_sub(q{
- our %temp_hints_hash;
- BEGIN { %temp_hints_hash = %^H }
- \%temp_hints_hash;
- });
- my $wrap_sub = do {
- use UseHintHash;
- my (undef, $code, $cap) = @{quoted_from_sub($sub)};
- quote_sub $code, $cap||();
- };
- is_deeply $wrap_sub->(), { ClearHintsHash::hints },
- 'empty hints maintained when inlined';
-}
-
-BEGIN {
- package BetterNumbers;
- $INC{'BetterNumbers.pm'} = 1;
- use overload ();
-
- sub import {
- my ($class, $add) = @_;
- # closure vs not
- if (defined $add) {
- overload::constant 'integer', sub { $_[0] + $add };
- }
- else {
- overload::constant 'integer', sub { $_[0] + 1 };
- }
- }
-}
-
-TODO: {
- my ($options, $context_sub, $direct_val);
- {
- use BetterNumbers;
- BEGIN { $options = { hints => $^H, hintshash => { %^H } } }
- $direct_val = 10;
- $context_sub = quote_sub(q{ 10 });
- }
- my $options_sub = quote_sub(q{ 10 }, {}, $options);
-
- is $direct_val, 11,
- 'integer overload is working';
-
- todo_skip "refs in hints hash not yet implemented", 4;
- {
- my $context_val;
- is exception { $context_val = $context_sub->() }, undef,
- 'hints hash refs from context not broken';
- local $TODO = 'hints hash from context not available on perl 5.8'
- if !$TODO && "$]" < 5.010_000;
- is $context_val, 11,
- 'hints hash refs preserved from context';
- }
-
- {
- my $options_val;
- is exception { $options_val = $options_sub->() }, undef,
- 'hints hash refs from options not broken';
- is $options_val, 11,
- 'hints hash refs used from options';
- }
-}
-
-TODO: {
- my ($options, $context_sub, $direct_val);
- {
- use BetterNumbers +2;
- BEGIN { $options = { hints => $^H, hintshash => { %^H } } }
- $direct_val = 10;
- $context_sub = quote_sub(q{ 10 });
- }
- my $options_sub = quote_sub(q{ 10 }, {}, $options);
-
- is $direct_val, 12,
- 'closure integer overload is working';
-
- todo_skip "refs in hints hash not yet implemented", 4;
-
- {
- my $context_val;
- is exception { $context_val = $context_sub->() }, undef,
- 'hints hash closure refs from context not broken';
- local $TODO = 'hints hash from context not available on perl 5.8'
- if !$TODO && "$]" < 5.010_000;
- is $context_val, 12,
- 'hints hash closure refs preserved from context';
- }
-
- {
- my $options_val;
- is exception { $options_val = $options_sub->() }, undef,
- 'hints hash closure refs from options not broken';
- is $options_val, 12,
- 'hints hash closure refs used from options';
- }
-}
-
-{
- my $foo = quote_sub '{}';
- my $foo_string = "$foo";
- undef $foo;
-
- is quoted_from_sub($foo_string), undef,
- "quoted subs don't leak";
-
- Sub::Quote->CLONE;
- ok !exists $Sub::Quote::QUOTED{$foo_string},
- 'CLONE cleans out expired entries';
-}
-
-{
- my $foo = quote_sub '{}';
- my $foo_string = "$foo";
- Sub::Quote->CLONE;
- undef $foo;
-
- is quoted_from_sub($foo_string), undef,
- "CLONE doesn't strengthen refs";
-}
-
-{
- my $foo = quote_sub '{}';
- my $foo_string = "$foo";
- my $foo_info = quoted_from_sub($foo_string);
- undef $foo;
-
- is exception { Sub::Quote->CLONE }, undef,
- 'CLONE works when quoted info saved externally';
- ok exists $Sub::Quote::QUOTED{$foo_string},
- 'CLONE keeps entries that had info saved';
-}
-
-{
- my $foo = quote_sub '{}';
- my $foo_string = "$foo";
- my $foo_info = $Sub::Quote::QUOTED{$foo_string};
- undef $foo;
-
- is exception { Sub::Quote->CLONE }, undef,
- 'CLONE works when quoted info kept alive externally';
- ok !exists $Sub::Quote::QUOTED{$foo_string},
- 'CLONE removes expired entries that were kept alive externally';
-}
-
-{
- my $foo = quote_sub '{}';
- my $foo_string = "$foo";
- my $sub = unquote_sub $foo;
- my $sub_string = "$sub";
-
- Sub::Quote->CLONE;
-
- ok quoted_from_sub($sub_string),
- 'CLONE maintains entries referenced by unquoted sub';
-
- undef $sub;
- ok quoted_from_sub($foo_string)->[3],
- 'unquoted sub still available if quoted sub exists';
-}
-
-{
- my $foo = quote_sub '{}';
- my $foo_string = "$foo";
- my $foo2 = unquote_sub $foo;
- undef $foo;
-
- my $foo_info = Sub::Quote::quoted_from_sub($foo_string);
- is $foo_info, undef,
- 'quoted data not maintained for quoted sub deleted after being unquoted';
-
- is quoted_from_sub($foo2)->[3], $foo2,
- 'unquoted sub still included in quote info';
-}
-
-use Data::Dumper;
-my $dump = sub {
- local $Data::Dumper::Terse = 1;
- my $d = Data::Dumper::Dumper($_[0]);
- $d =~ s/\s+$//;
- $d;
-};
-
-my @strings = (0, 1, "\x00", "a", "\xFC", "\x{1F4A9}");
-my $eval = sub { eval Sub::Quote::quotify($_[0])};
-
-my @failed = grep { my $o = $eval->($_); !defined $o || $o ne $_ } @strings;
-
-ok !@failed, "evaling quotify returns same value for all strings"
- or diag "Failed strings: " . join(' ', map { $dump->($_) } @failed);
-
-SKIP: {
- skip "working utf8 pragma not available", 1
- if "$]" < 5.008_000;
- my $eval_utf8 = eval 'sub { use utf8; eval Sub::Quote::quotify($_[0]) }';
-
- my @failed_utf8 = grep { my $o = $eval_utf8->($_); !defined $o || $o ne $_ }
- @strings;
- ok !@failed_utf8, "evaling quotify under utf8 returns same value for all strings"
- or diag "Failed strings: " . join(' ', map { $dump->($_) } @failed_utf8);
-}
-
-unlike Sub::Quote::quotify($_), qr/[^0-9.-]/,
- "quotify preserves $_ as number"
- for 0, 1, 1.5, 0.5, -10;
-
-my @stuff = (qsub q{ print "hello"; }, 1, 2);
-is scalar @stuff, 3, 'qsub only accepts a single parameter';
-
-my $captures = {
- '$x' => \1,
- '$y' => \2,
-};
-my $prelude = capture_unroll '$captures', $captures, 4;
-my $out = eval
- $prelude
- . '[ $x, $y ]';
-is "$@", '', 'capture_unroll produces valid code';
-is_deeply $out, [ 1, 2 ], 'unrolled variables get correct values';
-
-like exception {
- capture_unroll '$captures', { '&foo' => \sub { 5 } }, 4;
-}, qr/^capture key should start with @, % or \$/,
- 'capture_unroll rejects vars other than scalar, hash, or array';
-
-{
- my $inlined_code = inlinify q{
- my ($x, $y) = @_;
-
- [ $x, $y ];
- }, '$x, $y', $prelude;
- my $out = eval $inlined_code;
- is "$@", '', 'inlinify produces valid code'
- or diag "code:\n$inlined_code";
- is_deeply $out, [ 1, 2 ], 'inlinified code get correct values';
- unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/,
- "matching variables aren't reassigned";
-}
-
-{
- $Bar::baz = 3;
- my $inlined_code = inlinify q{
- package Bar;
- my ($x, $y) = @_;
-
- [ $x, $y, our $baz ];
- }, '$x, $y', $prelude;
- my $out = eval $inlined_code;
- is "$@", '', 'inlinify produces valid code'
- or diag "code:\n$inlined_code";
- is_deeply $out, [ 1, 2, 3 ], 'inlinified code get correct values';
- unlike $inlined_code, qr/my \(\$x, \$y\) = \@_;/,
- "matching variables aren't reassigned";
-}
-
-{
- my $inlined_code = inlinify q{
- my ($d, $f) = @_;
-
- [ $d, $f ];
- }, '$x, $y', $prelude;
- my $out = eval $inlined_code;
- is "$@", '', 'inlinify with unmatched params produces valid code'
- or diag "code:\n$inlined_code";
- is_deeply $out, [ 1, 2 ], 'inlinified code get correct values';
-}
-
-{
- my $inlined_code = inlinify q{
- my $z = $_[0];
- $z;
- }, '$y', $prelude;
- my $out = eval $inlined_code;
- is "$@", '', 'inlinify with out @_ produces valid code'
- or diag "code:\n$inlined_code";
- is $out, 2, 'inlinified code get correct values';
-}
-
-{
- my @warnings;
- local $ENV{SUB_QUOTE_DEBUG} = 1;
- local $SIG{__WARN__} = sub { push @warnings, @_ };
- my $sub = quote_sub q{ "this is in the quoted sub" };
- $sub->();
- like $warnings[0],
- qr/sub\s*{.*this is in the quoted sub/s,
- 'got debug info with SUB_QUOTE_DEBUG';
-}
-
-{
- my $sub = quote_sub q{
- BEGIN { $::EVALED{'no_defer'} = 1 }
- 1;
- }, {}, {no_defer => 1};
- is $::EVALED{no_defer}, 1,
- 'evaled immediately with no_defer option';
-}
-
-{
- my $sub = quote_sub 'No::Defer::Test', q{
- BEGIN { $::EVALED{'no_defer'} = 1 }
- 1;
- }, {}, {no_defer => 1};
- is $::EVALED{no_defer}, 1,
- 'evaled immediately with no_defer option (named)';
- ok defined &No::Defer::Test,
- 'sub installed with no_defer option';
-}
-
-{
- my $caller;
- sub No::Install::Tester {
- $caller = (caller(1))[3];
- }
- my $sub = quote_sub 'No::Install::Test', q{
- No::Install::Tester();
- }, {}, {no_install => 1};
- ok !defined &No::Install::Test,
- 'sub not installed with no_install option';
- $sub->();
- is $caller, 'No::Install::Test',
- 'sub named properly with no_install option';
-}
-
-{
- my $caller;
- sub No::Install::No::Defer::Tester {
- $caller = (caller(1))[3];
- }
- my $sub = quote_sub 'No::Install::No::Defer::Test', q{
- No::Install::No::Defer::Tester();
- }, {}, {no_install => 1, no_defer => 1};
- ok !defined &No::Install::No::Defer::Test,
- 'sub not installed with no_install and no_defer options';
- $sub->();
- is $caller, 'No::Install::No::Defer::Test',
- 'sub named properly with no_install and no_defer options';
-}
-
-my $var = sanitize_identifier('erk-qro yuf (fid)');
-eval qq{ my \$$var = 5; \$var };
-is $@, '', 'sanitize_identifier gives valid identifier';
-
-{
- my $var;
- my $sub = quote_sub q{ $$var }, { '$var' => \\$var }, { attributes => [ 'lvalue' ] };
- $sub->() = 5;
- is $var, 5,
- 'attributes applied to quoted sub';
-}
-
-{
- my $var;
- my $sub = quote_sub q{ $$var }, { '$var' => \\$var }, { attributes => [ 'lvalue' ], no_defer => 1 };
- $sub->() = 5;
- is $var, 5,
- 'attributes applied to quoted sub with no_defer';
-}
-
-done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libmoo-perl.git
More information about the Pkg-perl-cvs-commits
mailing list