fix ops that are not filehandle constructors to not create GV if it

doesn't already exist (avoids leaks); extend semantics of defined()
so that defined(*{$foo}) works (experimental)

p4raw-id: //depot/perl@2879

diff --git a/MANIFEST b/MANIFEST
index d95ed45..344c581 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1140,6 +1140,7 @@ t/op/each.t               See if hash iterators work
 t/op/eval.t            See if eval operator works
 t/op/exec.t            See if exec and system work
 t/op/exp.t             See if math functions work
+t/op/fh.t              See if filehandles work
 t/op/filetest.t                See if file tests work
 t/op/flip.t            See if range operator works
 t/op/fork.t            See if fork works

diff --git a/embed.h b/embed.h
index 6fc73ca..68a90a4 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1288,6 +1288,7 @@
 #define invert                 CPerlObj::Perl_invert
 #define io_close               CPerlObj::Perl_io_close
 #define is_an_int              CPerlObj::Perl_is_an_int
+#define is_handle_constructor  CPerlObj::Perl_is_handle_constructor
 #define is_uni_alnum           CPerlObj::Perl_is_uni_alnum
 #define is_uni_alnum_lc                CPerlObj::Perl_is_uni_alnum_lc
 #define is_uni_alpha           CPerlObj::Perl_is_uni_alpha

diff --git a/embed.pl b/embed.pl
index 3aabd9f..7d3039e 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -376,6 +376,7 @@ my @staticfuncs = qw(
     bset_obj_store
     new_logop
     simplify_sort
+    is_handle_constructor
     do_trans_CC_simple
     do_trans_CC_count
     do_trans_CC_complex

diff --git a/objXSUB.h b/objXSUB.h
index 0c4efd5..8138d0d 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1387,6 +1387,8 @@
 #define io_close               pPerl->Perl_io_close
 #undef  is_an_int
 #define is_an_int              pPerl->Perl_is_an_int
+#undef  is_handle_constructor
+#define is_handle_constructor  pPerl->Perl_is_handle_constructor
 #undef  is_uni_alnum
 #define is_uni_alnum           pPerl->Perl_is_uni_alnum
 #undef  is_uni_alnum_lc

diff --git a/op.c b/op.c
index 8f15a10..412eb57 100644 (file)
--- a/op.c
+++ b/op.c
@@ -52,6 +52,7 @@ static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
 static OP *newDEFSVOP _((void));
 static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
 static void simplify_sort _((OP *o));
+static bool is_handle_constructor _((OP *o, I32 argnum));
 #endif
 
 STATIC char*
@@ -1387,6 +1388,28 @@ scalar_mod_type(OP *o, I32 type)
     }
 }
 
+STATIC bool
+is_handle_constructor(OP *o, I32 argnum)
+{
+    switch (o->op_type) {
+    case OP_PIPE_OP:
+    case OP_SOCKPAIR:
+       if (argnum == 2)
+           return TRUE;
+       /* FALL THROUGH */
+    case OP_SYSOPEN:
+    case OP_OPEN:
+    case OP_SOCKET:
+    case OP_OPEN_DIR:
+    case OP_ACCEPT:
+       if (argnum == 1)
+           return TRUE;
+       /* FALL THROUGH */
+    default:
+       return FALSE;
+    }
+}
+
 OP *
 refkids(OP *o, I32 type)
 {
@@ -1423,6 +1446,8 @@ ref(OP *o, I32 type)
            ref(kid, type);
        break;
     case OP_RV2SV:
+       if (type == OP_DEFINED)
+           o->op_flags |= OPf_SPECIAL;         /* don't create GV */
        ref(cUNOPo->op_first, o->op_type);
        /* FALL THROUGH */
     case OP_PADSV:
@@ -1443,6 +1468,8 @@ ref(OP *o, I32 type)
        o->op_flags |= OPf_REF;
        /* FALL THROUGH */
     case OP_RV2GV:
+       if (type == OP_DEFINED)
+           o->op_flags |= OPf_SPECIAL;         /* don't create GV */
        ref(cUNOPo->op_first, o->op_type);
        break;
 
@@ -4675,7 +4702,7 @@ ck_fun(OP *o)
                    *tokid = kid;
                }
                else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
-                   bad_type(numargs, "array", PL_op_desc[o->op_type], kid);
+                   bad_type(numargs, "array", PL_op_desc[type], kid);
                mod(kid, type);
                break;
            case OA_HVREF:
@@ -4695,7 +4722,7 @@ ck_fun(OP *o)
                    *tokid = kid;
                }
                else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
-                   bad_type(numargs, "hash", PL_op_desc[o->op_type], kid);
+                   bad_type(numargs, "hash", PL_op_desc[type], kid);
                mod(kid, type);
                break;
            case OA_CVREF:
@@ -4725,8 +4752,12 @@ ck_fun(OP *o)
                        bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
                    }
                    else {
+                       I32 flags = OPf_SPECIAL;
+                       /* is this op a FH constructor? */
+                       if (is_handle_constructor(o,numargs))
+                           flags = 0;
                        kid->op_sibling = 0;
-                       kid = newUNOP(OP_RV2GV, 0, scalar(kid));
+                       kid = newUNOP(OP_RV2GV, flags, scalar(kid));
                    }
                    kid->op_sibling = sibl;
                    *tokid = kid;

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index eb84876..c303c00 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2323,6 +2323,11 @@ was either never opened or has since been closed.
 
 (F) This machine doesn't implement the select() system call.
 
+=item select() on unopened file
+
+(W) You tried to use the select() function on a filehandle that
+was either never opened or has since been closed.
+
 =item sem%s not implemented
 
 (F) You don't have System V semaphore IPC on your system.

diff --git a/pp.c b/pp.c
index 729d1e7..83d881b 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -240,9 +240,18 @@ PP(pp_rv2gv)
                RETSETUNDEF;
            }
            sym = SvPV(sv, n_a);
-           if (PL_op->op_private & HINT_STRICT_REFS)
-               DIE(PL_no_symref, sym, "a symbol");
-           sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+           if ((PL_op->op_flags & OPf_SPECIAL) &&
+               !(PL_op->op_flags & OPf_MOD))
+           {
+               sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
+               if (!sv)
+                   RETSETUNDEF;
+           }
+           else {
+               if (PL_op->op_private & HINT_STRICT_REFS)
+                   DIE(PL_no_symref, sym, "a symbol");
+               sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+           }
        }
     }
     if (PL_op->op_private & OPpLVAL_INTRO)
@@ -287,9 +296,18 @@ PP(pp_rv2sv)
                RETSETUNDEF;
            }
            sym = SvPV(sv, n_a);
-           if (PL_op->op_private & HINT_STRICT_REFS)
-               DIE(PL_no_symref, sym, "a SCALAR");
-           gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+           if ((PL_op->op_flags & OPf_SPECIAL) &&
+               !(PL_op->op_flags & OPf_MOD))
+           {
+               gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
+               if (!gv)
+                   RETSETUNDEF;
+           }
+           else {
+               if (PL_op->op_private & HINT_STRICT_REFS)
+                   DIE(PL_no_symref, sym, "a SCALAR");
+               gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+           }
        }
        sv = GvSV(gv);
     }

diff --git a/pp_hot.c b/pp_hot.c
index f304e8b..27af29d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -468,10 +468,20 @@ PP(pp_rv2av)
                    RETSETUNDEF;
                }
                sym = SvPV(sv,n_a);
-               if (PL_op->op_private & HINT_STRICT_REFS)
-                   DIE(PL_no_symref, sym, "an ARRAY");
-               gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
-           } else {
+               if ((PL_op->op_flags & OPf_SPECIAL) &&
+                   !(PL_op->op_flags & OPf_MOD))
+               {
+                   gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
+                   if (!gv)
+                       RETSETUNDEF;
+               }
+               else {
+                   if (PL_op->op_private & HINT_STRICT_REFS)
+                       DIE(PL_no_symref, sym, "an ARRAY");
+                   gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+               }
+           }
+           else {
                gv = (GV*)sv;
            }
            av = GvAVn(gv);
@@ -558,10 +568,20 @@ PP(pp_rv2hv)
                    RETSETUNDEF;
                }
                sym = SvPV(sv,n_a);
-               if (PL_op->op_private & HINT_STRICT_REFS)
-                   DIE(PL_no_symref, sym, "a HASH");
-               gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
-           } else {
+               if ((PL_op->op_flags & OPf_SPECIAL) &&
+                   !(PL_op->op_flags & OPf_MOD))
+               {
+                   gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
+                   if (!gv)
+                       RETSETUNDEF;
+               }
+               else {
+                   if (PL_op->op_private & HINT_STRICT_REFS)
+                       DIE(PL_no_symref, sym, "a HASH");
+                   gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+               }
+           }
+           else {
                gv = (GV*)sv;
            }
            hv = GvHVn(gv);

diff --git a/pp_sys.c b/pp_sys.c
index a35a206..e4694bc 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1003,8 +1003,13 @@ PP(pp_select)
     }
 
     if (newdefout) {
-       if (!GvIO(newdefout))
-           gv_IOadd(newdefout);
+       if (!GvIO(newdefout)) {
+           if (ckWARN(WARN_UNOPENED))
+               warner(WARN_UNOPENED, "select() on unopened file");
+           if (SvTYPE(newdefout) != SVt_PVGV)
+               RETURN;
+           gv_IOadd(newdefout);        /* XXX probably bogus */
+       }
        setdefout(newdefout);
     }
 

diff --git a/proto.h b/proto.h
index f91e80b..7e3d4c5 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -894,6 +894,7 @@ void debprof _((OP *o));
 void *bset_obj_store _((void *obj, I32 ix));
 OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
 void simplify_sort _((OP *o));
+bool is_handle_constructor _((OP *o, I32 argnum));
 
 I32 do_trans_CC_simple _((SV *sv));
 I32 do_trans_CC_count _((SV *sv));

diff --git a/t/op/fh.t b/t/op/fh.t
new file mode 100755 (executable)
index 0000000..8000d9f
--- /dev/null
+++ b/t/op/fh.t
@@ -0,0 +1,24 @@
+#!./perl
+
+print "1..6\n";
+
+my $test = 0;
+
+# symbolic filehandles should only result in glob entries with FH constructors
+
+my $a = "SYM000";
+print "not " if defined(fileno($a)) or defined *{$a};
+++$test; print "ok $test\n";
+
+select select $a;
+print "not " if defined *{$a};
+++$test; print "ok $test\n";
+
+print "not " if close $a or defined *{$a};
+++$test; print "ok $test\n";
+
+print "not " unless open($a, ">&STDOUT") and defined *{$a};
+++$test; print $a "ok $test\n";
+
+print "not " unless close $a;
+++$test; print $a "not "; print "ok $test\n";

diff --git a/t/op/gv.t b/t/op/gv.t
index c253e4b..df4984e 100755 (executable)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -4,7 +4,7 @@
 # various typeglob tests
 #
 
-print "1..23\n";
+print "1..29\n";
 
 # type coersion on assignment
 $foo = 'foo';
@@ -95,4 +95,29 @@ print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n";
 print {*x{IO}} "ok 22\n";
 print {*x{FILEHANDLE}} "ok 23\n";
 
+# test if defined() doesn't create any new symbols
+
+{
+    my $test = 23;
+
+    my $a = "SYM000";
+    print "not " if defined *{$a};
+    ++$test; print "ok $test\n";
+
+    print "not " if defined @{$a} or defined *{$a};
+    ++$test; print "ok $test\n";
+
+    print "not " if defined %{$a} or defined *{$a};
+    ++$test; print "ok $test\n";
+
+    print "not " if defined ${$a} or defined *{$a};
+    ++$test; print "ok $test\n";
+
+    print "not " if defined &{$a} or defined *{$a};
+    ++$test; print "ok $test\n";
+
+    *{$a} = sub { print "ok $test\n" };
+    print "not " unless defined &{$a} and defined *{$a};
+    ++$test; &{$a};
+}
 

diff --git a/t/op/misc.t b/t/op/misc.t
index 9fe98c4..57d57b7 100755 (executable)
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -411,7 +411,13 @@ destroyed
 package X;
 sub any { bless {} }
 my $f = "FH000"; # just to thwart any future optimisations
-sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
+sub afh {
+    open(++$f, '>&STDOUT') or die;
+    select select $f;
+    my $r = *{$f}{IO};
+    delete $X::{$f};
+    bless $r;
+}
 sub DESTROY { print "destroyed\n" }
 package main;
 $x = any X; # to bump sv_objcount. IO objs aren't counted??