bring '*' prototype closer to how it behaves internally

p4raw-id: //depot/perl@2978

diff --git a/MANIFEST b/MANIFEST
index f89e2c7..c38dae9 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1072,6 +1072,7 @@ t/lib/dumper.t            See if Data::Dumper works
 t/lib/english.t                See if English works
 t/lib/env.t            See if Env works
 t/lib/errno.t          See if Errno works
+t/lib/fatal.t           See if Fatal works
 t/lib/fields.t          See if base/fields works
 t/lib/filecache.t      See if FileCache works
 t/lib/filecopy.t       See if File::Copy works

diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index a1e5cff..d1d95af 100644 (file)
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -111,11 +111,13 @@ EOS
     $code .= write_invocation($core, $call, $name, @protos);
     $code .= "}\n";
     print $code if $Debug;
-    $code = eval($code);
-    die if $@;
-    local($^W) = 0;   # to avoid: Subroutine foo redefined ...
-    no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
-    *{$sub} = $code;
+    {
+      no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
+      $code = eval("package $pkg; use Carp; $code");
+      die if $@;
+      local($^W) = 0;   # to avoid: Subroutine foo redefined ...
+      *{$sub} = $code;
+    }
 }
 
 1;

diff --git a/op.c b/op.c
index ec3e27b..279fae8 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5303,19 +5303,13 @@ ck_subr(OP *o)
                    bad_type(arg, "block", gv_ename(namegv), o2);
                break;
            case '*':
+               /* '*' allows any scalar type, including bareword */
                proto++;
                arg++;
                if (o2->op_type == OP_RV2GV)
-                   goto wrapref;
-               {
-                   OP* kid = o2;
-                   OP* sib = kid->op_sibling;
-                   kid->op_sibling = 0;
-                   o2 = newUNOP(OP_RV2GV, 0, kid);
-                   o2->op_sibling = sib;
-                   prev->op_sibling = o2;
-               }
-               goto wrapref;
+                   goto wrapref;       /* autoconvert GLOB -> GLOBref */
+               scalar(o2);
+               break;
            case '\\':
                proto++;
                arg++;

diff --git a/t/comp/proto.t b/t/comp/proto.t
index 084e0ab..d58a782 100755 (executable)
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..82\n";
+print "1..87\n";
 
 my $i = 1;
 
@@ -413,3 +413,13 @@ sub X::foo4 ($);
 *X::foo4 = sub ($) {'ok'};
 print "not " unless X->foo4 eq 'ok';
 print "ok ", $i++, "\n";
+
+# test if the (*) prototype allows barewords, constants, scalar expressions,
+# globs and globrefs (just as CORE::open() does), all under stricture
+sub star (*&) { &{$_[1]} }
+my $star = 'FOO';
+star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++;
+star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;
+star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++;

diff --git a/t/lib/fatal.t b/t/lib/fatal.t
new file mode 100755 (executable)
index 0000000..fb3757f
--- /dev/null
+++ b/t/lib/fatal.t
@@ -0,0 +1,27 @@
+#!./perl -w
+
+BEGIN {
+   chdir 't' if -d 't';
+   unshift @INC, '../lib';
+   print "1..9\n";
+}
+
+use strict;
+use Fatal qw(open);
+
+my $i = 1;
+eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' };
+print "not " unless $@ =~ /^Can't open/;
+print "ok $i\n"; ++$i;
+
+my $foo = 'FOO';
+for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
+    eval qq{ open $_, '<$0' };
+    print "not " if $@;
+    print "ok $i\n"; ++$i;
+
+    print "not " unless scalar(<FOO>) =~ m|^#!./perl|;
+    print "not " if $@;
+    print "ok $i\n"; ++$i;
+    close FOO;
+}