X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSub%2FQuote.pm;h=3551aeb8afb9f16931342c0d5c206f1d9e92c528;hb=1108b2e2131e2f72dbd1a43afe5e8940b9e85931;hp=f8087e7b853336e66ed6e0e851a80d6ce479a0d0;hpb=0d39f9d397a590b65690ec0ac4a2384c82f00944;p=gitmo%2FMoo.git diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm index f8087e7..3551aeb 100644 --- a/lib/Sub/Quote.pm +++ b/lib/Sub/Quote.pm @@ -6,14 +6,15 @@ sub _clean_eval { eval $_[0] } use Sub::Defer; use B 'perlstring'; +use Scalar::Util qw(weaken); use base qw(Exporter); our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); -our %QUOTE_OUTSTANDING; - our %QUOTED; +our %WEAK_REFS; + sub capture_unroll { my ($from, $captures, $indent) = @_; join( @@ -36,62 +37,12 @@ sub inlinify { $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }'; } } else { - $do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }'; - } -} - -sub _unquote_all_outstanding { - return unless %QUOTE_OUTSTANDING; - my ($assembled_code, @assembled_captures, @localize_these) = ''; - # we sort the keys in order to make debugging more predictable - foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) { - my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}}; - - push @localize_these, $name if $name; - - my $make_sub = "{\n"; - - if (keys %$captures) { - my $ass_cap_count = @assembled_captures; - $make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2); - push @assembled_captures, $captures; - } - - my $o_quoted = perlstring $outstanding; - $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" - ); - $make_sub .= $code; - $make_sub .= " }".($name ? '' : ';')."\n"; - if ($name) { - $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; + my $assign = ''; + if ($local || $args ne '@_') { + $assign = ($local ? 'local ' : '').'@_ = ('.$args.'); '; } - $make_sub .= "}\n"; - $assembled_code .= $make_sub; + $do.$assign.$code.' }'; } - my $debug_code = $assembled_code; - if (@localize_these) { - $debug_code = - "# localizing: ".join(', ', @localize_these)."\n" - .$assembled_code; - $assembled_code = join("\n", - (map { "local *${_};" } @localize_these), - 'eval '.perlstring($assembled_code).'; die $@ if $@;' - ); - } else { - $ENV{SUB_QUOTE_DEBUG} && warn $assembled_code; - } - $assembled_code .= "\n1;"; - unless (_clean_eval $assembled_code, \@assembled_captures) { - die "Eval went very, very wrong:\n\n${debug_code}\n\n$@"; - } - $ENV{SUB_QUOTE_DEBUG} && warn $debug_code; - %QUOTE_OUTSTANDING = (); } sub quote_sub { @@ -114,20 +65,52 @@ sub quote_sub { unquote_sub($outstanding); }; $outstanding = "$deferred"; - $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [ - $name, $code, $captures - ]; + $QUOTED{$outstanding} = [ $name, $code, $captures ]; + weaken($WEAK_REFS{$outstanding} = $deferred); return $deferred; } sub quoted_from_sub { my ($sub) = @_; - $QUOTED{$sub||''}; + $WEAK_REFS{$sub||''} and $QUOTED{$sub||''}; } sub unquote_sub { my ($sub) = @_; - _unquote_all_outstanding; + unless ($QUOTED{$sub}[3]) { + my ($name, $code, $captures) = @{$QUOTED{$sub}}; + + my $make_sub = "{\n"; + + if (keys %$captures) { + $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" + ); + $make_sub .= $code; + $make_sub .= " }".($name ? '' : ';')."\n"; + if ($name) { + $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; + } + $make_sub .= "}\n1;\n"; + $ENV{SUB_QUOTE_DEBUG} && warn $make_sub; + { + local $@; + no strict 'refs'; + local *{$name} if $name; + unless (_clean_eval $make_sub, $captures) { + die "Eval went very, very wrong:\n\n${make_sub}\n\n$@"; + } + } + } $QUOTED{$sub}[3]; } @@ -147,10 +130,10 @@ Sub::Quote - efficient generation of subroutines via string eval quote_sub 'Silly::doggy', q{ print "woof" }; - my $sound; $$sound = 0; + my $sound = 0; quote_sub 'Silly::dagron', - q{ print ++$$sound % 2 ? 'burninate' : 'roar' }, + q{ print ++$sound % 2 ? 'burninate' : 'roar' }, { '$sound' => \$sound }; And elsewhere: @@ -169,7 +152,7 @@ This package provides performant ways to generate subroutines from strings. =head2 quote_sub - my $coderef = quote_sub 'Foo:bar', q{ print $x++ . "\n" }, { '$x' => \0 }; + my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 }; Arguments: ?$name, $code, ?\%captures, ?\%options @@ -195,10 +178,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. @@ -216,7 +196,7 @@ version for convenience. =head2 inlinify - my $prelude = capture_unroll { + my $prelude = capture_unroll '$captures', { '$x' => 1, '$y' => 2, }; @@ -233,11 +213,71 @@ 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 + +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 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.