From: Gurusamy Sarathy <gsar@cpan.org>
Date: Fri, 19 Feb 1999 05:08:29 +0000 (+0000)
Subject: bring '*' prototype closer to how it behaves internally
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2ba6ecf407bef45da384c153231c33d524202d81;p=p5sagit%2Fp5-mst-13.2.git

bring '*' prototype closer to how it behaves internally

p4raw-id: //depot/perl@2978
---

diff --git a/MANIFEST b/MANIFEST
index f89e2c7..c38dae9 100644
--- 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
--- 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
--- 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
--- 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
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;
+}