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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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;