diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | dist/B-Deparse/Deparse.pm | 53 | ||||
| -rw-r--r-- | dist/B-Deparse/t/core.t | 102 |
3 files changed, 142 insertions, 14 deletions
@@ -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 e780ab8e8d..6ff1c0de67 100644 --- 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 index 0000000000..adf44c6eda --- /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 + $_,
"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'; |