From: Robin Houston Date: Thu, 12 Apr 2001 20:12:27 +0000 (+0100) Subject: multiple B::* changes X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a9b44b9a8839e34e1280d3da2fff4df45384659;p=p5sagit%2Fp5-mst-13.2.git multiple B::* changes Message-ID: <20010412201226.A30940@puffinry.freeserve.co.uk> p4raw-id: //depot/perl@9725 --- diff --git a/ext/B/B.pm b/ext/B/B.pm index 7ee1d19..a33ff2b 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -66,7 +66,12 @@ sub B::GV::SAFENAME { # The regex below corresponds to the isCONTROLVAR macro # from toke.c - $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^". + chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e; + + # When we say unicode_to_native we really mean ascii_to_native, + # which matters iff this is a non-ASCII platform (EBCDIC). + return $name; } diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index cb352eb..dd37ecc 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -283,7 +283,7 @@ $priv{$_}{16} = "TARGMY" "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", "setpriority", "time", "sleep"); -@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN"); +@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", '$[', "BARE", "WARN"); $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; $priv{"list"}{64} = "GUESSED"; $priv{"delete"}{64} = "SLICE"; @@ -339,7 +339,16 @@ sub concise_op { $h{svclass} = $h{svaddr} = $h{svval} = ""; if ($h{class} eq "PMOP") { my $precomp = $op->precomp; - $precomp = defined($precomp) ? "/$precomp/" : ""; + if (defined $precomp) { + # Escape literal control sequences + for ($precomp) { + s/\t/\\t/g; s/\n/\\n/g; s/\r/\\r/g; + # How can we do the below portably? + #s/([\0-\037\177-\377])/"\\".sprintf("%03o", ord($1))/eg; + } + $precomp = "/$precomp/"; + } + else { $precomp = ""; } my $pmreplroot = $op->pmreplroot; my ($pmreplroot, $pmreplstart); if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) { diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index d08ccac..02a271b 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -8,11 +8,12 @@ package B::Deparse; use Carp 'cluck', 'croak'; -use B qw(class main_root main_start main_cv svref_2object opnumber +use B qw(class main_root main_start main_cv svref_2object opnumber cstring OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY + OPpCONST_ARYBASE SVf_IOK SVf_NOK SVf_ROK SVf_POK CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE @@ -355,6 +356,8 @@ sub new { $self->{'linenums'} = 0; $self->{'parens'} = 0; $self->{'ex_const'} = "'???'"; + $self->{'arybase'} = 0; + $self->{'warnings'} = "\0"x12; while (my $arg = shift @_) { if (substr($arg, 0, 2) eq "-u") { $self->stash_subs(substr($arg, 2)); @@ -406,6 +409,8 @@ sub deparse { # cluck if class($op) eq "NULL"; # cluck unless $op; # return $self->$ {\("pp_" . $op->name)}($op, $cx); +require Carp; +Carp::confess() unless defined $op; my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); } @@ -725,6 +730,7 @@ sub lineseq { $expr .= $self->deparse($ops[$i], 0); push @exprs, $expr if length $expr; } + for(@exprs[0..@exprs-1]) { s/;\n\z// } return join(";\n", @exprs); } @@ -760,7 +766,8 @@ sub scopeop { if ($cx > 0) { # inside an expression, (a do {} while for lineseq) return "do { " . $self->lineseq(@kids) . " }"; } else { - return $self->lineseq(@kids) . ";"; + my $lineseq = $self->lineseq(@kids); + return (length ($lineseq) ? "$lineseq;" : ""); } } @@ -812,6 +819,28 @@ 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; + } + + my $warnings = $op->warnings; + my $warning_bits; + if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { + $warning_bits = $warnings::Bits{"all"}; + } + elsif ($warnings->isa("B::SPECIAL")) { + $warning_bits = "\0"x12; + } + else { + $warning_bits = $warnings->PV; + } + + if ($self->{'warnings'} ne $warning_bits) { + push @text, 'BEGIN {${^WARNING_BITS} = '. cstring($warning_bits) ."}\n"; + $self->{'warnings'} = $warning_bits; + } + return join("", @text); } @@ -1822,6 +1851,7 @@ sub loop_common { $self->deparse($cont, 0) . "\n\b}\cK"; } } else { + return "" if !defined $body; $cont = "\cK"; $body = $self->deparse($body, 0); } @@ -1938,7 +1968,8 @@ sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; my $gv = $self->gv_or_padgv($op); - return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; + return "\$" . $self->gv_name($gv) . "[" . + ($op->private + $self->{'arybase'}) . "]"; } sub rv2x { @@ -2019,6 +2050,25 @@ sub elem { $left . $self->deparse($idx, 1) . $right; } $idx = $self->deparse($idx, 1); + + # Outer parens in an array index will confuse perl + # if we're interpolating in a regular expression, i.e. + # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ + # + # If $self->{parens}, then an initial '(' will + # definitely be paired with a final ')'. If + # !$self->{parens}, the misleading parens won't + # have been added in the first place. + # + # [You might think that we could get "(...)...(...)" + # where the initial and final parens do not match + # each other. But we can't, because the above would + # only happen if there's an infix binop between the + # two pairs of parens, and *that* means that the whole + # expression would be parenthesized as well.] + # + $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; + return "\$" . $array . $left . $idx . $right; } @@ -2377,11 +2427,13 @@ sub const { my $sv = shift; if (class($sv) eq "SPECIAL") { return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no + } elsif (class($sv) eq "NULL") { + return 'undef'; } elsif ($sv->FLAGS & SVf_IOK) { return $sv->int_value; } elsif ($sv->FLAGS & SVf_NOK) { return $sv->NV; - } elsif ($sv->FLAGS & SVf_ROK) { + } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { return "\\(" . const($sv->RV) . ")"; # constant folded } else { my $str = $sv->PV; @@ -2410,6 +2462,9 @@ sub pp_const { # } my $sv = $self->const_sv($op); # return const($sv); + if ($op->private & OPpCONST_ARYBASE) { + return '$['; + } my $c = const $sv; return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c; } diff --git a/ext/B/O.pm b/ext/B/O.pm index 2ef91ed..338d803 100644 --- a/ext/B/O.pm +++ b/ext/B/O.pm @@ -4,18 +4,28 @@ use Carp; sub import { my ($class, $backend, @options) = @_; - eval "use B::$backend ()"; - if ($@) { - croak "use of backend $backend failed: $@"; - } - my $compilesub = &{"B::${backend}::compile"}(@options); - if (ref($compilesub) eq "CODE") { - minus_c; - save_BEGINs; - eval 'CHECK { &$compilesub() }'; - } else { - die $compilesub; - } + eval q[ + BEGIN { + minus_c; + save_BEGINs; + } + + CHECK { + use B::].$backend.q[ (); + if ($@) { + croak "use of backend $backend failed: $@"; + } + + + my $compilesub = &{"B::${backend}::compile"}(@options); + if (ref($compilesub) ne "CODE") { + die $compilesub; + } + + &$compilesub(); + } + ]; + die $@ if $@; } 1;