Sub-Quote-2.005000/0000755000000000000000000000000013236367246013717 5ustar00rootwheel00000000000000Sub-Quote-2.005000/Changes0000644000000000000000000000245013236367211015203 0ustar00rootwheel00000000000000Revision history for Sub::Quote 2.005000 - 2018-02-06 - fixed defer_info and undefer_sub from returning data for a deferred sub after it expires, even if the ref address matches - fixed defer_info not returning info for undeferred unnamed subs after the deferred sub expires - include options in defer_info return data - exclude internals from defer_info return data - document defer_info function - encode all utf8 flagged scalars as strings, since they generally will always have originated as strings. Avoids future warning on bitwise ops on strings with wide characters. - more thorough check for threads availability to avoid needless test failures. - added file and line options to quote_sub to allow specifying apparent source location. - documented additional options to Sub::Defer::defer_sub and Sub::Quote::quote_sub. 2.004000 - 2017-06-07 - more extensive quotify tests - split tests into separate files - propagate package to deferred subs, even if unnamed - reject invalid attributes - include line numbers compile errors (PR#1, djerius) 2.003001 - 2016-12-09 - fix use of Sub::Name 2.003000 - 2016-12-09 - Sub::Quote and Sub::Defer have been split out of Moo. - For old history see: https://metacpan.org/changes/release/HAARG/Moo-2.002005 Sub-Quote-2.005000/lib/0000755000000000000000000000000013236367245014464 5ustar00rootwheel00000000000000Sub-Quote-2.005000/lib/Sub/0000755000000000000000000000000013236367245015215 5ustar00rootwheel00000000000000Sub-Quote-2.005000/lib/Sub/Defer.pm0000644000000000000000000001677013236367202016604 0ustar00rootwheel00000000000000package Sub::Defer; use strict; use warnings; use Exporter qw(import); use Scalar::Util qw(weaken); use Carp qw(croak); our $VERSION = '2.005000'; $VERSION = eval $VERSION; our @EXPORT = qw(defer_sub undefer_sub undefer_all); our @EXPORT_OK = qw(undefer_package defer_info); our %DEFERRED; sub _getglob { no strict 'refs'; \*{$_[0]} } BEGIN { my $no_subname; *_subname = defined &Sub::Util::set_subname ? \&Sub::Util::set_subname : defined &Sub::Name::subname ? \&Sub::Name::subname : (eval { require Sub::Util } && defined &Sub::Util::set_subname) ? \&Sub::Util::set_subname : (eval { require Sub::Name } && defined &Sub::Name::subname ) ? \&Sub::Name::subname : ($no_subname = 1, sub { $_[1] }); *_CAN_SUBNAME = $no_subname ? sub(){0} : sub(){1}; } sub _name_coderef { shift if @_ > 2; # three args is (target, name, sub) _CAN_SUBNAME ? _subname(@_) : $_[1]; } sub _install_coderef { my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_)); no warnings 'redefine'; if (*{$glob}{CODE}) { *{$glob} = $code; } # perl will sometimes warn about mismatched prototypes coming from the # inheritance cache, so disable them if we aren't redefining a sub else { no warnings 'prototype'; *{$glob} = $code; } } sub undefer_sub { my ($deferred) = @_; my $info = $DEFERRED{$deferred} or return $deferred; my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info; if (!( $deferred_sub && $deferred eq $deferred_sub || ${$undeferred_ref} && $deferred eq ${$undeferred_ref} )) { 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; } my $undefer_info = [ $target, $maker, $options, \$$undeferred_ref ]; $info->[5] = $DEFERRED{$made} = $undefer_info; weaken ${$undefer_info->[3]}; 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; my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info; if (!( $deferred_sub && $deferred eq $deferred_sub || ${$undeferred_ref} && $deferred eq ${$undeferred_ref} )) { delete $DEFERRED{$deferred}; return undef; } [ $target, $maker, $options, ( $undeferred_ref && $$undeferred_ref ? $$undeferred_ref : ()), ]; } 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} || []}; if (@attributes) { /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_" for @attributes; } my $deferred; my $undeferred; my $deferred_info = [ $target, $maker, $options, \$undeferred ]; if (@attributes || $target && !_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->[4]); 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->[4]); goto &$undeferred; }; _install_coderef($target, $deferred) if $target; } weaken($deferred_info->[4] = $deferred); weaken($DEFERRED{$deferred} = $deferred_info); return $deferred; } sub CLONE { %DEFERRED = map { defined $_ ? ( $_->[4] ? ($_->[4] => $_) : ($_->[3] && ${$_->[3]}) ? (${$_->[3]} => $_) : () ) : () } values %DEFERRED; } 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 { ... }, \%options; 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. =head3 Options A hashref of options can optionally be specified. =over 4 =item package The package to generate the sub in. Will be overridden by a fully qualified C<$name> option. If not specified, will default to the caller's package. =item attributes The L to apply to the sub generated. Should be specified as an array reference. =back =head2 undefer_sub my $coderef = undefer_sub \&Foo::name; If the passed coderef has been L 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. Exported by default. =head2 defer_info my $data = defer_info $sub; my ($name, $generator, $options, $undeferred_sub) = @$data; Returns original arguments to defer_sub, plus the undeferred version if this sub has already been undeferred. Note that $sub can be either the original deferred version or the undeferred version for convenience. Not 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 for support and contact information. =head1 AUTHORS See L for authors. =head1 COPYRIGHT AND LICENSE See L for the copyright and license. =cut Sub-Quote-2.005000/lib/Sub/Quote.pm0000644000000000000000000003625013236367202016647 0ustar00rootwheel00000000000000package Sub::Quote; sub _clean_eval { eval $_[0] } use strict; use warnings; use Sub::Defer qw(defer_sub); use Scalar::Util qw(weaken); use Exporter qw(import); use Carp qw(croak); BEGIN { our @CARP_NOT = qw(Sub::Defer) } use B (); BEGIN { *_HAVE_IS_UTF8 = defined &utf8::is_utf8 ? sub(){1} : sub(){0}; *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0}; } our $VERSION = '2.005000'; $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 { my $value = $_[0]; no warnings 'numeric'; ! defined $value ? 'undef()' # numeric detection : (!(_HAVE_IS_UTF8 && utf8::is_utf8($value)) && length( (my $dummy = '') & $value ) && 0 + $value eq $value && $value * 0 == 0 ) ? $value : _HAVE_PERLSTRING ? B::perlstring($value) : qq["\Q$value\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, $file, $line) = @{$options}{qw(attributes file line)}; if ($attributes) { /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_" for @$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) : ()), ($file ? (file => $file) : ()), ($line ? (line => $line) : ()), }; 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); Sub::Defer::_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 ) : ()), ($name ? () : ( package => $quoted_info->{package} )), }, ); 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, $file, $line) = @{$info}{qw(package hints warning_bits hintshash file line)}; $line ||= 1 if $file; my $line_mark = ''; if ($line) { $line_mark = "#line ".($line-1); if ($file) { $line_mark .= qq{ "$file"}; } $line_mark .= "\n"; } $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" .$line_mark ."# 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) { my $space = length($make_sub =~ tr/\n//); my $line = 0; $make_sub =~ s/^/sprintf "%${space}d: ", ++$line/emg; 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 { my @quoted = map { defined $_ ? ( $_->{unquoted} && ${$_->{unquoted}} ? (${ $_->{unquoted} } => $_) : (), $_->{deferred} ? ($_->{deferred} => $_) : (), ) : () } values %QUOTED; %QUOTED = @quoted; weaken($_) for values %QUOTED; } 1; __END__ =encoding utf-8 =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's C for an example using captures. Exported by default. =head3 options =over 2 =item C B. Set this option to not install the generated coderef into the passed subroutine name on undefer. =item C B. 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 The package that the quoted sub will be evaluated in. If not specified, the package from sub calling C will be used. =item C The value of L<< C<$^H> | perlvar/$^H >> to use for the code being evaluated. This captures the settings of the L pragma. If not specified, the value from the calling code will be used. =item C The value of L<< C<${^WARNING_BITS}> | perlvar/${^WARNING_BITS} >> to use for the code being evaluated. This captures the L set. If not specified, the warnings from the calling code will be used. =item C<%^H> The value of L<< C<%^H> | perlvar/%^H >> to use for the code being evaluated. This captures additional pragma settings. If not specified, the value from the calling code will be used if possible (on perl 5.10+). =item C The L to apply to the sub generated. Should be specified as an array reference. The attributes will be applied to both the generated sub and the deferred wrapper, if one is used. =item C The apparent filename to use for the code being evaluated. =item C The apparent line number to use for the code being evaluated. =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 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. =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. 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, 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 from a quote_sub'ed sub will not likely do what you intend. Instead of returning from the code you defined in C, 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 { do { return 1 if $condition; $morecode }; } 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 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 subs, care should be taken that user pragmas won't effect the rest of the code. =head1 SUPPORT Users' IRC: #moose on irc.perl.org =for :html L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org> Development and contribution IRC: #web-simple on irc.perl.org =for :html L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org> Bugtracker: L Git repository: L Git browser: L =head1 AUTHOR mst - Matt S. Trout (cpan:MSTROUT) =head1 CONTRIBUTORS frew - Arthur Axel "fREW" Schmidt (cpan:FREW) ribasushi - Peter Rabbitson (cpan:RIBASUSHI) Mithaldu - Christian Walde (cpan:MITHALDU) tobyink - Toby Inkster (cpan:TOBYINK) haarg - Graham Knop (cpan:HAARG) bluefeet - Aran Deltac (cpan:BLUEFEET) ether - Karen Etheridge (cpan:ETHER) dolmen - Olivier Mengué (cpan:DOLMEN) alexbio - Alessandro Ghedini (cpan:ALEXBIO) getty - Torsten Raudssus (cpan:GETTY) arcanez - Justin Hunter (cpan:ARCANEZ) kanashiro - Lucas Kanashiro (cpan:KANASHIRO) djerius - Diab Jerius (cpan:DJERIUS) =head1 COPYRIGHT Copyright (c) 2010-2016 the Sub::Quote L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. See L. =cut Sub-Quote-2.005000/maint/0000755000000000000000000000000013236367245015026 5ustar00rootwheel00000000000000Sub-Quote-2.005000/maint/Makefile.PL.include0000644000000000000000000000035713205543171020415 0ustar00rootwheel00000000000000BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar 0.001; use ExtUtils::MakeMaker 6.57_10 (); author 'mst - Matt S. Trout (cpan:MSTROUT) '; 1; Sub-Quote-2.005000/Makefile.PL0000644000000000000000000000547513205543171015671 0ustar00rootwheel00000000000000use strict; use warnings FATAL => 'all'; use 5.006; my %META = ( name => 'Sub-Quote', license => 'perl_5', prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, } }, build => { requires => { } }, test => { requires => { 'Test::More' => 0.94, 'Test::Fatal' => 0.003, }, }, runtime => { requires => { 'Scalar::Util' => 0, 'perl' => 5.006, }, recommends => { 'Sub::Name' => 0.08, }, }, develop => { requires => {}, }, }, resources => { repository => { url => 'https://github.com/moose/Sub-Quote.git', web => 'https://github.com/moose/Sub-Quote', type => 'git', }, x_IRC => 'irc://irc.perl.org/#moose', bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote', mailto => 'bug-Sub-Quote@rt.cpan.org', }, license => [ 'http://dev.perl.org/licenses/' ], }, no_index => { directory => [ 't', 'xt' ] }, x_authority => 'cpan:MSTROUT', ); my %MM_ARGS = ( PREREQ_PM => { ("$]" >= 5.008_000 ? () : ('Task::Weaken' => 0)), }, ); ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); ## END BOILERPLATE ########################################################### Sub-Quote-2.005000/MANIFEST0000644000000000000000000000112613236367246015050 0ustar00rootwheel00000000000000Changes lib/Sub/Defer.pm lib/Sub/Quote.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files t/croak-locations.t t/hints.t t/inline.t t/leaks.t t/lib/ErrorLocation.pm t/lib/InlineModule.pm t/lib/ThreadsCheck.pm t/quotify.t t/sub-defer-no-subname.t t/sub-defer-threads.t t/sub-defer.t t/sub-quote-threads.t t/sub-quote.t xt/release/kwalitee.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Sub-Quote-2.005000/META.json0000644000000000000000000000321113236367245015334 0ustar00rootwheel00000000000000{ "abstract" : "Efficient generation of subroutines via string eval", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Sub-Quote", "no_index" : { "directory" : [ "t", "xt" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : {} }, "runtime" : { "recommends" : { "Sub::Name" : "0.08" }, "requires" : { "Scalar::Util" : "0", "perl" : "5.006" } }, "test" : { "requires" : { "Test::Fatal" : "0.003", "Test::More" : "0.94" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Sub-Quote@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/moose/Sub-Quote.git", "web" : "https://github.com/moose/Sub-Quote" }, "x_IRC" : "irc://irc.perl.org/#moose" }, "version" : "2.005000", "x_authority" : "cpan:MSTROUT", "x_serialization_backend" : "JSON::PP version 2.97001" } Sub-Quote-2.005000/META.yml0000644000000000000000000000153013236367245015166 0ustar00rootwheel00000000000000--- abstract: 'Efficient generation of subroutines via string eval' author: - unknown build_requires: Test::Fatal: '0.003' Test::More: '0.94' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Sub-Quote no_index: directory: - t - xt recommends: Sub::Name: '0.08' requires: Scalar::Util: '0' perl: '5.006' resources: IRC: irc://irc.perl.org/#moose bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-Quote license: http://dev.perl.org/licenses/ repository: https://github.com/moose/Sub-Quote.git version: '2.005000' x_authority: cpan:MSTROUT x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Sub-Quote-2.005000/README0000644000000000000000000001725713236367246014613 0ustar00rootwheel00000000000000NAME Sub::Quote - Efficient generation of subroutines via string eval 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 DESCRIPTION This package provides performant ways to generate subroutines from strings. SUBROUTINES quote_sub my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 }; Arguments: ?$name, $code, ?\%captures, ?\%options $name is the subroutine where the coderef will be installed. $code is a string that will be turned into code. "\%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 "SYNOPSIS"'s "Silly::dagron" for an example using captures. Exported by default. options "no_install" Boolean. Set this option to not install the generated coderef into the passed subroutine name on undefer. "no_defer" 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. "package" The package that the quoted sub will be evaluated in. If not specified, the package from sub calling "quote_sub" will be used. "hints" The value of $^H to use for the code being evaluated. This captures the settings of the strict pragma. If not specified, the value from the calling code will be used. "warning_bits" The value of "${^WARNING_BITS}" to use for the code being evaluated. This captures the warnings set. If not specified, the warnings from the calling code will be used. "%^H" The value of "%^H" to use for the code being evaluated. This captures additional pragma settings. If not specified, the value from the calling code will be used if possible (on perl 5.10+). "attributes" The "Subroutine Attributes" in perlsub to apply to the sub generated. Should be specified as an array reference. The attributes will be applied to both the generated sub and the deferred wrapper, if one is used. "file" The apparent filename to use for the code being evaluated. "line" The apparent line number to use for the code being evaluated. 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. 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. 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 Boolean representing whether or not to localize the arguments. 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 "undef()". 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 "inlinify". $from is a string will be used as a hashref in the resulting code. The keys of %captures are the names of the variables and the values are ignored. $indent is the number of spaces to indent the result by. qsub my $hash = { coderef => qsub q{ print "hello"; }, other => 5, }; Arguments: $code Works exactly like "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. 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. CAVEATS Much of this is just string-based code-generation, and as a result, a few caveats apply. return Calling "return" from a quote_sub'ed sub will not likely do what you intend. Instead of returning from the code you defined in "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 { do { return 1 if $condition; $morecode }; } 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. pragmas "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 "Sub::Quote" subs, care should be taken that user pragmas won't effect the rest of the code. SUPPORT Users' IRC: #moose on irc.perl.org Development and contribution IRC: #web-simple on irc.perl.org Bugtracker: Git repository: Git browser: AUTHOR mst - Matt S. Trout (cpan:MSTROUT) CONTRIBUTORS frew - Arthur Axel "fREW" Schmidt (cpan:FREW) ribasushi - Peter Rabbitson (cpan:RIBASUSHI) Mithaldu - Christian Walde (cpan:MITHALDU) tobyink - Toby Inkster (cpan:TOBYINK) haarg - Graham Knop (cpan:HAARG) bluefeet - Aran Deltac (cpan:BLUEFEET) ether - Karen Etheridge (cpan:ETHER) dolmen - Olivier Mengué (cpan:DOLMEN) alexbio - Alessandro Ghedini (cpan:ALEXBIO) getty - Torsten Raudssus (cpan:GETTY) arcanez - Justin Hunter (cpan:ARCANEZ) kanashiro - Lucas Kanashiro (cpan:KANASHIRO) djerius - Diab Jerius (cpan:DJERIUS) COPYRIGHT Copyright (c) 2010-2016 the Sub::Quote "AUTHOR" and "CONTRIBUTORS" as listed above. LICENSE This library is free software and may be distributed under the same terms as perl itself. See . Sub-Quote-2.005000/t/0000755000000000000000000000000013236367245014161 5ustar00rootwheel00000000000000Sub-Quote-2.005000/t/croak-locations.t0000644000000000000000000000130513205543171017423 0ustar00rootwheel00000000000000use strict; use warnings; use Test::More; use lib 't/lib'; use ErrorLocation; 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::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 done_testing; Sub-Quote-2.005000/t/hints.t0000644000000000000000000001170613205543171015466 0ustar00rootwheel00000000000000BEGIN { %^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 strict; use warnings; no warnings 'once'; use Test::More; use Test::Fatal; use Sub::Quote qw( quote_sub unquote_sub quoted_from_sub ); { 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'; } } done_testing; Sub-Quote-2.005000/t/inline.t0000644000000000000000000000371313205543171015616 0ustar00rootwheel00000000000000use strict; use warnings; no warnings 'once'; use Test::More; use Test::Fatal; use Data::Dumper; use Sub::Quote qw( capture_unroll inlinify ); 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'; } done_testing; Sub-Quote-2.005000/t/leaks.t0000644000000000000000000000311513205543171015433 0ustar00rootwheel00000000000000use strict; use warnings; no warnings 'once'; use Test::More; use Test::Fatal; use Data::Dumper; use Sub::Quote qw( quote_sub unquote_sub quoted_from_sub ); { 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'; } done_testing; Sub-Quote-2.005000/t/lib/0000755000000000000000000000000013236367245014727 5ustar00rootwheel00000000000000Sub-Quote-2.005000/t/lib/ErrorLocation.pm0000644000000000000000000000456013205543171020042 0ustar00rootwheel00000000000000package ErrorLocation; use strict; use warnings; use Test::Builder; use Carp qw(croak); use Exporter 'import'; our @EXPORT = qw(location_ok); my $builder = Test::Builder->new; my $gen = 'A000'; sub location_ok ($$) { my ($code, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my ($pre) = $code =~ /\A(.*?)(?:## fail\n.*)?\n?\z/s; my $fail_line = 1 + $pre =~ tr/\n//; my $PACKAGE = "LocationTest::_".++$gen; my $sub = eval qq{ sub { package $PACKAGE; #line 1 LocationTestFile $code } }; my $full_trace; my $last_location; my $immediate; my $trace_capture = sub { my @c = caller; my ($location) = $_[0] =~ /^.* at (.*? line \d+)\.?$/; $location ||= sprintf "%s line %s", (caller(0))[1,2]; if (!$last_location || $last_location ne $location) { $last_location = $location; $immediate = $c[1] eq 'LocationTestFile'; { local %Carp::Internal; local %Carp::CarpInternal; $full_trace = Carp::longmess(''); } $full_trace =~ s/\A.*\n//; $full_trace =~ s/^\t//mg; $full_trace =~ s/^[^\n]+ called at ${\__FILE__} line [0-9]+\n.*//ms; if ($c[0] eq 'Carp') { $full_trace =~ s/.*?(^Carp::)/$1/ms; } else { my ($arg) = @_; $arg =~ s/\Q at $c[1] line $c[2]\E\.\n\z//; my $caller = 'CORE::die(' . Carp::format_arg($arg) . ") called at $location\n"; $full_trace =~ s/\A.*\n/$caller/; } $full_trace =~ s{^(.* called at )(\(eval [0-9]+\)(?:\[[^\]]*\])?) line ([0-9]+)\n}{ my ($prefix, $file, $line) = ($1, $2, $3); my $i = 0; while (my @c = caller($i++)) { if ($c[1] eq $file && $c[2] eq $line) { $file .= "[$c[0]]"; last; } } "$prefix$file line $line\n"; }meg; $full_trace =~ s/^/ /mg; } }; croak "$name - compile error: $@" if !$sub; local $@; eval { local $Carp::Verbose = 0; local $SIG{__WARN__}; local $SIG{__DIE__} = $trace_capture; $sub->(); 1; } and croak "$name - code did not fail!"; croak "died directly in test code: $@" if $immediate; delete $LocationTest::{"_$gen"}; my ($location) = $@ =~ /.* at (.*? line \d+)\.?$/; $builder->is_eq($location, "LocationTestFile line $fail_line", $name) or $builder->diag(" error:\n $@\n full trace:\n$full_trace"), return !1; } 1; Sub-Quote-2.005000/t/lib/InlineModule.pm0000644000000000000000000000172613205543171017645 0ustar00rootwheel00000000000000package InlineModule; use strict; use warnings; BEGIN { *_HAS_PERLIO = "$]" >= 5.008_000 ? sub(){1} : sub(){0}; } sub import { my ($class, %modules) = @_; unshift @INC, inc_hook(%modules); } sub inc_hook { my (%modules) = @_; my %files = map { (my $file = "$_.pm") =~ s{::}{/}g; $file => $modules{$_}; } keys %modules; sub { return unless exists $files{$_[1]}; my $module = $files{$_[1]}; if (!defined $module) { die "Can't locate $_[1] in \@INC (hidden) (\@INC contains: @INC).\n"; } inc_module($module); } } sub inc_module { my $code = $_[0]; if (_HAS_PERLIO) { open my $fh, '<', \$code or die "error loading module: $!"; return $fh; } else { my $pos = 0; my $last = length $code; return (sub { return 0 if $pos == $last; my $next = (1 + index $code, "\n", $pos) || $last; $_ .= substr $code, $pos, $next - $pos; $pos = $next; return 1; }); } } 1; Sub-Quote-2.005000/t/lib/ThreadsCheck.pm0000644000000000000000000000202613205543171017603 0ustar00rootwheel00000000000000package ThreadsCheck; use strict; use warnings; no warnings 'once'; sub _skip { print "1..0 # SKIP $_[0]\n"; exit 0; } sub import { my ($class, $op) = @_; require Config; if (! $Config::Config{useithreads}) { _skip "your perl does not support ithreads"; } elsif (system "$^X", __FILE__, 'installed') { _skip "threads.pm not installed"; } elsif (system "$^X", __FILE__, 'create') { _skip "threads are broken on this machine"; } } if (!caller && @ARGV) { my ($op) = @ARGV; require POSIX; if ($op eq 'installed') { eval { require threads } or POSIX::_exit(1); } elsif ($op eq 'create') { require threads; require File::Spec; open my $olderr, '>&', \*STDERR or die "can't dup filehandle: $!"; open STDERR, '>', File::Spec->devnull or die "can't open null: $!"; my $out = threads->create(sub { 1 })->join; open STDERR, '>&', $olderr; POSIX::_exit((defined $out && $out eq '1') ? 0 : 1); } else { die "Invalid option $op!\n"; } POSIX::_exit(0); } 1; Sub-Quote-2.005000/t/quotify.t0000644000000000000000000000502413205543171016035 0ustar00rootwheel00000000000000use strict; use warnings; no warnings 'once'; use Test::More; use Test::Fatal; use Data::Dumper; use B; use constant HAVE_UTF8 => defined &utf8::upgrade && defined &utf8::is_utf8;; use Sub::Quote qw( quotify ); sub _dump { my $value = shift; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 1; my $d = Data::Dumper::Dumper($value); $d =~ s/\s+$//; $d; } sub is_numeric { my $val = shift; my $sv = B::svref_2object(\$val); !!($sv->FLAGS & ( B::SVp_IOK | B::SVp_NOK ) ) } my %flags; { no strict 'refs'; for my $flag (qw( SVs_TEMP SVs_OBJECT SVs_GMG SVs_SMG SVs_RMG SVf_IOK SVf_NOK SVf_POK SVf_OOK SVf_FAKE SVf_READONLY SVf_PROTECT SVf_BREAK SVp_IOK SVp_NOK SVp_POK )) { if (defined &{'B::'.$flag}) { $flags{$flag} = &{'B::'.$flag}; } } } sub flags { my $val = shift; my $flags = B::svref_2object(\$val)->FLAGS; join ' ', sort grep $flags & $flags{$_}, keys %flags; } BEGIN { if (HAVE_UTF8) { eval ' sub eval_utf8 { my $value = shift; my $output; eval "use utf8; \$output = $value; 1;" or die $@; $output; } 1; ' or die $@; } } my @numbers = ( -20 .. 20, (map 1 / $_, -10 .. -2, 2 .. 10), ); my @strings = ( "\x00", "a", "\xC3\x84", "\xE8", "\xFC", "\xFF", "\x{1F4A9}", ); if (HAVE_UTF8) { utf8::downgrade($_, 1) for @strings; } my @utf8_strings; if (HAVE_UTF8) { @utf8_strings = @strings; utf8::upgrade($_) for @utf8_strings; } my @quotify = ( undef, (map { my $used_as_string = $_; my $string = "$used_as_string"; ($_, $used_as_string, $string); } @numbers), @strings, @utf8_strings, ); my $eval_utf8; for my $value (@quotify) { my $value_name = _dump($value) . (HAVE_UTF8 && utf8::is_utf8($value) ? ' utf8' : '') . (is_numeric($value) ? ' num' : ''); my $quoted = quotify(my $copy = $value); utf8::downgrade($quoted, 1) if HAVE_UTF8; is flags($copy), flags($value), "$value_name: quotify doesn't modify input"; my $evaled; eval "\$evaled = $quoted; 1" or die $@; is is_numeric($evaled), is_numeric($value), "$value_name: numeric status maintained"; is $value, $evaled, "$value_name: value maintained"; if (HAVE_UTF8) { my $utf8_evaled = eval_utf8($quoted); is is_numeric($value), is_numeric($utf8_evaled), "$value_name: numeric status maintained under utf8"; is $value, $utf8_evaled, "$value_name: value maintained under utf8"; } } done_testing; Sub-Quote-2.005000/t/sub-defer-no-subname.t0000644000000000000000000000022413205543171020250 0ustar00rootwheel00000000000000use strict; use warnings; use lib 't/lib'; use InlineModule 'Sub::Name' => undef, 'Sub::Util' => undef, ; do './t/sub-defer.t'; die $@ if $@; Sub-Quote-2.005000/t/sub-defer-threads.t0000644000000000000000000000140013205543171017633 0ustar00rootwheel00000000000000use lib 't/lib'; use ThreadsCheck; use threads; use strict; use warnings; 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; Sub-Quote-2.005000/t/sub-defer.t0000644000000000000000000002013213236366716016222 0ustar00rootwheel00000000000000use strict; use warnings; use Test::More; use Test::Fatal; use Sub::Defer qw(defer_sub undefer_sub undefer_all undefer_package defer_info); use Scalar::Util qw(refaddr weaken); 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 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 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 = defer_info($foo_string); undef $foo; is exception { Sub::Defer->CLONE }, undef, 'CLONE works when quoted 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'; } { my $guff; my $deferred = defer_sub "Foo::flub", sub { sub { $guff } }; my $undeferred = undefer_sub($deferred); my $undeferred_addr = refaddr($undeferred); my $deferred_str = "$deferred"; weaken($deferred); is $deferred, undef, 'no strong external refs kept for deferred named subs'; is defer_info($deferred_str), undef, 'defer_info on expired deferred named sub gives undef'; isnt refaddr(undefer_sub($deferred_str)), $undeferred_addr, 'undefer_sub on expired deferred named sub does not give undeferred sub'; is refaddr(undefer_sub($undeferred)), $undeferred_addr, 'undefer_sub on undeferred named sub after deferred expiry gives undeferred'; } { my $guff; my $deferred = defer_sub undef, sub { sub { $guff } }; my $undeferred = undefer_sub($deferred); my $undeferred_addr = refaddr($undeferred); my $deferred_str = "$deferred"; my $undeferred_str = "$undeferred"; weaken($deferred); is $deferred, undef, 'no strong external refs kept for deferred unnamed subs'; is defer_info($deferred_str), undef, 'defer_info on expired deferred unnamed sub gives undef'; isnt refaddr(undefer_sub($deferred_str)), $undeferred_addr, 'undefer_sub on expired deferred unnamed sub does not give undeferred sub'; is refaddr(undefer_sub($undeferred)), $undeferred_addr, 'undefer_sub on undeferred unnamed sub after deferred expiry gives undeferred'; } { my $guff; my $deferred = defer_sub "Foo::gwarf", sub { sub { $guff } }; my $undeferred = undefer_sub($deferred); my $undeferred_addr = refaddr($undeferred); my $deferred_str = "$deferred"; my $undeferred_str = "$undeferred"; delete $Foo::{gwarf}; weaken($deferred); weaken($undeferred); is $undeferred, undef, 'no strong external refs kept for undeferred named subs'; is defer_info($undeferred_str), undef, 'defer_info on expired undeferred named sub gives undef'; isnt refaddr(undefer_sub($undeferred_str)), $undeferred_addr, 'undefer_sub on expired undeferred named sub does not give undeferred sub'; } { my $guff; my $deferred = defer_sub undef, sub { sub { $guff } }; my $undeferred = undefer_sub($deferred); my $undeferred_addr = refaddr($undeferred); my $deferred_str = "$deferred"; my $undeferred_str = "$undeferred"; weaken($deferred); weaken($undeferred); is $undeferred, undef, 'no strong external refs kept for undeferred unnamed subs'; is defer_info($undeferred_str), undef, 'defer_info on expired undeferred unnamed sub gives undef'; isnt refaddr(undefer_sub($undeferred_str)), $undeferred_addr, 'undefer_sub on expired undeferred unnamed sub does not give undeferred sub'; } { my $guff; my $deferred = defer_sub undef, sub { sub { $guff } }; my $undeferred = undefer_sub($deferred); weaken($deferred); ok defer_info($undeferred), 'defer_info still returns info for undeferred unnamed subs after deferred sub expires'; } { my $guff; my $deferred = defer_sub undef, sub { sub { $guff } }; my $undeferred = undefer_sub($deferred); weaken($deferred); Sub::Defer->CLONE; ok defer_info($undeferred), 'defer_info still returns info for undeferred unnamed subs after deferred sub expires and CLONE'; } { my $guff; my $gen = sub { +sub :lvalue { $guff } }; my $deferred = defer_sub 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] }; is_deeply defer_info($deferred), [ 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] } ], 'defer_info gives name, generator, options before undefer'; my $undeferred = undefer_sub $deferred; is_deeply defer_info($deferred), [ 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] }, $undeferred ], 'defer_info on deferred gives name, generator, options after undefer'; is_deeply defer_info($undeferred), [ 'Foo::blorp', $gen, { attributes => [ 'lvalue' ] }, $undeferred ], 'defer_info on undeferred gives name, generator, options after undefer'; } done_testing; Sub-Quote-2.005000/t/sub-quote-threads.t0000644000000000000000000000171313205543171017712 0ustar00rootwheel00000000000000use lib 't/lib'; use ThreadsCheck; use threads; use strict; use warnings; 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; Sub-Quote-2.005000/t/sub-quote.t0000644000000000000000000001405113205543171016261 0ustar00rootwheel00000000000000use strict; use warnings; no warnings 'once'; use Test::More; use Test::Fatal; use Sub::Quote qw( quote_sub quoted_from_sub unquote_sub qsub capture_unroll inlinify sanitize_identifier quotify ); use B; 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<; Guh }; my $err = exception { $broken_quoted->() }; like( $err, qr/Eval went very, very wrong/, "quoted sub with syntax error dies when called" ); my ($location) = $err =~ /syntax error at .+? line (\d+)/; like( $err, qr/$location:\s*return 5<;/, "syntax errors include usable line numbers" ); 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'; { 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'; } my @stuff = (qsub q{ print "hello"; }, 1, 2); is scalar @stuff, 3, 'qsub only accepts a single parameter'; { 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'; } { my $sub = quote_sub q{ sub { join " line ", (caller(0))[1,2] }->() }, {}, { file => "welp.pl", line => 42 }; is $sub->(), "welp.pl line 42", "file and line provided"; } done_testing; Sub-Quote-2.005000/xt/0000755000000000000000000000000013236367245014351 5ustar00rootwheel00000000000000Sub-Quote-2.005000/xt/release/0000755000000000000000000000000013236367245015771 5ustar00rootwheel00000000000000Sub-Quote-2.005000/xt/release/kwalitee.t0000644000000000000000000000074613205271502017754 0ustar00rootwheel00000000000000use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'these tests are for release candidate testing' unless $ENV{RELEASE_TESTING}; } use CPAN::Meta; use Test::Kwalitee 'kwalitee_ok'; my ($meta_file) = grep -e, qw(MYMETA.json MYMETA.yml META.json META.yml) or die "unable to find MYMETA or META file!"; my $meta = CPAN::Meta->load_file($meta_file)->as_struct; my @ignore = keys %{$meta->{x_cpants}{ignore}}; kwalitee_ok(map "-$_", @ignore); done_testing;