diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | objXSUB.h | 2 | ||||
| -rw-r--r-- | op.c | 37 | ||||
| -rw-r--r-- | pod/perldiag.pod | 5 | ||||
| -rw-r--r-- | pp.c | 30 | ||||
| -rw-r--r-- | pp_hot.c | 36 | ||||
| -rw-r--r-- | pp_sys.c | 9 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rwxr-xr-x | t/op/fh.t | 24 | ||||
| -rwxr-xr-x | t/op/gv.t | 27 | ||||
| -rwxr-xr-x | t/op/misc.t | 8 |
13 files changed, 161 insertions, 21 deletions
@@ -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 @@ -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 @@ -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 @@ -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 @@ -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 eb84876d4e..c303c003a6 100644 --- 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. @@ -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); } @@ -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); @@ -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); } @@ -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 index 0000000000..8000d9fa61 --- /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"; @@ -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 9fe98c4589..57d57b7b37 100755 --- 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?? |