X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSub%2FQuote.pm;h=8016b06f15886455912df4305a61337ebe7859ef;hb=350f2de6ebd85fd6fc5699c0773e6737756bac36;hp=337815fb5df282c916661297fa259fa1e9388804;hpb=8a0ad775e4dc6869662f15f2c01dd6410887ee5b;p=gitmo%2FMoo.git diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm index 337815f..8016b06 100644 --- a/lib/Sub/Quote.pm +++ b/lib/Sub/Quote.pm @@ -9,9 +9,10 @@ use B 'perlstring'; use Scalar::Util qw(weaken); use base qw(Exporter); -our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); +our $VERSION = '1.003001'; +$VERSION = eval $VERSION; -our %QUOTE_OUTSTANDING; +our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); our %QUOTED; @@ -39,62 +40,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 { @@ -108,34 +59,69 @@ 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"; - $QUOTE_OUTSTANDING{$outstanding} = $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 { my ($sub) = @_; - _unquote_all_outstanding; + unless ($QUOTED{$sub}[3]) { + my ($name, $code, $captures) = @{$QUOTED{$sub}}; + + my $make_sub = "{\n"; + + my %captures = $captures ? %$captures : (); + $captures{'$_QUOTED'} = \$QUOTED{$sub}; + $make_sub .= capture_unroll("\$_[1]", \%captures, 2); + + $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" + : " \$_QUOTED->[3] = sub {\n" + ); + $make_sub .= $code; + $make_sub .= " }".($name ? '' : ';')."\n"; + if ($name) { + $make_sub .= " \$_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]; } +sub CLONE { + %QUOTED = map { defined $_ ? ($_->[4] => $_) : () } values %QUOTED; + weaken($_) for values %QUOTED; +} + 1; +__END__ =head1 NAME @@ -151,10 +137,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: @@ -173,7 +159,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 @@ -182,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 @@ -199,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. @@ -220,7 +206,7 @@ version for convenience. =head2 inlinify - my $prelude = capture_unroll { + my $prelude = capture_unroll '$captures', { '$x' => 1, '$y' => 2, }; @@ -237,11 +223,73 @@ 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. + +=cut