From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sat, 4 Dec 1999 01:00:49 +0000 (+0000)
Subject: better implementation of change#3326; open(local $foo,...) now
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2c8ac474a00b933b4d84e8567b4b6db1293ad0ef;p=p5sagit%2Fp5-mst-13.2.git

better implementation of change#3326; open(local $foo,...) now
allowed in addition to any uninitialized variable, for consistency
with how autovivification works elsewhere; add code to use the
variable name as the name of the handle for simple variables, so
that diagnostics report the handle: "... at - line 1, <$foo> line 10."

p4raw-link: @3326 on //depot/perl: 853846ea710f8feaed8c98b358bdc8967dd522d2

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

diff --git a/op.c b/op.c
index 1be2428..155c001 100644
--- a/op.c
+++ b/op.c
@@ -5286,26 +5286,46 @@ Perl_ck_fun(pTHX_ OP *o)
 		    else {
 			I32 flags = OPf_SPECIAL;
 			I32 priv = 0;
+			PADOFFSET targ = 0;
+
 			/* is this op a FH constructor? */
 			if (is_handle_constructor(o,numargs)) {
-			    flags   = 0;                         
-			    /* Set a flag to tell rv2gv to vivify 
+			    char *name = Nullch;
+			    STRLEN len;
+
+			    flags = 0;
+			    /* Set a flag to tell rv2gv to vivify
 			     * need to "prove" flag does not mean something
 			     * else already - NI-S 1999/05/07
-			     */ 
-			    priv = OPpDEREF; 
-#if 0
-			    /* Helps with open($array[$n],...) 
-			       but is too simplistic - need to do selectively
-			    */
-			    mod(kid,type);
-#endif
+			     */
+			    priv = OPpDEREF;
+			    if (kid->op_type == OP_PADSV) {
+				SV **namep = av_fetch(PL_comppad_name,
+						      kid->op_targ, 4);
+				if (namep && *namep)
+				    name = SvPV(*namep, len);
+			    }
+			    else if (kid->op_type == OP_RV2SV
+				     && kUNOP->op_first->op_type == OP_GV)
+			    {
+				GV *gv = cGVOPx_gv(kUNOP->op_first);
+				name = GvNAME(gv);
+				len = GvNAMELEN(gv);
+			    }
+			    if (name) {
+				SV *namesv;
+				targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
+				namesv = PL_curpad[targ];
+				SvUPGRADE(namesv, SVt_PV);
+				if (*name != '$')
+				    sv_setpvn(namesv, "$", 1);
+				sv_catpvn(namesv, name, len);
+			    }
 			}
 			kid->op_sibling = 0;
 			kid = newUNOP(OP_RV2GV, flags, scalar(kid));
-			if (priv) {
-			    kid->op_private |= priv;
-			}
+			kid->op_targ = targ;
+			kid->op_private |= priv;
 		    }
 		    kid->op_sibling = sibl;
 		    *tokid = kid;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 12d2684..47a9eb1 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -360,11 +360,14 @@ The length argument of C<syswrite()> has become optional.
 
 =head2 Filehandles can be autovivified
 
-The construct C<open(my $fh, ...)> can be used to create filehandles
-more easily.  The filehandle will be automatically closed at the end
-of the scope of $fh, provided there are no other references to it.  This
-largely eliminates the need for typeglobs when opening filehandles
-that must be passed around, as in the following example:
+Similar to how constructs such as C<$x->[0]> autovivify a reference,
+open() now autovivifies a filehandle if the first argument is an
+uninitialized variable.  This allows the constructs C<open(my $fh, ...)> and
+C<open(local $fh,...)> to be used to create filehandles that will
+conveniently be closed automatically when the scope ends, provided there
+are no other references to them.  This largely eliminates the need for
+typeglobs when opening filehandles that must be passed around, as in the
+following example:
 
     sub myopen {
         open my $fh, "@_"
diff --git a/pp.c b/pp.c
index a35131f..f999b28 100644
--- a/pp.c
+++ b/pp.c
@@ -241,26 +241,25 @@ PP(pp_rv2gv)
 		 * NI-S 1999/05/07
 		 */ 
 		if (PL_op->op_private & OPpDEREF) {
-		    GV *gv = (GV *) newSV(0);
-		    STRLEN len = 0;
-		    char *name = "";
-		    if (cUNOP->op_first->op_type == OP_PADSV) {
-			SV **namep = av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
-			if (namep && *namep) {
-			    name = SvPV(*namep,len);
-			    if (!name) {
-				name = "";
-				len  = 0;
-			    }
-			}
+		    char *name;
+		    GV *gv;
+		    if (cUNOP->op_targ) {
+			STRLEN len;
+			SV *namesv = PL_curpad[cUNOP->op_targ];
+			name = SvPV(namesv, len);
+			gv = (GV*)NEWSV(0,len);
+			gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
+		    }
+		    else {
+			name = CopSTASHPV(PL_curcop);
+			gv = newGVgen(name);
 		    }
-		    gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 		    sv_upgrade(sv, SVt_RV);
-		    SvRV(sv) = (SV *) gv;
+		    SvRV(sv) = (SV*)gv;
 		    SvROK_on(sv);
 		    SvSETMAGIC(sv);
 		    goto wasref;
-		}  
+		}
 		if (PL_op->op_flags & OPf_REF ||
 		    PL_op->op_private & HINT_STRICT_REFS)
 		    DIE(aTHX_ PL_no_usym, "a symbol");
diff --git a/t/io/open.t b/t/io/open.t
index 905aee5..f8c7213 100755
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -5,110 +5,256 @@ $|  = 1;
 $^W = 1;
 $Is_VMS = $^O eq 'VMS';
 
-print "1..32\n";
+print "1..64\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
 
 # my $file tests
 
+# 1..9
 {
-unlink("afile") if -f "afile";     
-print "$!\nnot " unless open(my $f,"+>afile");
-print "ok 1\n";
-binmode $f;
-print "not " unless -f "afile";     
-print "ok 2\n";
-print "not " unless print $f "SomeData\n";
-print "ok 3\n";
-print "not " unless tell($f) == 9;
-print "ok 4\n";
-print "not " unless seek($f,0,0);
-print "ok 5\n";
-$b = <$f>;
-print "not " unless $b eq "SomeData\n";
-print "ok 6\n";
-print "not " unless -f $f;     
-print "ok 7\n";
-eval  { die "Message" };   
-# warn $@;
-print "not " unless $@ =~ /<\$f> line 1/;
-print "ok 8\n";
-print "not " unless close($f);
-print "ok 9\n";
-unlink("afile");     
+    unlink("afile") if -f "afile";     
+    print "$!\nnot " unless open(my $f,"+>afile");
+    ok;
+    binmode $f;
+    print "not " unless -f "afile";     
+    ok;
+    print "not " unless print $f "SomeData\n";
+    ok;
+    print "not " unless tell($f) == 9;
+    ok;
+    print "not " unless seek($f,0,0);
+    ok;
+    $b = <$f>;
+    print "not " unless $b eq "SomeData\n";
+    ok;
+    print "not " unless -f $f;     
+    ok;
+    eval  { die "Message" };   
+    # warn $@;
+    print "not " unless $@ =~ /<\$f> line 1/;
+    ok;
+    print "not " unless close($f);
+    ok;
+    unlink("afile");     
 }
+
+# 10..12
 {
-print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile');
-print "ok 10\n";
-print $f "a row\n";
-print "not " unless close($f);
-print "ok 11\n";
-print "not " unless -s 'afile' < 10;
-print "ok 12\n";
+    print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile');
+    ok;
+    print $f "a row\n";
+    print "not " unless close($f);
+    ok;
+    print "not " unless -s 'afile' < 10;
+    ok;
 }
+
+# 13..15
 {
-print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile');
-print "ok 13\n";
-print $f "a row\n";
-print "not " unless close($f);
-print "ok 14\n";
-print "not " unless -s 'afile' > 10;
-print "ok 15\n";
+    print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile');
+    ok;
+    print $f "a row\n";
+    print "not " unless close($f);
+    ok;
+    print "not " unless -s 'afile' > 10;
+    ok;
 }
+
+# 16..18
 {
-print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile');
-print "ok 16\n";
-@rows = <$f>;
-print "not " unless @rows == 2;
-print "ok 17\n";
-print "not " unless close($f);
-print "ok 18\n";
+    print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile');
+    ok;
+    @rows = <$f>;
+    print "not " unless @rows == 2;
+    ok;
+    print "not " unless close($f);
+    ok;
 }
+
+# 19..23
 {
-print "not " unless -s 'afile' < 20;
-print "ok 19\n";
-print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile');
-print "ok 20\n";
-@rows = <$f>;
-print "not " unless @rows == 2;
-print "ok 21\n";
-seek $f, 0, 1;
-print $f "yet another row\n";
-print "not " unless close($f);
-print "ok 22\n";
-print "not " unless -s 'afile' > 20;
-print "ok 23\n";
-
-unlink("afile");     
-}
-if ($Is_VMS) { for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } }
+    print "not " unless -s 'afile' < 20;
+    ok;
+    print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile');
+    ok;
+    @rows = <$f>;
+    print "not " unless @rows == 2;
+    ok;
+    seek $f, 0, 1;
+    print $f "yet another row\n";
+    print "not " unless close($f);
+    ok;
+    print "not " unless -s 'afile' > 20;
+    ok;
+
+    unlink("afile");     
+}
+
+# 24..26
+if ($Is_VMS) {
+    for (24..26) { print "ok $_ # skipped: not Unix fork\n"; }
+}
 else {
-print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC');
-./perl -e "print qq(a row\n); print qq(another row\n)"
+    print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC');
+    ./perl -e "print qq(a row\n); print qq(another row\n)"
 EOC
-print "ok 24\n";
-@rows = <$f>;
-print "not " unless @rows == 2;
-print "ok 25\n";
-print "not " unless close($f);
-print "ok 26\n";
-}
-if ($Is_VMS) { for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } }
+    ok;
+    @rows = <$f>;
+    print "not " unless @rows == 2;
+    ok;
+    print "not " unless close($f);
+    ok;
+}
+
+# 27..30
+if ($Is_VMS) {
+    for (27..30) { print "ok $_ # skipped: not Unix fork\n"; }
+}
 else {
-print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC');
-./perl -pe "s/^not //"
+    print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC');
+    ./perl -pe "s/^not //"
 EOC
-print "ok 27\n";
-@rows = <$f>;
-print $f "not ok 28\n";
-print $f "not ok 29\n";
-print "#\nnot " unless close($f);
-sleep 1;
-print "ok 30\n";
+    ok;
+    @rows = <$f>;
+    print $f "not ok $test\n"; $test++;
+    print $f "not ok $test\n"; $test++;
+    print "#\nnot " unless close($f);
+    sleep 1;
+    ok;
 }
 
+# 31..32
 eval <<'EOE' and print "not ";
 open my $f, '<&', 'afile';
 1;
 EOE
-print "ok 31\n";
+ok;
+$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not ";
+ok;
+
+# local $file tests
+
+# 33..41
+{
+    unlink("afile") if -f "afile";     
+    print "$!\nnot " unless open(local $f,"+>afile");
+    ok;
+    binmode $f;
+    print "not " unless -f "afile";     
+    ok;
+    print "not " unless print $f "SomeData\n";
+    ok;
+    print "not " unless tell($f) == 9;
+    ok;
+    print "not " unless seek($f,0,0);
+    ok;
+    $b = <$f>;
+    print "not " unless $b eq "SomeData\n";
+    ok;
+    print "not " unless -f $f;     
+    ok;
+    eval  { die "Message" };   
+    # warn $@;
+    print "not " unless $@ =~ /<\$f> line 1/;
+    ok;
+    print "not " unless close($f);
+    ok;
+    unlink("afile");     
+}
+
+# 42..44
+{
+    print "# \$!='$!'\nnot " unless open(local $f,'>', 'afile');
+    ok;
+    print $f "a row\n";
+    print "not " unless close($f);
+    ok;
+    print "not " unless -s 'afile' < 10;
+    ok;
+}
+
+# 45..47
+{
+    print "# \$!='$!'\nnot " unless open(local $f,'>>', 'afile');
+    ok;
+    print $f "a row\n";
+    print "not " unless close($f);
+    ok;
+    print "not " unless -s 'afile' > 10;
+    ok;
+}
+
+# 48..50
+{
+    print "# \$!='$!'\nnot " unless open(local $f, '<', 'afile');
+    ok;
+    @rows = <$f>;
+    print "not " unless @rows == 2;
+    ok;
+    print "not " unless close($f);
+    ok;
+}
+
+# 51..55
+{
+    print "not " unless -s 'afile' < 20;
+    ok;
+    print "# \$!='$!'\nnot " unless open(local $f, '+<', 'afile');
+    ok;
+    @rows = <$f>;
+    print "not " unless @rows == 2;
+    ok;
+    seek $f, 0, 1;
+    print $f "yet another row\n";
+    print "not " unless close($f);
+    ok;
+    print "not " unless -s 'afile' > 20;
+    ok;
+
+    unlink("afile");     
+}
+
+# 56..58
+if ($Is_VMS) {
+    for (56..58) { print "ok $_ # skipped: not Unix fork\n"; }
+}
+else {
+    print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC');
+    ./perl -e "print qq(a row\n); print qq(another row\n)"
+EOC
+    ok;
+    @rows = <$f>;
+    print "not " unless @rows == 2;
+    ok;
+    print "not " unless close($f);
+    ok;
+}
+
+# 59..62
+if ($Is_VMS) {
+    for (59..62) { print "ok $_ # skipped: not Unix fork\n"; }
+}
+else {
+    print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC');
+    ./perl -pe "s/^not //"
+EOC
+    ok;
+    @rows = <$f>;
+    print $f "not ok $test\n"; $test++;
+    print $f "not ok $test\n"; $test++;
+    print "#\nnot " unless close($f);
+    sleep 1;
+    ok;
+}
+
+# 63..64
+eval <<'EOE' and print "not ";
+open local $f, '<&', 'afile';
+1;
+EOE
+ok;
 $@ =~ /Unknown open\(\) mode \'<&\'/ or print "not ";
-print "ok 32\n";
+ok;