X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bc0c81caab3813b2d61b70f94e5075bbf3a3ef69..e2712234fb9f66b89b77d929912e337172313635:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 0d8673a..f8370f7 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -358,7 +358,22 @@ PP(pp_glob) { dVAR; OP *result; - tryAMAGICunTARGET(iter, -1); + dSP; + /* make a copy of the pattern, to ensure that magic is called once + * and only once */ + TOPm1s = sv_2mortal(newSVsv(TOPm1s)); + + tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); + + if (PL_op->op_flags & OPf_SPECIAL) { + /* call Perl-level glob function instead. Stack args are: + * MARK, wildcard, csh_glob context index + * and following OPs should be: gv(CORE::GLOBAL::glob), entersub + * */ + return NORMAL; + } + /* stack args are: wildcard, gv(_GEN_n) */ + /* Note that we only ever get here if File::Glob fails to load * without at the same time croaking, for some reason, or if @@ -487,12 +502,60 @@ PP(pp_die) else { exsv = newSVpvs_flags("Died", SVs_TEMP); } - die_sv(exsv); - RETURN; + return die_sv(exsv); } /* I/O. */ +OP * +Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, + const MAGIC *const mg, const U32 flags, U32 argc, ...) +{ + PERL_ARGS_ASSERT_TIED_METHOD; + + /* Ensure that our flag bits do not overlap. */ + assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); + assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); + assert((TIED_METHOD_SAY & G_WANT) == 0); + + PUSHMARK(sp); + PUSHs(SvTIED_obj(sv, mg)); + if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) + sp += argc; + else if (argc) { + const U32 mortalize_not_needed + = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; + va_list args; + va_start(args, argc); + do { + SV *const arg = va_arg(args, SV *); + if(mortalize_not_needed) + PUSHs(arg); + else + mPUSHs(arg); + } while (--argc); + va_end(args); + } + + PUTBACK; + ENTER_with_name("call_tied_method"); + if (flags & TIED_METHOD_SAY) { + /* local $\ = "\n" */ + SAVEGENERICSV(PL_ors_sv); + PL_ors_sv = newSVpvs("\n"); + } + call_method(methname, flags & G_WANT); + LEAVE_with_name("call_tied_method"); + return NORMAL; +} + +#define tied_method0(a,b,c,d) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0) +#define tied_method1(a,b,c,d,e) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e) +#define tied_method2(a,b,c,d,e,f) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f) + PP(pp_open) { dVAR; dSP; @@ -506,11 +569,11 @@ PP(pp_open) GV * const gv = MUTABLE_GV(*++MARK); - if (!isGV(gv)) + if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv))) DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) { - MAGIC *mg; + const MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; if (IoDIRP(io)) @@ -522,14 +585,9 @@ PP(pp_open) if (mg) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ - *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg); - PUSHMARK(MARK); - PUTBACK; - ENTER_with_name("call_OPEN"); - call_method("OPEN", G_SCALAR); - LEAVE_with_name("call_OPEN"); - SPAGAIN; - RETURN; + return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -552,38 +610,6 @@ PP(pp_open) RETURN; } -static OP * -S_tied_handle_method(pTHX_ const char *const methname, SV **sp, - IO *const io, MAGIC *const mg, unsigned int argc, ...) -{ - PERL_ARGS_ASSERT_TIED_HANDLE_METHOD; - - PUSHMARK(sp); - PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - if (argc) { - va_list args; - va_start(args, argc); - do { - SV *const arg = va_arg(args, SV *); - PUSHs(arg); - } while (--argc); - va_end(args); - } - - PUTBACK; - ENTER_with_name("call_tied_handle_method"); - call_method(methname, G_SCALAR); - LEAVE_with_name("call_tied_handle_method"); - return NORMAL; -} - -#define tied_handle_method(a,b,c,d) \ - S_tied_handle_method(aTHX_ a,b,c,d,0) -#define tied_handle_method1(a,b,c,d,e) \ - S_tied_handle_method(aTHX_ a,b,c,d,1,e) -#define tied_handle_method2(a,b,c,d,e,f) \ - S_tied_handle_method(aTHX_ a,b,c,d,2,e,f) - PP(pp_close) { dVAR; dSP; @@ -595,9 +621,9 @@ PP(pp_close) if (gv) { IO * const io = GvIO(gv); if (io) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_handle_method("CLOSE", SP, io, mg); + return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg); } } } @@ -661,7 +687,6 @@ badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); - return NORMAL; #endif } @@ -671,23 +696,24 @@ PP(pp_fileno) GV *gv; IO *io; PerlIO *fp; - MAGIC *mg; + const MAGIC *mg; if (MAXARG < 1) RETPUSHUNDEF; gv = MUTABLE_GV(POPs); + io = GvIO(gv); - if (gv && (io = GvIO(gv)) + if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_handle_method("FILENO", SP, io, mg); + return tied_method0("FILENO", SP, MUTABLE_SV(io), mg); } - if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) { + if (!io || !(fp = IoIFP(io))) { /* Can't do this because people seem to do things like defined(fileno($foo)) to check whether $foo is a valid fh. - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + + report_evil_fh(gv); */ RETPUSHUNDEF; } @@ -742,22 +768,23 @@ PP(pp_binmode) } gv = MUTABLE_GV(POPs); + io = GvIO(gv); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { /* This takes advantage of the implementation of the varargs function, which I don't think that the optimiser will be able to figure out. Although, as it's a static function, in theory it could. */ - return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg, - discp ? 1 : 0, discp); + return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg, + G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, + discp ? 1 : 0, discp); } } - if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io || !(fp = IoIFP(io))) { + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } @@ -808,7 +835,12 @@ PP(pp_tie) methname = "TIEARRAY"; break; case SVt_PVGV: + case SVt_PVLV: if (isGV_with_GP(varsv)) { + if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) { + deprecate("tie on a handle without *"); + GvFLAGS(varsv) |= GVf_TIEWARNED; + } methname = "TIEHANDLE"; how = PERL_MAGIC_tiedscalar; /* For tied filehandles, we apply tiedscalar magic to the IO @@ -836,8 +868,10 @@ PP(pp_tie) call_method(methname, G_SCALAR); } else { - /* Not clear why we don't call call_method here too. - * perhaps to get different error message ? + /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO" + * will attempt to invoke IO::File::TIEARRAY, with (best case) the + * wrong error message, and worse case, supreme action at a distance. + * (Sorry obfuscation writers. You're not going to be given this one.) */ STRLEN len; const char *name = SvPV_nomg_const(*MARK, len); @@ -883,8 +917,14 @@ PP(pp_untie) const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) + if (isGV_with_GP(sv)) { + if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) { + deprecate("untie on a handle without *"); + GvFLAGS(sv) |= GVf_TIEWARNED; + } + if (!(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHYES; + } if ((mg = SvTIED_mg(sv, how))) { SV * const obj = SvRV(SvTIED_obj(sv, mg)); @@ -921,8 +961,14 @@ PP(pp_tied) const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) + if (isGV_with_GP(sv)) { + if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) { + deprecate("tied on a handle without *"); + GvFLAGS(sv) |= GVf_TIEWARNED; + } + if (!(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHUNDEF; + } if ((mg = SvTIED_mg(sv, how))) { SV *osv = SvTIED_obj(sv, mg); @@ -1024,7 +1070,7 @@ PP(pp_sselect) if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) - DIE(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(aTHX); } if (!SvPOK(sv)) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); @@ -1147,7 +1193,6 @@ PP(pp_sselect) RETURN; #else DIE(aTHX_ "select not implemented"); - return NORMAL; #endif } @@ -1206,32 +1251,27 @@ PP(pp_select) PP(pp_getc) { dVAR; dSP; dTARGET; - IO *io = NULL; GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs); + IO *const io = GvIO(gv); if (MAXARG == 0) EXTEND(SP, 1); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - const I32 gimme = GIMME_V; - PUSHMARK(SP); - PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER; - call_method("GETC", gimme); - LEAVE; - SPAGAIN; - if (gimme == G_SCALAR) + const U32 gimme = GIMME_V; + Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0); + if (gimme == G_SCALAR) { + SPAGAIN; SvSetMagicSV_nosteal(TARG, TOPs); - RETURN; + } + return NORMAL; } } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ - if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) - && ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } @@ -1261,6 +1301,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PERL_ARGS_ASSERT_DOFORM; + if (cv && CvCLONE(cv)) + cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); + ENTER; SAVETMPS; @@ -1316,9 +1359,6 @@ PP(pp_enterwrite) not_a_format_reference: DIE(aTHX_ "Not a format reference"); } - if (CvCLONE(cv)) - cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); - IoFLAGS(io) &= ~IOf_DIDTOP; return doform(cv,gv,PL_op->op_next); } @@ -1333,6 +1373,7 @@ PP(pp_leavewrite) SV **newsp; I32 gimme; register PERL_CONTEXT *cx; + OP *retop; if (!io || !(ofp = IoOFP(io))) goto forget_top; @@ -1407,24 +1448,21 @@ PP(pp_leavewrite) else DIE(aTHX_ "Undefined top format called"); } - if (cv && CvCLONE(cv)) - cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); return doform(cv, gv, PL_op); } forget_top: POPBLOCK(cx,PL_curpm); POPFORMAT(cx); + retop = cx->blk_sub.retop; LEAVE; fp = IoOFP(io); if (!fp) { - if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); PUSHs(&PL_sv_no); } else { @@ -1447,21 +1485,21 @@ PP(pp_leavewrite) PUTBACK; PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); - return cx->blk_sub.retop; + return retop; } PP(pp_prtf) { dVAR; dSP; dMARK; dORIGMARK; - IO *io; PerlIO *fp; SV *sv; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; + IO *const io = GvIO(gv); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { if (MARK == ORIGMARK) { MEXTEND(SP, 1); @@ -1469,34 +1507,24 @@ PP(pp_prtf) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - PUSHMARK(MARK - 1); - *MARK = SvTIED_obj(MUTABLE_SV(io), mg); - PUTBACK; - ENTER; - call_method("PRINTF", G_SCALAR); - LEAVE; - SPAGAIN; - MARK = ORIGMARK + 1; - *MARK = *SP; - SP = MARK; - RETURN; + return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io), + mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } sv = newSV(0); - if (!(io = GvIO(gv))) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io) { + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - } + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else if (ckWARN(WARN_CLOSED)) + report_evil_fh(gv); SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } @@ -1570,19 +1598,11 @@ PP(pp_sysread) if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && gv && (io = GvIO(gv)) ) { - const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - SV *sv; - PUSHMARK(MARK-1); - *MARK = SvTIED_obj(MUTABLE_SV(io), mg); - ENTER; - call_method("READ", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; + return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -1599,8 +1619,7 @@ PP(pp_sysread) offset = 0; io = GvIO(gv); if (!io || !IoIFP(io)) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto say_undef; } @@ -1640,6 +1659,9 @@ PP(pp_sysread) (struct sockaddr *)namebuf, &bufsize); if (count < 0) RETPUSHUNDEF; + /* MSG_TRUNC can give oversized count; quietly lose it */ + if (count > length) + count = length; #ifdef EPOC /* Bogus return without padding */ bufsize = sizeof (struct sockaddr_in); @@ -1739,8 +1761,8 @@ PP(pp_sysread) count = -1; } if (count < 0) { - if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) - report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); + if (IoTYPE(io) == IoTYPE_WRONLY) + report_wrongway_fh(gv, '>'); goto say_undef; } SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); @@ -1815,26 +1837,17 @@ PP(pp_send) GV *const gv = MUTABLE_GV(*++MARK); if (PL_op->op_type == OP_SYSWRITE && gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - SV *sv; - if (MARK == SP - 1) { - sv = *SP; + SV *sv = *SP; mXPUSHi(sv_len(sv)); PUTBACK; } - PUSHMARK(ORIGMARK); - *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg); - ENTER; - call_method("WRITE", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; + return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } if (!gv) @@ -1846,12 +1859,10 @@ PP(pp_send) io = GvIO(gv); if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) { retval = -1; - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { - if (io && IoIFP(io)) - report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); - else - report_evil_fh(gv, io, PL_op->op_type); - } + if (io && IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); goto say_undef; } @@ -1883,7 +1894,23 @@ PP(pp_send) } } - if (op_type == OP_SYSWRITE) { + if (op_type == OP_SEND) { +#ifdef HAS_SOCKET + const int flags = SvIVx(*++MARK); + if (SP > MARK) { + STRLEN mlen; + char * const sockbuf = SvPVx(*++MARK, mlen); + retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, + flags, (struct sockaddr *)sockbuf, mlen); + } + else { + retval + = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); + } +#else + DIE(aTHX_ PL_no_sock_func, "send"); +#endif + } else { Size_t length = 0; /* This length is in characters. */ STRLEN blen_chars; IV offset; @@ -1978,24 +2005,6 @@ PP(pp_send) buffer, length); } } -#ifdef HAS_SOCKET - else { - const int flags = SvIVx(*++MARK); - if (SP > MARK) { - STRLEN mlen; - char * const sockbuf = SvPVx(*++MARK, mlen); - retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, - flags, (struct sockaddr *)sockbuf, mlen); - } - else { - retval - = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); - } - } -#else - else - DIE(aTHX_ PL_no_sock_func, "send"); -#endif if (retval < 0) goto say_undef; @@ -2022,7 +2031,7 @@ PP(pp_eof) dVAR; dSP; GV *gv; IO *io; - MAGIC *mg; + const MAGIC *mg; /* * in Perl 5.12 and later, the additional parameter is a bitmask: * 0 = eof @@ -2056,8 +2065,7 @@ PP(pp_eof) RETPUSHNO; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_handle_method1("EOF", SP, io, mg, - sv_2mortal(newSVuv(which))); + return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which)); } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ @@ -2093,10 +2101,11 @@ PP(pp_tell) EXTEND(SP, 1); gv = PL_last_in_gv; - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + io = GvIO(gv); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_handle_method("TELL", SP, io, mg); + return tied_method0("TELL", SP, MUTABLE_SV(io), mg); } } else if (!gv) { @@ -2125,19 +2134,19 @@ PP(pp_sysseek) #endif GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs); - IO *io; + IO *const io = GvIO(gv); - if (gv && (io = GvIO(gv))) { - MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { #if LSEEKSIZE > IVSIZE - SV *const offset_sv = sv_2mortal(newSVnv((NV) offset)); + SV *const offset_sv = newSVnv((NV) offset); #else - SV *const offset_sv = sv_2mortal(newSViv(offset)); + SV *const offset_sv = newSViv(offset); #endif - return tied_handle_method2("SEEK", SP, io, mg, offset_sv, - sv_2mortal(newSViv(whence))); + return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv, + newSViv(whence)); } } @@ -2190,11 +2199,11 @@ PP(pp_truncate) tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO); do_ftruncate_gv: - if (!GvIO(tmpgv)) + io = GvIO(tmpgv); + if (!io) result = 0; else { PerlIO *fp; - io = GvIOp(tmpgv); do_ftruncate_io: TAINT_PROPER("truncate"); if (!(fp = IoIFP(io))) { @@ -2268,8 +2277,7 @@ PP(pp_ioctl) IV retval; if (!io || !argsv || !IoIFP(io)) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ RETPUSHUNDEF; } @@ -2336,25 +2344,18 @@ PP(pp_flock) #ifdef FLOCK dVAR; dSP; dTARGET; I32 value; - IO *io = NULL; - PerlIO *fp; const int argtype = POPi; GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs); + IO *const io = GvIO(gv); + PerlIO *const fp = io ? IoIFP(io) : NULL; - if (gv && (io = GvIO(gv))) - fp = IoIFP(io); - else { - fp = NULL; - io = NULL; - } /* XXX Looks to me like io is always NULL at this point */ if (fp) { (void)PerlIO_flush(fp); value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); value = 0; SETERRNO(EBADF,RMS_IFI); } @@ -2362,7 +2363,6 @@ PP(pp_flock) RETURN; #else DIE(aTHX_ PL_no_func, "flock()"); - return NORMAL; #endif } @@ -2379,9 +2379,8 @@ PP(pp_socket) register IO * const io = gv ? GvIOn(gv) : NULL; int fd; - if (!gv || !io) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (!io) { + report_evil_fh(gv); if (io && IoIFP(io)) do_close(gv, FALSE); SETERRNO(EBADF,LIB_INVARG); @@ -2415,7 +2414,6 @@ PP(pp_socket) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); - return NORMAL; #endif } @@ -2432,25 +2430,19 @@ PP(pp_sockpair) register IO * const io2 = gv2 ? GvIOn(gv2) : NULL; int fd[2]; - if (!gv1 || !gv2 || !io1 || !io2) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { - if (!gv1 || !io1) - report_evil_fh(gv1, io1, PL_op->op_type); - if (!gv2 || !io2) - report_evil_fh(gv1, io2, PL_op->op_type); - } - if (io1 && IoIFP(io1)) - do_close(gv1, FALSE); - if (io2 && IoIFP(io2)) - do_close(gv2, FALSE); - RETPUSHUNDEF; - } + if (!io1) + report_evil_fh(gv1); + if (!io2) + report_evil_fh(gv2); - if (IoIFP(io1)) + if (io1 && IoIFP(io1)) do_close(gv1, FALSE); - if (IoIFP(io2)) + if (io2 && IoIFP(io2)) do_close(gv2, FALSE); + if (!io1 || !io2) + RETPUSHUNDEF; + TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; @@ -2477,7 +2469,6 @@ PP(pp_sockpair) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socketpair"); - return NORMAL; #endif } @@ -2491,56 +2482,27 @@ PP(pp_bind) GV * const gv = MUTABLE_GV(POPs); register IO * const io = GvIOn(gv); STRLEN len; + const int op_type = PL_op->op_type; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); - TAINT_PROPER("bind"); - if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) - RETPUSHYES; - else - RETPUSHUNDEF; - -nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS_IVCHAN); - RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_sock_func, "bind"); - return NORMAL; -#endif -} - -PP(pp_connect) -{ -#ifdef HAS_SOCKET - dVAR; dSP; - SV * const addrsv = POPs; - GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); - const char *addr; - STRLEN len; - - if (!io || !IoIFP(io)) - goto nuts; - - addr = SvPV_const(addrsv, len); - TAINT_PROPER("connect"); - if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) + TAINT_PROPER(PL_op_desc[op_type]); + if ((op_type == OP_BIND + ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) + : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)) + >= 0) RETPUSHYES; else RETPUSHUNDEF; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else - DIE(aTHX_ PL_no_sock_func, "connect"); - return NORMAL; + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif } @@ -2552,7 +2514,7 @@ PP(pp_listen) GV * const gv = MUTABLE_GV(POPs); register IO * const io = gv ? GvIOn(gv) : NULL; - if (!gv || !io || !IoIFP(io)) + if (!io || !IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) @@ -2561,13 +2523,11 @@ PP(pp_listen) RETPUSHUNDEF; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); - return NORMAL; #endif } @@ -2638,8 +2598,7 @@ PP(pp_accept) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); + report_evil_fh(ggv); SETERRNO(EBADF,SS_IVCHAN); badexit: @@ -2647,7 +2606,6 @@ badexit: #else DIE(aTHX_ PL_no_sock_func, "accept"); - return NORMAL; #endif } @@ -2666,13 +2624,11 @@ PP(pp_shutdown) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); - return NORMAL; #endif } @@ -2742,15 +2698,13 @@ PP(pp_ssockopt) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, optype); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -2807,15 +2761,13 @@ PP(pp_getpeername) RETURN; nuts: - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, optype); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -2864,8 +2816,7 @@ PP(pp_stat) } if (PL_laststatval < 0) { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, GvIO(gv), PL_op->op_type); + report_evil_fh(gv); max = 0; } } @@ -3036,7 +2987,7 @@ PP(pp_ftrread) conditional compiling below much clearer. */ I32 use_access = 0; #endif - int stat_mode = S_IRUSR; + Mode_t stat_mode = S_IRUSR; bool effective = FALSE; char opchar = '?'; @@ -3130,7 +3081,7 @@ PP(pp_ftrread) #endif } - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3158,7 +3109,7 @@ PP(pp_ftis) STACKED_FTEST_CHECK; - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3213,24 +3164,33 @@ PP(pp_ftrowned) } tryAMAGICftest_MG(opchar); + STACKED_FTEST_CHECK; + /* I believe that all these three are likely to be defined on most every system these days. */ #ifndef S_ISUID - if(PL_op->op_type == OP_FTSUID) + if(PL_op->op_type == OP_FTSUID) { + if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + (void) POPs; RETPUSHNO; + } #endif #ifndef S_ISGID - if(PL_op->op_type == OP_FTSGID) + if(PL_op->op_type == OP_FTSGID) { + if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + (void) POPs; RETPUSHNO; + } #endif #ifndef S_ISVTX - if(PL_op->op_type == OP_FTSVTX) + if(PL_op->op_type == OP_FTSVTX) { + if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + (void) POPs; RETPUSHNO; + } #endif - STACKED_FTEST_CHECK; - - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3300,7 +3260,7 @@ PP(pp_ftlink) I32 result; tryAMAGICftest_MG('l'); - result = my_lstat(); + result = my_lstat_flags(0); SPAGAIN; if (result < 0) @@ -3317,6 +3277,8 @@ PP(pp_fttty) int fd; GV *gv; SV *tmpsv = NULL; + char *name = NULL; + STRLEN namelen; tryAMAGICftest_MG('t'); @@ -3324,19 +3286,21 @@ PP(pp_fttty) if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV(TOPs)) + else if (isGV_with_GP(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); - else - gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO); + else { + tmpsv = POPs; + name = SvPV_nomg(tmpsv, namelen); + gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); + } if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (tmpsv && SvOK(tmpsv)) { - const char *tmps = SvPV_nolen_const(tmpsv); - if (isDIGIT(*tmps)) - fd = atoi(tmps); + if (isDIGIT(*name)) + fd = atoi(name); else RETPUSHUNDEF; } @@ -3375,7 +3339,7 @@ PP(pp_fttext) if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV(TOPs)) + else if (isGV_with_GP(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); @@ -3424,10 +3388,7 @@ PP(pp_fttext) len = 512; } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { - gv = cGVOP_gv; - report_evil_fh(gv, GvIO(gv), PL_op->op_type); - } + report_evil_fh(cGVOP_gv); SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } @@ -3437,7 +3398,7 @@ PP(pp_fttext) really_filename: PL_statgv = NULL; PL_laststype = OP_STAT; - sv_setpv(PL_statname, SvPV_nolen_const(sv)); + sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) @@ -3571,15 +3532,13 @@ PP(pp_chdir) PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF, RMS_IFI); PUSHi(0); } } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); PUSHi(0); } @@ -3617,7 +3576,6 @@ PP(pp_chroot) RETURN; #else DIE(aTHX_ PL_no_func, "chroot"); - return NORMAL; #endif } @@ -3692,7 +3650,6 @@ PP(pp_link) { /* Have neither. */ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); - return NORMAL; } #endif @@ -3907,7 +3864,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); - return NORMAL; #endif } @@ -3915,7 +3871,6 @@ PP(pp_readdir) { #if !defined(Direntry_t) || !defined(HAS_READDIR) DIE(aTHX_ PL_no_dir_func, "readdir"); - return NORMAL; #else #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); @@ -3994,7 +3949,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); - return NORMAL; #endif } @@ -4020,7 +3974,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); - return NORMAL; #endif } @@ -4044,7 +3997,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); - return NORMAL; #endif } @@ -4077,7 +4029,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); - return NORMAL; #endif } @@ -4124,7 +4075,6 @@ PP(pp_fork) RETURN; # else DIE(aTHX_ PL_no_func, "fork"); - return NORMAL; # endif #endif } @@ -4154,7 +4104,6 @@ PP(pp_wait) RETURN; #else DIE(aTHX_ PL_no_func, "wait"); - return NORMAL; #endif } @@ -4185,7 +4134,6 @@ PP(pp_waitpid) RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); - return NORMAL; #endif } @@ -4391,7 +4339,6 @@ PP(pp_getppid) RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); - return NORMAL; #endif } @@ -4413,7 +4360,6 @@ PP(pp_getpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "getpgrp()"); - return NORMAL; #endif } @@ -4447,21 +4393,25 @@ PP(pp_setpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "setpgrp()"); - return NORMAL; #endif } +#if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2)) +# define PRIORITY_WHICH_T(which) (__priority_which_t)which +#else +# define PRIORITY_WHICH_T(which) which +#endif + PP(pp_getpriority) { #ifdef HAS_GETPRIORITY dVAR; dSP; dTARGET; const int who = POPi; const int which = TOPi; - SETi( getpriority(which, who) ); + SETi( getpriority(PRIORITY_WHICH_T(which), who) ); RETURN; #else DIE(aTHX_ PL_no_func, "getpriority()"); - return NORMAL; #endif } @@ -4473,14 +4423,15 @@ PP(pp_setpriority) const int who = POPi; const int which = TOPi; TAINT_PROPER("setpriority"); - SETi( setpriority(which, who, niceval) >= 0 ); + SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); - return NORMAL; #endif } +#undef PRIORITY_WHICH_T + /* Time calls. */ PP(pp_time) @@ -4528,7 +4479,6 @@ PP(pp_tms) RETURN; # else DIE(aTHX_ "times not implemented"); - return NORMAL; # endif #endif /* HAS_TIMES */ } @@ -4645,7 +4595,6 @@ PP(pp_alarm) RETURN; #else DIE(aTHX_ PL_no_func, "alarm"); - return NORMAL; #endif } @@ -4715,7 +4664,6 @@ PP(pp_semget) RETURN; #else DIE(aTHX_ "System V IPC is not implemented on this machine"); - return NORMAL; #endif } @@ -4851,7 +4799,6 @@ PP(pp_ghostent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "gethostent"); - return NORMAL; #endif } @@ -4925,7 +4872,6 @@ PP(pp_gnetent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getnetent"); - return NORMAL; #endif } @@ -4986,7 +4932,6 @@ PP(pp_gprotoent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); - return NORMAL; #endif } @@ -5062,7 +5007,6 @@ PP(pp_gservent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getservent"); - return NORMAL; #endif } @@ -5074,7 +5018,6 @@ PP(pp_shostent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "sethostent"); - return NORMAL; #endif } @@ -5086,7 +5029,6 @@ PP(pp_snetent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setnetent"); - return NORMAL; #endif } @@ -5098,7 +5040,6 @@ PP(pp_sprotoent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setprotoent"); - return NORMAL; #endif } @@ -5110,7 +5051,6 @@ PP(pp_sservent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setservent"); - return NORMAL; #endif } @@ -5123,7 +5063,6 @@ PP(pp_ehostent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endhostent"); - return NORMAL; #endif } @@ -5136,7 +5075,6 @@ PP(pp_enetent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endnetent"); - return NORMAL; #endif } @@ -5149,7 +5087,6 @@ PP(pp_eprotoent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endprotoent"); - return NORMAL; #endif } @@ -5162,7 +5099,6 @@ PP(pp_eservent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endservent"); - return NORMAL; #endif } @@ -5309,7 +5245,7 @@ PP(pp_gpwent) const struct spwd * const spwent = getspnam(pwent->pw_name); /* Save and restore errno so that * underprivileged attempts seem - * to have never made the unsccessful + * to have never made the unsuccessful * attempt to retrieve the shadow password. */ RESTORE_ERRNO; if (spwent && spwent->sp_pwdp) @@ -5396,7 +5332,6 @@ PP(pp_gpwent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -5408,7 +5343,6 @@ PP(pp_spwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); - return NORMAL; #endif } @@ -5420,7 +5354,6 @@ PP(pp_epwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); - return NORMAL; #endif } @@ -5495,7 +5428,6 @@ PP(pp_ggrent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -5507,7 +5439,6 @@ PP(pp_sgrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setgrent"); - return NORMAL; #endif } @@ -5519,7 +5450,6 @@ PP(pp_egrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endgrent"); - return NORMAL; #endif } @@ -5531,11 +5461,11 @@ PP(pp_getlogin) EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) RETPUSHUNDEF; - PUSHp(tmps, strlen(tmps)); + sv_setpv_mg(TARG, tmps); + PUSHs(TARG); RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); - return NORMAL; #endif } @@ -5634,7 +5564,6 @@ PP(pp_syscall) RETURN; #else DIE(aTHX_ PL_no_func, "syscall"); - return NORMAL; #endif }