X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSub%2FQuote.pm;h=8016b06f15886455912df4305a61337ebe7859ef;hb=350f2de6ebd85fd6fc5699c0773e6737756bac36;hp=d067e2a2e1a68c42471e4d59534614f0296ff801;hpb=9c8204612cac46da05778bf98efa6b45ae91c62b;p=gitmo%2FMoo.git diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm index d067e2a..8016b06 100644 --- a/lib/Sub/Quote.pm +++ b/lib/Sub/Quote.pm @@ -9,6 +9,9 @@ use B 'perlstring'; use Scalar::Util qw(weaken); use base qw(Exporter); +our $VERSION = '1.003001'; +$VERSION = eval $VERSION; + our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); our %QUOTED; @@ -37,7 +40,11 @@ sub inlinify { $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }'; } } else { - $do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }'; + my $assign = ''; + if ($local || $args ne '@_') { + $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); '; + } + $do.$assign.$code.' }'; } } @@ -52,23 +59,22 @@ sub quote_sub { (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH') ? pop : {}; - my $captures = pop if ref($_[-1]) eq 'HASH'; + my $captures = ref($_[-1]) eq 'HASH' ? pop : undef; undef($captures) if $captures && !keys %$captures; my $code = pop; my $name = $_[0]; - my $outstanding; + my $quoted_info; my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { - unquote_sub($outstanding); + unquote_sub($quoted_info->[4]); }; - $outstanding = "$deferred"; - $QUOTED{$outstanding} = [ $name, $code, $captures ]; - weaken($WEAK_REFS{$outstanding} = $deferred); + $quoted_info = [ $name, $code, $captures, undef, $deferred ]; + weaken($QUOTED{$deferred} = $quoted_info); return $deferred; } sub quoted_from_sub { my ($sub) = @_; - $WEAK_REFS{$sub||''} and $QUOTED{$sub||''}; + $QUOTED{$sub||''}; } sub unquote_sub { @@ -78,23 +84,22 @@ sub unquote_sub { my $make_sub = "{\n"; - if (keys %$captures) { - $make_sub .= capture_unroll("\$_[1]", $captures, 2); - } + my %captures = $captures ? %$captures : (); + $captures{'$_QUOTED'} = \$QUOTED{$sub}; + $make_sub .= capture_unroll("\$_[1]", \%captures, 2); - my $o_quoted = perlstring $sub; $make_sub .= ( $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} {\n" - : " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n" + : " \$_QUOTED->[3] = sub {\n" ); $make_sub .= $code; $make_sub .= " }".($name ? '' : ';')."\n"; if ($name) { - $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; + $make_sub .= " \$_QUOTED->[3] = \\&${name}\n"; } $make_sub .= "}\n1;\n"; $ENV{SUB_QUOTE_DEBUG} && warn $make_sub; @@ -102,7 +107,7 @@ sub unquote_sub { local $@; no strict 'refs'; local *{$name} if $name; - unless (_clean_eval $make_sub, $captures) { + unless (_clean_eval $make_sub, \%captures) { die "Eval went very, very wrong:\n\n${make_sub}\n\n$@"; } } @@ -110,7 +115,13 @@ sub unquote_sub { $QUOTED{$sub}[3]; } +sub CLONE { + %QUOTED = map { defined $_ ? ($_->[4] => $_) : () } values %QUOTED; + weaken($_) for values %QUOTED; +} + 1; +__END__ =head1 NAME @@ -157,7 +168,10 @@ 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. See the L's C for an example using captures. +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. =head3 options @@ -174,10 +188,7 @@ passed subroutine name on undefer. my $coderef = unquote_sub $sub; -Forcibly replace subroutine with actual code. Note that for performance -reasons all quoted subs declared so far will be globally unquoted/parsed in -a single eval. This means that if you have a syntax error in one of your -quoted subs you may find out when some other sub is unquoted. +Forcibly replace subroutine with actual code. If $sub is not a quoted sub, this is a no-op. @@ -195,7 +206,7 @@ version for convenience. =head2 inlinify - my $prelude = capture_unroll { + my $prelude = capture_unroll '$captures', { '$x' => 1, '$y' => 2, }; @@ -212,14 +223,17 @@ arguments. =head2 capture_unroll - my $prelude = 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. The keys are the names of the variables and the values are (duh) -the values. Note that references work as values. +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. =head1 CAVEATS @@ -251,3 +265,31 @@ It might turn up in the intended context as follows: 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 strictures + +Sub::Quote compiles quoted subs in an environment where C<< use strictures >> +is in effect. L enables L and FATAL L. + +The following dies I<< Use of uninitialized value in print... >> + + no warnings; + quote_sub 'Silly::kitty', q{ print undef }; + +If you need to disable parts of strictures, do it within the quoted sub: + + quote_sub 'Silly::kitty', q{ no warnings; print undef }; + +=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