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 <ha...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits