X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/21a64c3ee03cc1a361f10224a63c36ef3523d3d8..e0b7b5e2d45f1c3adc7e7f4afb29a4cfa6ca788c:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 3757401..aba3b14 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -359,23 +359,24 @@ PP(pp_glob) dVAR; OP *result; dSP; + GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; + + PUTBACK; + /* make a copy of the pattern if it is gmagical, to ensure that magic * is called once and only once */ - if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s)); + if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); - tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); + tryAMAGICunTARGETlist(iter_amg, (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 + * MARK, wildcard * and following OPs should be: gv(CORE::GLOBAL::glob), entersub * */ return NORMAL; } - /* stack args are: wildcard, gv(_GEN_n) */ - if (PL_globhook) { - SETs(GvSV(TOPs)); PL_globhook(aTHX); return NORMAL; } @@ -387,7 +388,7 @@ PP(pp_glob) ENTER_with_name("glob"); #ifndef VMS - if (PL_tainting) { + if (TAINTING_get) { /* * The external globbing program may use things we can't control, * so for security reasons we must assume the worst. @@ -398,7 +399,7 @@ PP(pp_glob) #endif /* !VMS */ SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */ - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + PL_last_in_gv = gv; SAVESPTR(PL_rs); /* This is not permanent, either. */ PL_rs = newSVpvs_flags("\000", SVs_TEMP); @@ -438,20 +439,30 @@ PP(pp_warn) } else { exsv = TOPs; + if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv); } if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { /* well-formed exception supplied */ } - else if (SvROK(ERRSV)) { - exsv = ERRSV; - } - else if (SvPOK(ERRSV) && SvCUR(ERRSV)) { - exsv = sv_mortalcopy(ERRSV); - sv_catpvs(exsv, "\t...caught"); - } else { + SV * const errsv = ERRSV; + SvGETMAGIC(errsv); + if (SvROK(errsv)) { + if (SvGMAGICAL(errsv)) { + exsv = sv_newmortal(); + sv_setsv_nomg(exsv, errsv); + } + else exsv = errsv; + } + else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) { + exsv = sv_newmortal(); + sv_setsv_nomg(exsv, errsv); + sv_catpvs(exsv, "\t...caught"); + } + else { exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); + } } if (SvROK(exsv) && !PL_warnhook) Perl_warn(aTHX_ "%"SVf, SVfARG(exsv)); @@ -465,7 +476,8 @@ PP(pp_die) SV *exsv; STRLEN len; #ifdef VMS - VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); + VMSISH_HUSHED = + VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH); #endif if (SP - MARK != 1) { dTARGET; @@ -480,32 +492,36 @@ PP(pp_die) if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { /* well-formed exception supplied */ } - else if (SvROK(ERRSV)) { - exsv = ERRSV; - if (sv_isobject(exsv)) { - HV * const stash = SvSTASH(SvRV(exsv)); - GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); - if (gv) { - SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); - SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); - EXTEND(SP, 3); - PUSHMARK(SP); - PUSHs(exsv); - PUSHs(file); - PUSHs(line); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), - G_SCALAR|G_EVAL|G_KEEPERR); - exsv = sv_mortalcopy(*PL_stack_sp--); + else { + SV * const errsv = ERRSV; + SvGETMAGIC(errsv); + if (SvROK(errsv)) { + exsv = errsv; + if (sv_isobject(exsv)) { + HV * const stash = SvSTASH(SvRV(exsv)); + GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); + if (gv) { + SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); + SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); + EXTEND(SP, 3); + PUSHMARK(SP); + PUSHs(exsv); + PUSHs(file); + PUSHs(line); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(gv)), + G_SCALAR|G_EVAL|G_KEEPERR); + exsv = sv_mortalcopy(*PL_stack_sp--); + } } } - } - else if (SvPOK(ERRSV) && SvCUR(ERRSV)) { - exsv = sv_mortalcopy(ERRSV); - sv_catpvs(exsv, "\t...propagated"); - } - else { - exsv = newSVpvs_flags("Died", SVs_TEMP); + else if (SvPOK(errsv) && SvCUR(errsv)) { + exsv = sv_mortalcopy(errsv); + sv_catpvs(exsv, "\t...propagated"); + } + else { + exsv = newSVpvs_flags("Died", SVs_TEMP); + } } return die_sv(exsv); } @@ -513,7 +529,7 @@ PP(pp_die) /* I/O. */ OP * -Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, +Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, const MAGIC *const mg, const U32 flags, U32 argc, ...) { SV **orig_sp = sp; @@ -557,7 +573,7 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, SAVEGENERICSV(PL_ors_sv); PL_ors_sv = newSVpvs("\n"); } - ret_args = call_method(methname, flags & G_WANT); + ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED); SPAGAIN; orig_sp = sp; POPSTACK; @@ -608,7 +624,7 @@ PP(pp_open) if (mg) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ - return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg, + return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg, G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, sp - mark); } @@ -647,7 +663,7 @@ PP(pp_close) if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg); + return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg); } } } @@ -660,8 +676,8 @@ PP(pp_pipe_op) #ifdef HAS_PIPE dVAR; dSP; - register IO *rstio; - register IO *wstio; + IO *rstio; + IO *wstio; int fd[2]; GV * const wgv = MUTABLE_GV(POPs); @@ -730,7 +746,7 @@ PP(pp_fileno) if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_method0("FILENO", SP, MUTABLE_SV(io), mg); + return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg); } if (!io || !(fp = IoIFP(io))) { @@ -801,7 +817,7 @@ PP(pp_binmode) 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 Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg, + return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg, G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, discp ? 1 : 0, discp); } @@ -852,9 +868,16 @@ PP(pp_tie) switch(SvTYPE(varsv)) { case SVt_PVHV: + { + HE *entry; methname = "TIEHASH"; + if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) { + HvLAZYDEL_off(varsv); + hv_free_ent((HV *)varsv, entry); + } HvEITER_set(MUTABLE_HV(varsv), 0); break; + } case SVt_PVAV: methname = "TIEARRAY"; if (!AvREAL(varsv)) { @@ -877,6 +900,10 @@ PP(pp_tie) varsv = MUTABLE_SV(GvIOp(varsv)); break; } + if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') { + vivify_defelem(varsv); + varsv = LvTARG(varsv); + } /* FALL THROUGH */ default: methname = "TIESCALAR"; @@ -945,6 +972,9 @@ PP(pp_untie) if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHYES; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && + !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; + if ((mg = SvTIED_mg(sv, how))) { SV * const obj = SvRV(SvTIED_obj(sv, mg)); if (obj) { @@ -983,6 +1013,9 @@ PP(pp_tied) if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHUNDEF; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && + !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; + if ((mg = SvTIED_mg(sv, how))) { PUSHs(SvTIED_obj(sv, mg)); RETURN; @@ -1050,10 +1083,10 @@ PP(pp_sselect) { #ifdef HAS_SELECT dVAR; dSP; dTARGET; - register I32 i; - register I32 j; - register char *s; - register SV *sv; + I32 i; + I32 j; + char *s; + SV *sv; NV value; I32 maxlen = 0; I32 nfound; @@ -1081,11 +1114,10 @@ PP(pp_sselect) if (!SvOK(sv)) continue; if (SvREADONLY(sv)) { - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); - if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) - Perl_croak_no_modify(aTHX); + if (!(SvPOK(sv) && SvCUR(sv) == 0)) + Perl_croak_no_modify(); } + else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); if (!SvPOK(sv)) { if (!SvPOKp(sv)) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), @@ -1128,8 +1160,9 @@ PP(pp_sselect) # endif sv = SP[4]; + SvGETMAGIC(sv); if (SvOK(sv)) { - value = SvNV(sv); + value = SvNV_nomg(sv); if (value < 0.0) value = 0.0; timebuf.tv_sec = (long)value; @@ -1227,7 +1260,8 @@ void Perl_setdefout(pTHX_ GV *gv) { dVAR; - SvREFCNT_inc_simple_void(gv); + PERL_ARGS_ASSERT_SETDEFOUT; + SvREFCNT_inc_simple_void_NN(gv); SvREFCNT_dec(PL_defoutgv); PL_defoutgv = gv; } @@ -1277,7 +1311,7 @@ PP(pp_getc) const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { const U32 gimme = GIMME_V; - Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0); + Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0); if (gimme == G_SCALAR) { SPAGAIN; SvSetMagicSV_nosteal(TARG, TOPs); @@ -1312,7 +1346,7 @@ STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { dVAR; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; PERL_ARGS_ASSERT_DOFORM; @@ -1325,8 +1359,12 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx, retop); + if (CvDEPTH(cv) >= 2) { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(CvPADLIST(cv), CvDEPTH(cv)); + } SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1336,8 +1374,8 @@ PP(pp_enterwrite) { dVAR; dSP; - register GV *gv; - register IO *io; + GV *gv; + IO *io; GV *fgv; CV *cv = NULL; SV *tmpsv = NULL; @@ -1360,33 +1398,28 @@ PP(pp_enterwrite) else fgv = gv; - if (!fgv) - goto not_a_format_reference; + assert(fgv); cv = GvFORM(fgv); if (!cv) { tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); - if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv)) - DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv)); - - not_a_format_reference: - DIE(aTHX_ "Not a format reference"); + DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv)); } IoFLAGS(io) &= ~IOf_DIDTOP; - return doform(cv,gv,PL_op->op_next); + RETURNOP(doform(cv,gv,PL_op->op_next)); } PP(pp_leavewrite) { dVAR; dSP; GV * const gv = cxstack[cxstack_ix].blk_format.gv; - register IO * const io = GvIOp(gv); + IO * const io = GvIOp(gv); PerlIO *ofp; PerlIO *fp; SV **newsp; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; OP *retop; if (!io || !(ofp = IoOFP(io))) @@ -1444,35 +1477,31 @@ PP(pp_leavewrite) } } if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) - do_print(PL_formfeed, ofp); + do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; PL_formtarget = PL_toptarget; IoFLAGS(io) |= IOf_DIDTOP; fgv = IoTOP_GV(io); - if (!fgv) - DIE(aTHX_ "bad top format reference"); + assert(fgv); /* IoTOP_GV(io) should have been set above */ cv = GvFORM(fgv); if (!cv) { SV * const sv = sv_newmortal(); gv_efullname4(sv, fgv, NULL, FALSE); - if (SvPOK(sv) && *SvPV_nolen_const(sv)) - DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); - else - DIE(aTHX_ "Undefined top format called"); + DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); } return doform(cv, gv, PL_op); } forget_top: POPBLOCK(cx,PL_curpm); - POPFORMAT(cx); retop = cx->blk_sub.retop; + POPFORMAT(cx); + SP = newsp; /* ignore retval of formline */ LEAVE; - fp = IoOFP(io); - if (!fp) { - if (IoIFP(io)) + if (!io || !(fp = IoOFP(io))) { + if (io && IoIFP(io)) report_wrongway_fh(gv, '<'); else report_evil_fh(gv); @@ -1493,24 +1522,23 @@ PP(pp_leavewrite) PUSHs(&PL_sv_yes); } } - /* bad_ofp: */ PL_formtarget = PL_bodytarget; - PUTBACK; - PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); - return retop; + RETURNOP(retop); } PP(pp_prtf) { dVAR; dSP; dMARK; dORIGMARK; PerlIO *fp; - SV *sv; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; IO *const io = GvIO(gv); + /* Treat empty list as "" */ + if (MARK == SP) XPUSHs(&PL_sv_no); + if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { @@ -1520,14 +1548,13 @@ PP(pp_prtf) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io), + return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io), mg, G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, sp - mark); } } - sv = newSV(0); if (!io) { report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); @@ -1542,6 +1569,7 @@ PP(pp_prtf) goto just_say_no; } else { + SV *sv = sv_newmortal(); do_sprintf(sv, SP - MARK, MARK + 1); if (!do_print(sv, fp)) goto just_say_no; @@ -1550,13 +1578,11 @@ PP(pp_prtf) if (PerlIO_flush(fp) == EOF) goto just_say_no; } - SvREFCNT_dec(sv); SP = ORIGMARK; PUSHs(&PL_sv_yes); RETURN; just_say_no: - SvREFCNT_dec(sv); SP = ORIGMARK; PUSHs(&PL_sv_undef); RETURN; @@ -1611,7 +1637,7 @@ PP(pp_sysread) { const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg, + return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg, G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, sp - mark); } @@ -1623,6 +1649,8 @@ PP(pp_sysread) if (! SvOK(bufsv)) sv_setpvs(bufsv, ""); length = SvIVx(*++MARK); + if (length < 0) + DIE(aTHX_ "Negative length"); SETERRNO(0,0); if (MARK < SP) offset = SvIVx(*++MARK); @@ -1644,19 +1672,20 @@ PP(pp_sysread) buffer = SvPV_force(bufsv, blen); buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); } - if (length < 0) - DIE(aTHX_ "Negative length"); - wanted = length; + if (DO_UTF8(bufsv)) { + blen = sv_len_utf8_nomg(bufsv); + } charstart = TRUE; charskip = 0; skip = 0; + wanted = length; #ifdef HAS_SOCKET if (PL_op->op_type == OP_RECV) { Sock_size_t bufsize; char namebuf[MAXPATHLEN]; -#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else bufsize = sizeof namebuf; @@ -1674,10 +1703,6 @@ PP(pp_sysread) /* 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); -#endif SvCUR_set(bufsv, count); *SvEND(bufsv) = '\0'; (void)SvPOK_only(bufsv); @@ -1693,10 +1718,6 @@ PP(pp_sysread) RETURN; } #endif - if (DO_UTF8(bufsv)) { - /* offset adjust in characters not bytes */ - blen = sv_len_utf8(bufsv); - } if (offset < 0) { if (-offset > (SSize_t)blen) DIE(aTHX_ "Offset outside string"); @@ -1704,7 +1725,7 @@ PP(pp_sysread) } if (DO_UTF8(bufsv)) { /* convert offset-as-chars to offset-as-bytes */ - if (offset >= (int)blen) + if (offset >= (SSize_t)blen) offset += SvCUR(bufsv) - blen; else offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; @@ -1750,20 +1771,6 @@ PP(pp_sysread) } } else -#ifdef HAS_SOCKET__bad_code_maybe - if (IoTYPE(io) == IoTYPE_SOCKET) { - Sock_size_t bufsize; - char namebuf[MAXPATHLEN]; -#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS) - bufsize = sizeof (struct sockaddr_in); -#else - bufsize = sizeof namebuf; -#endif - count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0, - (struct sockaddr *)namebuf, &bufsize); - } - else -#endif { count = PerlIO_read(IoIFP(io), buffer, length); /* PerlIO_read() - like fread() returns 0 on both error and EOF */ @@ -1854,7 +1861,7 @@ PP(pp_syswrite) PUTBACK; } - return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg, + return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg, G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, sp - mark); } @@ -1929,15 +1936,9 @@ PP(pp_syswrite) blen_chars = orig_blen_bytes; } else { /* The SV really is UTF-8. */ - if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { - /* Don't call sv_len_utf8 again because it will call magic - or overloading a second time, and we might get back a - different result. */ - blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen); - } else { - /* It's safe, and it may well be cached. */ - blen_chars = sv_len_utf8(bufsv); - } + /* Don't call sv_len_utf8 on a magical or overloaded + scalar, as we might get back a different result. */ + blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen); } } else { blen_chars = blen; @@ -2073,7 +2074,7 @@ PP(pp_eof) RETPUSHNO; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which)); + return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ @@ -2113,7 +2114,7 @@ PP(pp_tell) if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_method0("TELL", SP, MUTABLE_SV(io), mg); + return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg); } } else if (!gv) { @@ -2153,7 +2154,7 @@ PP(pp_sysseek) SV *const offset_sv = newSViv(offset); #endif - return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv, + return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv, newSViv(whence)); } } @@ -2204,9 +2205,9 @@ PP(pp_truncate) GV *tmpgv; IO *io; - if ((tmpgv = PL_op->op_flags & OPf_SPECIAL - ? gv_fetchsv(sv, 0, SVt_PVIO) - : MAYBE_DEREF_GV(sv) )) { + if (PL_op->op_flags & OPf_SPECIAL + ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1) + : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) { io = GvIO(tmpgv); if (!io) result = 0; @@ -2341,7 +2342,7 @@ PP(pp_flock) dVAR; dSP; dTARGET; I32 value; const int argtype = POPi; - GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs); + GV * const gv = MUTABLE_GV(POPs); IO *const io = GvIO(gv); PerlIO *const fp = io ? IoIFP(io) : NULL; @@ -2373,13 +2374,11 @@ PP(pp_socket) const int type = POPi; const int domain = POPi; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = gv ? GvIOn(gv) : NULL; int fd; if (!io) { report_evil_fh(gv); - if (io && IoIFP(io)) - do_close(gv, FALSE); SETERRNO(EBADF,LIB_INVARG); RETPUSHUNDEF; } @@ -2404,10 +2403,6 @@ PP(pp_socket) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif -#ifdef EPOC - setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */ -#endif - RETPUSHYES; } #endif @@ -2416,19 +2411,22 @@ PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dVAR; dSP; + int fd[2]; const int protocol = POPi; const int type = POPi; const int domain = POPi; + GV * gv1; + IO * io1; + GV * const gv2 = MUTABLE_GV(POPs); - GV * const gv1 = MUTABLE_GV(POPs); - register IO * const io1 = gv1 ? GvIOn(gv1) : NULL; - register IO * const io2 = gv2 ? GvIOn(gv2) : NULL; - int fd[2]; + IO * const io2 = gv2 ? GvIOn(gv2) : NULL; + if (!io2) + report_evil_fh(gv2); + gv1 = MUTABLE_GV(POPs); + io1 = gv1 ? GvIOn(gv1) : NULL; if (!io1) report_evil_fh(gv1); - if (!io2) - report_evil_fh(gv2); if (io1 && IoIFP(io1)) do_close(gv1, FALSE); @@ -2476,14 +2474,15 @@ PP(pp_bind) /* OK, so on what platform does bind modify addr? */ const char *addr; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); STRLEN len; - const int op_type = PL_op->op_type; + int op_type; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); + op_type = PL_op->op_type; TAINT_PROPER(PL_op_desc[op_type]); if ((op_type == OP_BIND ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) @@ -2504,7 +2503,7 @@ PP(pp_listen) dVAR; dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = gv ? GvIOn(gv) : NULL; if (!io || !IoIFP(io)) goto nuts; @@ -2523,10 +2522,10 @@ nuts: PP(pp_accept) { dVAR; dSP; dTARGET; - register IO *nstio; - register IO *gstio; + IO *nstio; + IO *gstio; char namebuf[MAXPATHLEN]; -#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) Sock_size_t len = sizeof (struct sockaddr_in); #else Sock_size_t len = sizeof namebuf; @@ -2574,10 +2573,6 @@ PP(pp_accept) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ #endif -#ifdef EPOC - len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */ - setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ -#endif #ifdef __SCO_VERSION__ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ #endif @@ -2599,7 +2594,7 @@ PP(pp_shutdown) dVAR; dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); if (!io || !IoIFP(io)) goto nuts; @@ -2621,7 +2616,7 @@ PP(pp_ssockopt) const unsigned int optname = (unsigned int) POPi; const unsigned int lvl = (unsigned int) POPi; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); int fd; Sock_size_t len; @@ -2690,7 +2685,7 @@ PP(pp_getpeername) dVAR; dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); Sock_size_t len; SV *sv; int fd; @@ -2752,7 +2747,7 @@ PP(pp_stat) dVAR; dSP; GV *gv = NULL; - IO *io; + IO *io = NULL; I32 gimme; I32 max = 13; SV* sv; @@ -2774,28 +2769,33 @@ PP(pp_stat) } if (gv != PL_defgv) { + bool havefp; + do_fstat_have_io: + havefp = FALSE; PL_laststype = OP_STAT; - PL_statgv = gv; + PL_statgv = gv ? gv : (GV *)io; sv_setpvs(PL_statname, ""); if(gv) { io = GvIO(gv); - do_fstat_have_io: - if (io) { + } + if (io) { if (IoIFP(io)) { PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); + havefp = TRUE; } else if (IoDIRP(io)) { PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); + havefp = TRUE; } else { PL_laststatval = -1; } - } } + else PL_laststatval = -1; + if (PL_laststatval < 0 && !havefp) report_evil_fh(gv); } if (PL_laststatval < 0) { - report_evil_fh(gv); max = 0; } } @@ -2804,12 +2804,10 @@ PP(pp_stat) io = MUTABLE_IO(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; - PL_laststype = OP_STAT; - PL_statgv = (GV *)io; - sv_setpvs(PL_statname, ""); goto do_fstat_have_io; } + SvTAINTED_off(PL_statname); /* previous tainting irrelevant */ sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); PL_statgv = NULL; PL_laststype = PL_op->op_type; @@ -2818,8 +2816,14 @@ PP(pp_stat) else PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) + if (ckWARN(WARN_NEWLINE) && + strchr(SvPV_nolen_const(PL_statname), '\n')) + { + /* PL_warn_nl is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); + GCC_DIAG_RESTORE; + } max = 0; } } @@ -2845,24 +2849,10 @@ PP(pp_stat) #endif mPUSHu(PL_statcache.st_mode); mPUSHu(PL_statcache.st_nlink); -#if Uid_t_size > IVSIZE - mPUSHn(PL_statcache.st_uid); -#else -# if Uid_t_sign <= 0 - mPUSHi(PL_statcache.st_uid); -# else - mPUSHu(PL_statcache.st_uid); -# endif -#endif -#if Gid_t_size > IVSIZE - mPUSHn(PL_statcache.st_gid); -#else -# if Gid_t_sign <= 0 - mPUSHi(PL_statcache.st_gid); -# else - mPUSHu(PL_statcache.st_gid); -# endif -#endif + + sv_setuid(PUSHmortal, PL_statcache.st_uid); + sv_setgid(PUSHmortal, PL_statcache.st_gid); + #ifdef USE_STAT_RDEV mPUSHi(PL_statcache.st_rdev); #else @@ -2893,23 +2883,69 @@ PP(pp_stat) RETURN; } +/* All filetest ops avoid manipulating the perl stack pointer in their main + bodies (since commit d2c4d2d1e22d3125), and return using either + S_ft_return_false() or S_ft_return_true(). These two helper functions are + the only two which manipulate the perl stack. To ensure that no stack + manipulation macros are used, the filetest ops avoid defining a local copy + of the stack pointer with dSP. */ + +/* If the next filetest is stacked up with this one + (PL_op->op_private & OPpFT_STACKING), we leave + the original argument on the stack for success, + and skip the stacked operators on failure. + The next few macros/functions take care of this. +*/ + +static OP * +S_ft_return_false(pTHX_ SV *ret) { + OP *next = NORMAL; + dSP; + + if (PL_op->op_flags & OPf_REF) XPUSHs(ret); + else SETs(ret); + PUTBACK; + + if (PL_op->op_private & OPpFT_STACKING) { + while (OP_IS_FILETEST(next->op_type) + && next->op_private & OPpFT_STACKED) + next = next->op_next; + } + return next; +} + +PERL_STATIC_INLINE OP * +S_ft_return_true(pTHX_ SV *ret) { + dSP; + if (PL_op->op_flags & OPf_REF) + XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret)); + else if (!(PL_op->op_private & OPpFT_STACKING)) + SETs(ret); + PUTBACK; + return NORMAL; +} + +#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no) +#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef) +#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes) + #define tryAMAGICftest_MG(chr) STMT_START { \ - if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \ - && PL_op->op_flags & OPf_KIDS \ - && S_try_amagic_ftest(aTHX_ chr)) \ - return NORMAL; \ + if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \ + && PL_op->op_flags & OPf_KIDS) { \ + OP *next = S_try_amagic_ftest(aTHX_ chr); \ + if (next) return next; \ + } \ } STMT_END -STATIC bool +STATIC OP * S_try_amagic_ftest(pTHX_ char chr) { dVAR; - dSP; - SV* const arg = TOPs; + SV *const arg = *PL_stack_sp; assert(chr != '?'); - SvGETMAGIC(arg); + if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); - if (SvAMAGIC(TOPs)) + if (SvAMAGIC(arg)) { const char tmpchr = chr; SV * const tmpsv = amagic_call(arg, @@ -2917,33 +2953,15 @@ S_try_amagic_ftest(pTHX_ char chr) { ftest_amg, AMGf_unary); if (!tmpsv) - return FALSE; - - SPAGAIN; - - if (PL_op->op_private & OPpFT_STACKING) { - if (SvTRUE(tmpsv)) - /* leave the object alone */ - return TRUE; - } + return NULL; - SETs(tmpsv); - PUTBACK; - return TRUE; + return SvTRUE(tmpsv) + ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv); } - return FALSE; + return NULL; } -/* This macro is used by the stacked filetest operators : - * if the previous filetest failed, short-circuit and pass its value. - * Else, discard it from the stack and continue. --rgs - */ -#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ - if (!SvTRUE(TOPs)) { RETURN; } \ - else { (void)POPs; PUTBACK; } \ - } - PP(pp_ftrread) { dVAR; @@ -2967,7 +2985,6 @@ PP(pp_ftrread) bool effective = FALSE; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTRREAD: opchar = 'R'; break; @@ -2979,8 +2996,6 @@ PP(pp_ftrread) } tryAMAGICftest_MG(opchar); - STACKED_FTEST_CHECK; - switch (PL_op->op_type) { case OP_FTRREAD: #if !(defined(HAS_ACCESS) && defined(R_OK)) @@ -3033,7 +3048,7 @@ PP(pp_ftrread) if (use_access) { #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) - const char *name = POPpx; + const char *name = SvPV_nolen(*PL_stack_sp); if (effective) { # ifdef PERL_EFF_ACCESS result = PERL_EFF_ACCESS(name, access_mode); @@ -3050,20 +3065,19 @@ PP(pp_ftrread) # endif } if (result == 0) - RETPUSHYES; + FT_RETURNYES; if (result < 0) - RETPUSHUNDEF; - RETPUSHNO; + FT_RETURNUNDEF; + FT_RETURNNO; #endif } result = my_stat_flags(0); - SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (cando(stat_mode, effective, &PL_statcache)) - RETPUSHYES; - RETPUSHNO; + FT_RETURNYES; + FT_RETURNNO; } PP(pp_ftis) @@ -3072,7 +3086,6 @@ PP(pp_ftis) I32 result; const int op_type = PL_op->op_type; char opchar = '?'; - dSP; switch (op_type) { case OP_FTIS: opchar = 'e'; break; @@ -3083,14 +3096,11 @@ PP(pp_ftis) } tryAMAGICftest_MG(opchar); - STACKED_FTEST_CHECK; - result = my_stat_flags(0); - SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (op_type == OP_FTIS) - RETPUSHYES; + FT_RETURNYES; { /* You can't dTARGET inside OP_FTIS, because you'll get "panic: pad_sv po" - the op is not flagged to have a target. */ @@ -3098,23 +3108,28 @@ PP(pp_ftis) switch (op_type) { case OP_FTSIZE: #if Off_t_size > IVSIZE - PUSHn(PL_statcache.st_size); + sv_setnv(TARG, (NV)PL_statcache.st_size); #else - PUSHi(PL_statcache.st_size); + sv_setiv(TARG, (IV)PL_statcache.st_size); #endif break; case OP_FTMTIME: - PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 ); break; case OP_FTATIME: - PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 ); break; case OP_FTCTIME: - PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 ); break; } + SvSETMAGIC(TARG); + return SvTRUE_nomg(TARG) + ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG); } - RETURN; } PP(pp_ftrowned) @@ -3122,7 +3137,6 @@ PP(pp_ftrowned) dVAR; I32 result; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTROWNED: opchar = 'O'; break; @@ -3140,117 +3154,104 @@ 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_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) - (void) POPs; - RETPUSHNO; + FT_RETURNNO; } #endif #ifndef S_ISGID 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; + FT_RETURNNO; } #endif #ifndef S_ISVTX 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; + FT_RETURNNO; } #endif result = my_stat_flags(0); - SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; switch (PL_op->op_type) { case OP_FTROWNED: - if (PL_statcache.st_uid == PL_uid) - RETPUSHYES; + if (PL_statcache.st_uid == PerlProc_getuid()) + FT_RETURNYES; break; case OP_FTEOWNED: - if (PL_statcache.st_uid == PL_euid) - RETPUSHYES; + if (PL_statcache.st_uid == PerlProc_geteuid()) + FT_RETURNYES; break; case OP_FTZERO: if (PL_statcache.st_size == 0) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTSOCK: if (S_ISSOCK(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTCHR: if (S_ISCHR(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTBLK: if (S_ISBLK(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTFILE: if (S_ISREG(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTDIR: if (S_ISDIR(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; case OP_FTPIPE: if (S_ISFIFO(PL_statcache.st_mode)) - RETPUSHYES; + FT_RETURNYES; break; #ifdef S_ISUID case OP_FTSUID: if (PL_statcache.st_mode & S_ISUID) - RETPUSHYES; + FT_RETURNYES; break; #endif #ifdef S_ISGID case OP_FTSGID: if (PL_statcache.st_mode & S_ISGID) - RETPUSHYES; + FT_RETURNYES; break; #endif #ifdef S_ISVTX case OP_FTSVTX: if (PL_statcache.st_mode & S_ISVTX) - RETPUSHYES; + FT_RETURNYES; break; #endif } - RETPUSHNO; + FT_RETURNNO; } PP(pp_ftlink) { dVAR; - dSP; I32 result; tryAMAGICftest_MG('l'); - STACKED_FTEST_CHECK; result = my_lstat_flags(0); - SPAGAIN; if (result < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (S_ISLNK(PL_statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; + FT_RETURNYES; + FT_RETURNNO; } PP(pp_fttty) { dVAR; - dSP; int fd; GV *gv; char *name = NULL; @@ -3258,12 +3259,10 @@ PP(pp_fttty) tryAMAGICftest_MG('t'); - STACKED_FTEST_CHECK; - if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else { - SV *tmpsv = POPs; + SV *tmpsv = *PL_stack_sp; if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) { name = SvPV_nomg(tmpsv, namelen); gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); @@ -3275,46 +3274,36 @@ PP(pp_fttty) else if (name && isDIGIT(*name)) fd = atoi(name); else - RETPUSHUNDEF; + FT_RETURNUNDEF; if (PerlLIO_isatty(fd)) - RETPUSHYES; - RETPUSHNO; + FT_RETURNYES; + FT_RETURNNO; } -#if defined(atarist) /* this will work with atariST. Configure will - make guesses for other systems. */ -# define FILE_base(f) ((f)->_base) -# define FILE_ptr(f) ((f)->_ptr) -# define FILE_cnt(f) ((f)->_cnt) -# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base)) -#endif - PP(pp_fttext) { dVAR; - dSP; I32 i; - I32 len; + SSize_t len; I32 odd = 0; STDCHAR tbuf[512]; - register STDCHAR *s; - register IO *io; - register SV *sv = NULL; + STDCHAR *s; + IO *io; + SV *sv = NULL; GV *gv; PerlIO *fp; tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); - STACKED_FTEST_CHECK; - if (PL_op->op_flags & OPf_REF) - { gv = cGVOP_gv; - EXTEND(SP, 1); - } - else if (PL_op->op_private & OPpFT_STACKED) + else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) + == OPpFT_STACKED) gv = PL_defgv; - else sv = POPs, gv = MAYBE_DEREF_GV_nomg(sv); + else { + sv = *PL_stack_sp; + gv = MAYBE_DEREF_GV_nomg(sv); + } if (gv) { if (gv == PL_defgv) { @@ -3338,12 +3327,12 @@ PP(pp_fttext) DIE(aTHX_ "-T and -B not implemented on filehandles"); PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); if (PL_laststatval < 0) - RETPUSHUNDEF; + FT_RETURNUNDEF; if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ if (PL_op->op_type == OP_FTTEXT) - RETPUSHNO; + FT_RETURNNO; else - RETPUSHYES; + FT_RETURNYES; } if (PerlIO_get_cnt(IoIFP(io)) <= 0) { i = PerlIO_getc(IoIFP(io)); @@ -3351,7 +3340,7 @@ PP(pp_fttext) (void)PerlIO_ungetc(IoIFP(io),i); } if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */ - RETPUSHYES; + FT_RETURNYES; len = PerlIO_get_bufsiz(IoIFP(io)); s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); /* sfio can have large buffers - limit to 512 */ @@ -3359,34 +3348,44 @@ PP(pp_fttext) len = 512; } else { + SETERRNO(EBADF,RMS_IFI); report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); - RETPUSHUNDEF; + FT_RETURNUNDEF; } } else { sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); really_filename: PL_statgv = NULL; - PL_laststype = OP_STAT; if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { + if (!gv) { + PL_laststatval = -1; + PL_laststype = OP_STAT; + } if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) + { + /* PL_warn_nl is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); - RETPUSHUNDEF; + GCC_DIAG_RESTORE; + } + FT_RETURNUNDEF; } + PL_laststype = OP_STAT; PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); if (PL_laststatval < 0) { (void)PerlIO_close(fp); - RETPUSHUNDEF; + FT_RETURNUNDEF; } PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); len = PerlIO_read(fp, tbuf, sizeof(tbuf)); (void)PerlIO_close(fp); if (len <= 0) { if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) - RETPUSHNO; /* special case NFS directories */ - RETPUSHYES; /* null file is anything */ + FT_RETURNNO; /* special case NFS directories */ + FT_RETURNYES; /* null file is anything */ } s = tbuf; } @@ -3440,9 +3439,9 @@ PP(pp_fttext) } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ - RETPUSHNO; + FT_RETURNNO; else - RETPUSHYES; + FT_RETURNYES; } /* File calls. */ @@ -3556,7 +3555,7 @@ PP(pp_rename) if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { - if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) + if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps, tmps2))) anum = UNLINK(tmps); @@ -3626,9 +3625,7 @@ PP(pp_readlink) char buf[MAXPATHLEN]; int len; -#ifndef INCOMPLETE_TAINTS TAINT; -#endif tmps = POPpconstx; len = readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) @@ -3680,13 +3677,7 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) ; e++) { /* you don't see this */ - const char * const errmsg = -#ifdef HAS_SYS_ERRLIST - sys_errlist[e] -#else - strerror(e) -#endif - ; + const char * const errmsg = Strerror(e) ; if (!errmsg) break; if (instr(s, errmsg)) { @@ -3806,7 +3797,7 @@ PP(pp_open_dir) dVAR; dSP; const char * const dirname = POPpconstx; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); if (!io) goto nope; @@ -3844,8 +3835,8 @@ PP(pp_readdir) SV *sv; const I32 gimme = GIMME; GV * const gv = MUTABLE_GV(POPs); - register const Direntry_t *dp; - register IO * const io = GvIOn(gv); + const Direntry_t *dp; + IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), @@ -3863,15 +3854,13 @@ PP(pp_readdir) #else sv = newSVpv(dp->d_name, 0); #endif -#ifndef INCOMPLETE_TAINTS if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(sv); -#endif mXPUSHs(sv); } while (gimme == G_ARRAY); if (!dp && gimme != G_ARRAY) - goto nope; + RETPUSHUNDEF; RETURN; @@ -3897,7 +3886,7 @@ PP(pp_telldir) long telldir (DIR *); # endif GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), @@ -3923,7 +3912,7 @@ PP(pp_seekdir) dVAR; dSP; const long along = POPl; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), @@ -3948,7 +3937,7 @@ PP(pp_rewinddir) #if defined(HAS_REWINDDIR) || defined(rewinddir) dVAR; dSP; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), @@ -3972,7 +3961,7 @@ PP(pp_closedir) #if defined(Direntry_t) && defined(HAS_READDIR) dVAR; dSP; GV * const gv = MUTABLE_GV(POPs); - register IO * const io = GvIOn(gv); + IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), @@ -4007,16 +3996,34 @@ PP(pp_fork) #ifdef HAS_FORK dVAR; dSP; dTARGET; Pid_t childpid; +#ifdef HAS_SIGPROCMASK + sigset_t oldmask, newmask; +#endif EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; +#ifdef HAS_SIGPROCMASK + sigfillset(&newmask); + sigprocmask(SIG_SETMASK, &newmask, &oldmask); +#endif childpid = PerlProc_fork(); + if (childpid == 0) { + int sig; + PL_sig_pending = 0; + if (PL_psig_pend) + for (sig = 1; sig < SIG_SIZE; sig++) + PL_psig_pend[sig] = 0; + } +#ifdef HAS_SIGPROCMASK + { + dSAVE_ERRNO; + sigprocmask(SIG_SETMASK, &oldmask, NULL); + RESTORE_ERRNO; + } +#endif if (childpid < 0) - RETSETUNDEF; + RETPUSHUNDEF; if (!childpid) { -#ifdef THREADS_HAVE_PIDS - PL_ppid = (IV)getppid(); -#endif #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ #endif @@ -4032,7 +4039,7 @@ PP(pp_fork) PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); if (childpid == -1) - RETSETUNDEF; + RETPUSHUNDEF; PUSHi(childpid); RETURN; # else @@ -4110,11 +4117,11 @@ PP(pp_system) I32 value; int result; - if (PL_tainting) { + if (TAINTING_get) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (PL_tainted) + if (TAINT_get) break; } MARK = ORIGMARK; @@ -4126,13 +4133,13 @@ PP(pp_system) Pid_t childpid; int pp[2]; I32 did_pipes = 0; -#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) +#ifdef HAS_SIGPROCMASK sigset_t newset, oldset; #endif if (PerlProc_pipe(pp) >= 0) did_pipes = 1; -#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) +#ifdef HAS_SIGPROCMASK sigemptyset(&newset); sigaddset(&newset, SIGCHLD); sigprocmask(SIG_BLOCK, &newset, &oldset); @@ -4146,7 +4153,7 @@ PP(pp_system) PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); } -#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) +#ifdef HAS_SIGPROCMASK sigprocmask(SIG_SETMASK, &oldset, NULL); #endif RETURN; @@ -4192,7 +4199,7 @@ PP(pp_system) PerlLIO_close(pp[0]); if (n) { /* Error */ if (n != sizeof(int)) - DIE(aTHX_ "panic: kid popen errno read"); + DIE(aTHX_ "panic: kid popen errno read, n=%u", n); errno = errkid; /* Propagate errno from kid */ STATUS_NATIVE_CHILD_SET(-1); } @@ -4200,7 +4207,7 @@ PP(pp_system) XPUSHi(STATUS_CURRENT); RETURN; } -#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) +#ifdef HAS_SIGPROCMASK sigprocmask(SIG_SETMASK, &oldset, NULL); #endif if (did_pipes) { @@ -4257,11 +4264,11 @@ PP(pp_exec) dVAR; dSP; dMARK; dORIGMARK; dTARGET; I32 value; - if (PL_tainting) { + if (TAINTING_get) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (PL_tainted) + if (TAINT_get) break; } MARK = ORIGMARK; @@ -4276,25 +4283,13 @@ PP(pp_exec) #ifdef VMS value = (I32)vms_do_aexec(NULL, MARK, SP); #else -# ifdef __OPEN_VM - { - (void ) do_aspawn(NULL, MARK, SP); - value = 0; - } -# else value = (I32)do_aexec(NULL, MARK, SP); -# endif #endif else { #ifdef VMS value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #else -# ifdef __OPEN_VM - (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); - value = 0; -# else value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); -# endif #endif } @@ -4307,14 +4302,7 @@ PP(pp_getppid) { #ifdef HAS_GETPPID dVAR; dSP; dTARGET; -# ifdef THREADS_HAVE_PIDS - if (PL_ppid != 1 && getppid() == 1) - /* maybe the parent process has died. Refresh ppid cache */ - PL_ppid = 1; - XPUSHi( PL_ppid ); -# else XPUSHi( getppid() ); -# endif RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); @@ -4697,8 +4685,8 @@ PP(pp_ghostent) #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) dVAR; dSP; I32 which = PL_op->op_type; - register char **elem; - register SV *sv; + char **elem; + SV *sv; #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); struct hostent *gethostbyname(Netdb_name_t); @@ -4787,7 +4775,7 @@ PP(pp_gnetent) #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) dVAR; dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ struct netent *getnetbyaddr(Netdb_net_t, int); struct netent *getnetbyname(Netdb_name_t); @@ -4860,7 +4848,7 @@ PP(pp_gprotoent) #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) dVAR; dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ struct protoent *getprotobyname(Netdb_name_t); struct protoent *getprotobynumber(int); @@ -4920,7 +4908,7 @@ PP(pp_gservent) #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) dVAR; dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ struct servent *getservbyname(Netdb_name_t, Netdb_name_t); struct servent *getservbyport(int, Netdb_name_t); @@ -4941,9 +4929,7 @@ PP(pp_gservent) #ifdef HAS_GETSERVBYPORT const char * const proto = POPpbytex; unsigned short port = (unsigned short)POPu; -#ifdef HAS_HTONS port = PerlSock_htons(port); -#endif sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto); #else DIE(aTHX_ PL_no_sock_func, "getservbyport"); @@ -4961,11 +4947,7 @@ PP(pp_gservent) PUSHs(sv = sv_newmortal()); if (sent) { if (which == OP_GSBYNAME) { -#ifdef HAS_NTOHS sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port)); -#else - sv_setiv(sv, (IV)(sent->s_port)); -#endif } else sv_setpv(sv, sent->s_name); @@ -4976,11 +4958,7 @@ PP(pp_gservent) if (sent) { mPUSHs(newSVpv(sent->s_name, 0)); PUSHs(space_join_names_mortal(sent->s_aliases)); -#ifdef HAS_NTOHS mPUSHi(PerlSock_ntohs(sent->s_port)); -#else - mPUSHi(sent->s_port); -#endif mPUSHs(newSVpv(sent->s_proto, 0)); } @@ -5097,7 +5075,7 @@ PP(pp_gpwent) #ifdef HAS_PASSWD dVAR; dSP; I32 which = PL_op->op_type; - register SV *sv; + SV *sv; struct passwd *pwent = NULL; /* * We currently support only the SysV getsp* shadow password interface. @@ -5195,11 +5173,7 @@ PP(pp_gpwent) PUSHs(sv = sv_newmortal()); if (pwent) { if (which == OP_GPWNAM) -# if Uid_t_sign <= 0 - sv_setiv(sv, (IV)pwent->pw_uid); -# else - sv_setuv(sv, (UV)pwent->pw_uid); -# endif + sv_setuid(sv, pwent->pw_uid); else sv_setpv(sv, pwent->pw_name); } @@ -5247,23 +5221,13 @@ PP(pp_gpwent) sv_setpv(sv, pwent->pw_passwd); # endif -# ifndef INCOMPLETE_TAINTS /* passwd is tainted because user himself can diddle with it. * admittedly not much and in a very limited way, but nevertheless. */ SvTAINTED_on(sv); -# endif -# if Uid_t_sign <= 0 - mPUSHi(pwent->pw_uid); -# else - mPUSHu(pwent->pw_uid); -# endif + sv_setuid(PUSHmortal, pwent->pw_uid); + sv_setgid(PUSHmortal, pwent->pw_gid); -# if Uid_t_sign <= 0 - mPUSHi(pwent->pw_gid); -# else - mPUSHu(pwent->pw_gid); -# endif /* pw_change, pw_quota, and pw_age are mutually exclusive-- * because of the poor interface of the Perl getpw*(), * not because there's some standard/convention saying so. @@ -5302,18 +5266,14 @@ PP(pp_gpwent) # else PUSHs(sv = sv_mortalcopy(&PL_sv_no)); # endif -# ifndef INCOMPLETE_TAINTS /* pw_gecos is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); -# endif mPUSHs(newSVpv(pwent->pw_dir, 0)); PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0))); -# ifndef INCOMPLETE_TAINTS /* pw_shell is tainted because user himself can diddle with it. */ SvTAINTED_on(sv); -# endif # ifdef PWEXPIRE mPUSHi(pwent->pw_expire); @@ -5354,11 +5314,7 @@ PP(pp_ggrent) PUSHs(sv); if (grent) { if (which == OP_GGRNAM) -#if Gid_t_sign <= 0 - sv_setiv(sv, (IV)grent->gr_gid); -#else - sv_setuv(sv, (UV)grent->gr_gid); -#endif + sv_setgid(sv, grent->gr_gid); else sv_setpv(sv, grent->gr_name); } @@ -5374,11 +5330,7 @@ PP(pp_ggrent) PUSHs(sv_mortalcopy(&PL_sv_no)); #endif -#if Gid_t_sign <= 0 - mPUSHi(grent->gr_gid); -#else - mPUSHu(grent->gr_gid); -#endif + sv_setgid(PUSHmortal, grent->gr_gid); #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API)) /* In UNICOS/mk (_CRAYMPP) the multithreading @@ -5421,12 +5373,12 @@ PP(pp_syscall) { #ifdef HAS_SYSCALL dVAR; dSP; dMARK; dORIGMARK; dTARGET; - register I32 items = SP - MARK; + I32 items = SP - MARK; unsigned long a[20]; - register I32 i = 0; - I32 retval = -1; + I32 i = 0; + IV retval = -1; - if (PL_tainting) { + if (TAINTING_get) { while (++MARK <= SP) { if (SvTAINTED(*MARK)) { TAINT; @@ -5480,30 +5432,6 @@ PP(pp_syscall) case 8: retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); break; -#ifdef atarist - case 9: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]); - break; - case 10: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]); - break; - case 11: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10]); - break; - case 12: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11]); - break; - case 13: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11],a[12]); - break; - case 14: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11],a[12],a[13]); - break; -#endif /* atarist */ } SP = ORIGMARK; PUSHi(retval); @@ -5638,8 +5566,8 @@ lockf_emulate_flock(int fd, int operation) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */