From: Gurusamy Sarathy 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 has become optional. =head2 Filehandles can be autovivified -The construct C 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 and +C 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;