From: Robin Houston Date: Tue, 17 Apr 2001 20:01:59 +0000 (+0100) Subject: ambient pragmas X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=08c6f5ec7f15b47fc7de94977cecfa7d547d74bb;p=p5sagit%2Fp5-mst-13.2.git ambient pragmas Message-ID: <20010417200159.A4882@puffinry.freeserve.co.uk> p4raw-id: //depot/perl@9727 --- diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 02a271b..1ac5db0 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -94,9 +94,6 @@ use strict; # Todo: # - finish tr/// changes # - add option for even more parens (generalize \&foo change) -# - {} around variables in strings ("${var}letters") -# base/lex.t 25-27 -# comp/term.t 11 # - left/right context # - recognize `use utf8', `use integer', etc # - treat top-level block specially for incremental output @@ -356,8 +353,11 @@ sub new { $self->{'linenums'} = 0; $self->{'parens'} = 0; $self->{'ex_const'} = "'???'"; - $self->{'arybase'} = 0; - $self->{'warnings'} = "\0"x12; + + $self->{'ambient_arybase'} = 0; + $self->{'ambient_warnings'} = "\0"x12; + $self->init(); + while (my $arg = shift @_) { if (substr($arg, 0, 2) eq "-u") { $self->stash_subs(substr($arg, 2)); @@ -376,6 +376,16 @@ sub new { return $self; } +# Initialise the contextual information, either from +# defaults provided with the ambient_pragmas method, +# or from perl's own defaults otherwise. +sub init { + my $self = shift; + + $self->{'arybase'} = $self->{'ambient_arybase'}; + $self->{'warnings'} = $self->{'ambient_warnings'}; +} + sub compile { my(@args) = @_; return sub { @@ -400,9 +410,94 @@ sub coderef2text { my $self = shift; my $sub = shift; croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE"; + + $self->init(); return $self->indent($self->deparse_sub(svref_2object($sub))); } +sub ambient_pragmas { + my $self = shift; + my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12); + + while (@_ > 1) { + my $name = shift(); + my $val = shift(); + + if ($name eq 'strict') { + require strict; + + if ($val eq 'none') { + $hint_bits &= ~strict::bits(qw/refs subs vars/); + next(); + } + + my @names; + if ($val eq "all") { + @names = qw/refs subs vars/; + } + elsif (ref $val) { + @names = @$val; + } + else { + @names = split/\s+/, $val; + } + $hint_bits |= strict::bits(@names); + } + + elsif ($name eq '$[') { + $arybase = $val; + } + + elsif ($name eq 'integer') { + require integer; + if ($val) { + $hint_bits |= $integer::hint_bits; + } + else { + $hint_bits &= ~$integer::hint_bits; + } + } + + elsif ($name eq 'warnings') { + require warnings; + if ($val eq 'none') { + $warning_bits = "\0"x12; + next(); + } + + my @names; + if (ref $val) { + @names = @$val; + } + else { + @names = split/\s+/, $val; + } + + $warning_bits |= warnings::bits(@names); + } + + elsif ($name eq 'warning_bits') { + $warning_bits = $val; + } + + elsif ($name eq 'hint_bits') { + $hint_bits = $val; + } + + else { + croak "Unknown pragma type: $name"; + } + } + if (@_) { + croak "The ambient_pragmas method expects an even number of args"; + } + + $self->{'ambient_arybase'} = $arybase; + $self->{'ambient_warnings'} = $warning_bits; + + # $^H pragmas not yet implemented here +} + sub deparse { my $self = shift; my($op, $cx) = @_; @@ -799,7 +894,8 @@ sub gv_name { return $stash . $name; } -# Notice how subs and formats are inserted between statements here +# Notice how subs and formats are inserted between statements here; +# also $[ assignments and the warnings pragma. sub pp_nextstate { my $self = shift; my($op, $cx) = @_; @@ -819,6 +915,7 @@ sub pp_nextstate { push @text, "\f#line " . $op->line . ' "' . $op->file, qq'"\n'; } + if ($self->{'arybase'} != $op->arybase) { push @text, '$[ = '. $op->arybase .";\n"; $self->{'arybase'} = $op->arybase; @@ -837,13 +934,18 @@ sub pp_nextstate { } if ($self->{'warnings'} ne $warning_bits) { - push @text, 'BEGIN {${^WARNING_BITS} = '. cstring($warning_bits) ."}\n"; + push @text, declare_warnings($self->{'warnings'}, $warning_bits); $self->{'warnings'} = $warning_bits; } return join("", @text); } +sub declare_warnings { + my ($from, $to) = @_; + return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."};\n"; +} + sub pp_dbstate { pp_nextstate(@_) } sub pp_setstate { pp_nextstate(@_) } @@ -2380,6 +2482,16 @@ sub unback { return $str; } +# Remove backslashes which precede literal control characters, +# to avoid creating ambiguity when we escape the latter. +sub re_unback { + my($str) = @_; + + # the insane complexity here is due to the behaviour of "\c\" + $str =~ s/(^|[^\\]|\\c\\)(?name; if ($type eq "const") { - return re_uninterp($self->const_sv($op)->PV); + return re_uninterp(escape_str(re_unback($self->const_sv($op)->PV))); } elsif ($type eq "concat") { my $first = $self->re_dq($op->first); my $last = $self->re_dq($op->last); @@ -2822,7 +2934,7 @@ sub matchop { $kid = $kid->sibling; } if (null $kid) { - $re = re_uninterp(escape_str($op->precomp)); + $re = re_uninterp(escape_str(re_unback($op->precomp))); } else { $re = $self->deparse($kid, 1); } @@ -2909,7 +3021,7 @@ sub pp_subst { } } if (null $kid) { - $re = re_uninterp(escape_str($op->precomp)); + $re = re_uninterp(escape_str(re_unback($op->precomp))); } else { $re = $self->deparse($kid, 1); } @@ -3161,6 +3273,108 @@ after B<-MO=Deparse> should be given as separate strings. Some options, like B<-u>, don't make sense for a single subroutine, so don't pass them. +=head2 ambient_pragmas + + $deparse->ambient_pragmas(strict => 'all', '$[' => $[); + +The compilation of a subroutine can be affected by a few compiler +directives, B. These are: + +=over 4 + +=item * + +use strict; + +=item * + +use warnings; + +=item * + +Assigning to the special variable $[ + +=item * + +use integer; + +=back + +Ordinarily, if you use B::Deparse on a subroutine which has +been compiled in the presence of one or more of these pragmas, +the output will include statements to turn on the appropriate +directives. So if you then compile the code returned by coderef2text, +it will behave the same way as the subroutine which you deparsed. + +However, you may know that you intend to use the results in a +particular context, where some pragmas are already in scope. In +this case, you use the B method to describe the +assumptions you wish to make. + +The parameters it accepts are: + +=over 4 + +=item strict + +Takes a string, possibly containing several values separated +by whitespace. The special values "all" and "none" mean what you'd +expect. + + $deparse->ambient_pragmas(strict => 'subs refs'); + +=item $[ + +Takes a number, the value of the array base $[. + +=item integer + +If the value is true, then the B pragma is assumed to +be in the ambient scope, otherwise not. + +=item warnings + +Takes a string, possibly containing a whitespace-separated list of +values. The values "all" and "none" are special, again. It's also +permissible to pass an array reference here. + + $deparser->ambient_pragmas(warnings => [qw[void io]]); + +If one of the values is the string "FATAL", then all the warnings +in that list will be considered fatal, just as with the B +pragma itself. Should you need to specify that some warnings are +fatal, and others are merely enabled, you can pass the B +parameter twice: + + $deparser->ambient_pragmas( + warnings => 'all', + warnings => [FATAL => qw/void io/], + ); + +See L for more information about lexical warnings. + +=item hint_bits + +=item warning_bits + +These two parameters are used to specify the ambient pragmas in +the format used by the special variables $^H and ${^WARNING_BITS}. + +They exist principally so that you can write code like: + + { my ($hint_bits, $warning_bits); + BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} + $deparser->ambient_pragmas ( + hint_bits => $hint_bits, + warning_bits => $warning_bits, + '$[' => 0 + $[ + ); } + +which specifies that the ambient pragmas are exactly those which +are in scope at the point of calling. + +=back + =head2 coderef2text $body = $deparse->coderef2text(\&func) diff --git a/t/lib/b.t b/t/lib/b.t index 9cadaf7..7681b4d 100755 --- a/t/lib/b.t +++ b/t/lib/b.t @@ -25,6 +25,16 @@ use B::Deparse; my $deparse = B::Deparse->new() or print "not "; ok; +# Tell B::Deparse about our ambient pragmas +{ my ($hint_bits, $warning_bits); + BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} + $deparse->ambient_pragmas ( + hint_bits => $hint_bits, + warning_bits => $warning_bits, + '$[' => 0 + $[ + ); +} + print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1}); ok;