Make Deparse use CORE:: when necessary

Till now, Deparse has not added CORE:: to built-in keywords, even when
they are overridden by subs.  Now it does.

It was simply a matter of adding a ‘keyword’ sub that looks in the
current stash to determine whether there is a possible override.  And
it only does so for overridable non-infix functions.  It returns the
keyword with CORE:: added to the beginning if necessary.  Various
parts of the code have been modified to call this routine.

diff --git a/MANIFEST b/MANIFEST
index b139548..bcaa5c6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2836,6 +2836,7 @@ dist/base/t/sigdie.t              See if base works with SIGDIE
 dist/base/t/version.t          See if base works with versions
 dist/base/t/warnings.t         See if base works with warnings
 dist/B-Deparse/Deparse.pm      Compiler Deparse backend
+dist/B-Deparse/t/core.t                See if B::Deparse knows when to use CORE::
 dist/B-Deparse/t/deparse.t     See if B::Deparse works
 dist/bignum/lib/bigint.pm              bigint
 dist/bignum/lib/bignum.pm              bignum

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index e780ab8..6ff1c0d 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -243,7 +243,8 @@ BEGIN {
 #
 # subs_declared
 # keys are names of subs for which we've printed declarations.
-# That means we can omit parentheses from the arguments.
+# That means we can omit parentheses from the arguments. It also means we
+# need to put CORE:: on core functions of the same name.
 #
 # subs_deparsed
 # Keeps track of fully qualified names of all deparsed subs.
@@ -1017,12 +1018,13 @@ sub maybe_parens_unop {
        if ($name eq "umask" && $kid =~ /^\d+$/) {
            $kid = sprintf("%#o", $kid);
        }
-       return "$name($kid)";
+       return $self->keyword($name) . "($kid)";
     } else {
        $kid = $self->deparse($kid, 16);
        if ($name eq "umask" && $kid =~ /^\d+$/) {
            $kid = sprintf("%#o", $kid);
        }
+       $name = $self->keyword($name);
        if (substr($kid, 0, 1) eq "\cS") {
            # use kid's parens
            return $name . substr($kid, 1);
@@ -1521,10 +1523,28 @@ sub pp_setstate { pp_nextstate(@_) }
 
 sub pp_unstack { return "" } # see also leaveloop
 
+sub keyword {
+    my $self = shift;
+    my $name = shift;
+    return $name if $name =~ /^CORE::/; # just in case
+    if (
+      $name !~ /^(?:chom?p|exec|system)\z/
+       && !defined eval{prototype "CORE::$name"}
+    ) { return $name }
+    if (
+       exists $self->{subs_declared}{$name}
+        or
+       exists &{"$self->{curstash}::$name"}
+    ) {
+       return "CORE::$name"
+    }
+    return $name;
+}
+
 sub baseop {
     my $self = shift;
     my($op, $cx, $name) = @_;
-    return $name;
+    return $self->keyword($name);
 }
 
 sub pp_stub {
@@ -1600,7 +1620,7 @@ sub pp_not {
     my $self = shift;
     my($op, $cx) = @_;
     if ($cx <= 4) {
-       $self->pfixop($op, $cx, "not ", 4);
+       $self->pfixop($op, $cx, $self->keyword("not")." ", 4);
     } else {
        $self->pfixop($op, $cx, "!", 21);       
     }
@@ -1626,7 +1646,8 @@ sub unop {
 
        return $self->maybe_parens_unop($name, $kid, $cx);
     } else {
-       return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
+       return $self->keyword($name)
+         . ($op->flags & OPf_SPECIAL ? "()" : "");
     }
 }
 
@@ -1951,7 +1972,7 @@ sub pp_last { loopex(@_, "last") }
 sub pp_next { loopex(@_, "next") }
 sub pp_redo { loopex(@_, "redo") }
 sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
+sub pp_dump { loopex(@_, $_[0]->keyword("dump")) }
 
 sub ftst {
     my $self = shift;
@@ -2284,9 +2305,10 @@ sub listop {
     my(@exprs);
     my $parens = ($cx >= 5) || $self->{'parens'};
     my $kid = $op->first->sibling;
-    return $name if null $kid;
+    return $self->keyword($name) if null $kid;
     my $first;
     $name = "socketpair" if $name eq "sockpair";
+    my $fullname = $self->keyword($name);
     my $proto = prototype("CORE::$name");
     if (defined $proto
        && $proto =~ /^;?\*/
@@ -2310,12 +2332,13 @@ sub listop {
        push @exprs, $self->deparse($kid, 6);
     }
     if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
-       return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
+       return "$exprs[0] = $fullname"
+                . ($parens ? "($exprs[0])" : " $exprs[0]");
     }
     if ($parens) {
-       return "$name(" . join(", ", @exprs) . ")";
+       return "$fullname(" . join(", ", @exprs) . ")";
     } else {
-       return "$name " . join(", ", @exprs);
+       return "$fullname " . join(", ", @exprs);
     }
 }
 
@@ -2436,10 +2459,11 @@ sub pp_truncate {
         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
     }
     my $len = $self->deparse($kid->sibling, 6);
+    my $name = $self->keyword('truncate');
     if ($parens) {
-       return "truncate($fh, $len)";
+       return "$name($fh, $len)";
     } else {
-       return "truncate $fh, $len";
+       return "$name $fh, $len";
     }
 }
 
@@ -2474,10 +2498,11 @@ sub indirop {
        $expr = $self->deparse($kid, 6);
        push @exprs, $expr;
     }
-    my $name2 = $name;
+    my $name2;
     if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
-       $name2 = 'reverse sort';
+       $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
     }
+    else { $name2 = $self->keyword($name) }
     if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
        return "$exprs[0] = $name2 $indir $exprs[0]";
     }

diff --git a/dist/B-Deparse/t/core.t b/dist/B-Deparse/t/core.t
new file mode 100644 (file)
index 0000000..adf44c6
--- /dev/null
+++ b/dist/B-Deparse/t/core.t
@@ -0,0 +1,102 @@
+#!./perl
+
+BEGIN {
+    unshift @INC, 't','../../t';
+    require 'test.pl';
+    skip_all_without_dynamic_extension('B');
+}
+
+
+# Many functions appear in multiple lists, so that shift() and shift(foo)
+# are both tested.
+# For lists, we test 0 to 2 arguments.
+my @nary = (
+ # nullary functions
+     [qw( abs alarm break chr cos chop close chdir chomp chmod chown
+          chroot caller continue die dump exp exit exec endgrent
+          endpwent endnetent endhostent endservent endprotoent fork
+          getppid getpwent getprotoent gethostent getnetent getservent
+          getgrent getlogin getc gmtime hex int lc log lstat length
+          lcfirst localtime mkdir ord oct pop quotemeta ref rand
+          rmdir reset reverse readlink select setpwent setgrent
+          shift sin sleep sqrt srand stat system tell time times
+          uc utime umask unlink ucfirst wantarray warn wait write    )],
+ # unary
+     [qw( abs alarm bless binmode chr cos chop close chdir chomp
+          chmod chown chroot closedir die dump exp exit exec
+          each fileno getpgrp getpwnam getpwuid getpeername
+          getprotobyname getprotobynumber gethostbyname
+          getnetbyname getsockname getgrnam getgrgid
+          getc gmtime hex int join keys kill lc
+          log lock lstat length lcfirst localtime
+          mkdir ord oct open pop push pack quotemeta
+          ref rand rmdir reset reverse readdir readlink
+          rewinddir select setnetent sethostent setservent
+          setprotoent shift sin sleep sprintf splice sqrt
+          srand stat system tell tied telldir uc utime umask
+          unpack unlink unshift untie ucfirst values warn write )],
+ # binary, but not circumfix
+     [qw( atan2 accept bind binmode chop chomp chmod chown crypt
+          connect die exec flock formline getpriority gethostbyaddr
+          getnetbyaddr getservbyname getservbyport index join kill
+          link listen mkdir msgget open opendir push pack pipe
+          rename rindex reverse seekdir semop setpgrp shutdown
+          sprintf splice substr system symlink syscall syswrite
+          tie truncate utime unpack unlink warn waitpid           )],
+ # ternary
+     [qw( fcntl getsockopt index ioctl join  kill  msgctl
+          msgsnd open push pack  read  rindex  seek  send
+          semget setpriority shmctl shmget sprintf splice
+          substr sysopen sysread sysseek syswrite tie vec )],
+ # quaternary
+     [qw( open read  recv  send  select  semctl  setsockopt  shmread
+          shmwrite socket splice substr sysopen sysread syswrite tie )],
+ # quinary
+     [qw( msgrcv open socketpair splice )]
+);
+
+my $tests = @bin + 13;
+$tests += @$_ for @nary;
+plan $tests;
+
+use B::Deparse;
+my $deparse = new B::Deparse;
+
+sub CORE_test {
+  my($keyword,$expr,$name) = @_;
+  package test;
+  use subs ();
+  import subs $keyword;
+  use feature 'switch';
+  ::like
+      $deparse->coderef2text(
+         eval "sub { () = $expr }" or die "$@in $expr"
+      ),
+      qr/\sCORE::$keyword.*;/,
+      $name||$keyword  
+}
+
+for my $argc(0..$#nary) {
+ for(@{$nary[$argc]}) {
+  CORE_test
+     $_,\r    "CORE::$_(" . join(',',map "\$$_", (undef,"a".."z")[1..$argc]) . ")",
+    "$_, $argc argument" . "s"x($argc != 1);
+ }
+}
+
+# Special cases
+CORE_test dbmopen => 'CORE::dbmopen %foo, $bar, $baz';
+CORE_test dbmclose => 'CORE::dbmclose %foo';
+CORE_test eof => 'CORE::eof $foo', 'eof $arg';
+CORE_test eof => 'CORE::eof', 'eof';
+CORE_test eof => 'CORE::eof()', 'eof()';
+CORE_test exec => 'CORE::exec $foo $bar', 'exec PROGRAM LIST';
+CORE_test each => 'CORE::each %bar', 'each %hash';
+CORE_test keys => 'CORE::keys %bar', 'keys %hash';
+CORE_test reverse => 'CORE::reverse sort @foo', 'reverse sort';
+CORE_test system => 'CORE::system $foo $bar', 'system PROGRAM LIST';
+CORE_test values => 'CORE::values %bar', 'values %hash';
+# This test does not work. How do I get Deparse to output a not?
+#CORE_test not => 'CORE::not $a, $b', 'not';
+CORE_test readline => 'CORE::readline $a.$b', 'readline';
+CORE_test readpipe => 'CORE::readpipe $a+$b', 'readpipe';