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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;