X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/043647aa56b4b8e6d11b57c6bdb10a4007670155..88621eaff54e5f5ea9adea13440d1750968643a6:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 726be76..b233942 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -49,10 +49,6 @@ # include #endif -#ifdef I_SYS_WAIT -# include -#endif - #ifdef I_SYS_RESOURCE # include #endif @@ -252,6 +248,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresuid(euid, ruid, (Uid_t)-1)) #endif #endif + /* diag_listed_as: entering effective %s failed */ Perl_croak(aTHX_ "entering effective uid failed"); #endif @@ -265,6 +262,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresgid(egid, rgid, (Gid_t)-1)) #endif #endif + /* diag_listed_as: entering effective %s failed */ Perl_croak(aTHX_ "entering effective gid failed"); #endif @@ -277,6 +275,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresuid(ruid, euid, (Uid_t)-1)) #endif #endif + /* diag_listed_as: leaving effective %s failed */ Perl_croak(aTHX_ "leaving effective uid failed"); #ifdef HAS_SETREGID @@ -286,6 +285,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) if (setresgid(rgid, egid, (Gid_t)-1)) #endif #endif + /* diag_listed_as: leaving effective %s failed */ Perl_croak(aTHX_ "leaving effective gid failed"); return res; @@ -359,11 +359,11 @@ PP(pp_glob) dVAR; OP *result; dSP; - /* make a copy of the pattern, to ensure that magic is called once - * and only once */ - TOPm1s = sv_2mortal(newSVsv(TOPm1s)); + /* 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)); - tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); + tryAMAGICunTARGETlist(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: @@ -374,6 +374,11 @@ PP(pp_glob) } /* stack args are: wildcard, gv(_GEN_n) */ + if (PL_globhook) { + SETs(GvSV(TOPs)); + PL_globhook(aTHX); + return NORMAL; + } /* Note that we only ever get here if File::Glob fails to load * without at the same time croaking, for some reason, or if @@ -433,20 +438,29 @@ 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 { + 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)); @@ -495,7 +509,7 @@ PP(pp_die) } } } - else if (SvPOK(ERRSV) && SvCUR(ERRSV)) { + else if (SvPV_const(ERRSV, len), len) { exsv = sv_mortalcopy(ERRSV); sv_catpvs(exsv, "\t...propagated"); } @@ -596,8 +610,8 @@ PP(pp_open) if (IoDIRP(io)) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening dirhandle %s also as a file", - GvENAME(gv)); + "Opening dirhandle %"HEKf" also as a file", + HEKfARG(GvENAME_HEK(gv))); mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { @@ -631,7 +645,8 @@ PP(pp_open) PP(pp_close) { dVAR; dSP; - GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs); + GV * const gv = + MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); if (MAXARG == 0) EXTEND(SP, 1); @@ -654,8 +669,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); @@ -748,7 +763,7 @@ PP(pp_umask) dTARGET; Mode_t anum; - if (MAXARG < 1) { + if (MAXARG < 1 || (!TOPs && !POPs)) { anum = PerlLIO_umask(022); /* setting it to 022 between the two calls to umask avoids * to have a window where the umask is set to 0 -- meaning @@ -764,7 +779,7 @@ PP(pp_umask) /* Only DIE if trying to restrict permissions on "user" (self). * Otherwise it's harmless and more useful to just return undef * since 'group' and 'other' concepts probably don't exist here. */ - if (MAXARG >= 1 && (POPi & 0700)) + if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700)) DIE(aTHX_ "umask not implemented"); XPUSHs(&PL_sv_undef); #endif @@ -851,6 +866,13 @@ PP(pp_tie) break; case SVt_PVAV: methname = "TIEARRAY"; + if (!AvREAL(varsv)) { + if (!AvREIFY(varsv)) + Perl_croak(aTHX_ "Cannot tie unreifiable array"); + av_clear((AV *)varsv); + AvREIFY_off(varsv); + AvREAL_on(varsv); + } break; case SVt_PVGV: case SVt_PVLV: @@ -887,10 +909,8 @@ PP(pp_tie) * 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); - stash = gv_stashpvn(name, len, 0); - if (!stash || !(gv = gv_fetchmethod(stash, methname))) { + stash = gv_stashsv(*MARK, 0); + if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); } @@ -973,10 +993,7 @@ PP(pp_tied) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { - SV *osv = SvTIED_obj(sv, mg); - if (osv == mg->mg_obj) - osv = sv_mortalcopy(osv); - PUSHs(osv); + PUSHs(SvTIED_obj(sv, mg)); RETURN; } RETPUSHUNDEF; @@ -1009,7 +1026,10 @@ PP(pp_dbmopen) if (SvIV(right)) mPUSHu(O_RDWR|O_CREAT); else + { mPUSHu(O_RDWR); + if (!SvOK(right)) right = &PL_sv_no; + } PUSHs(right); PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); @@ -1039,10 +1059,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; @@ -1066,6 +1086,7 @@ PP(pp_sselect) SP -= 4; for (i = 1; i <= 3; i++) { SV * const sv = SP[i]; + SvGETMAGIC(sv); if (!SvOK(sv)) continue; if (SvREADONLY(sv)) { @@ -1075,8 +1096,10 @@ PP(pp_sselect) Perl_croak_no_modify(aTHX); } if (!SvPOK(sv)) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); - SvPV_force_nolen(sv); /* force string conversion */ + if (!SvPOKp(sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Non-string passed as bitmask"); + SvPV_force_nomg_nolen(sv); /* force string conversion */ } j = SvCUR(sv); if (maxlen < j) @@ -1213,7 +1236,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; } @@ -1224,21 +1248,20 @@ PP(pp_select) HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; GV * egv = GvEGVx(PL_defoutgv); + GV * const *gvp; if (!egv) egv = PL_defoutgv; hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL; - if (! hv) - XPUSHs(&PL_sv_undef); - else { - GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); - if (gvp && *gvp == egv) { + gvp = hv && HvENAME(hv) + ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE) + : NULL; + if (gvp && *gvp == egv) { gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); XPUSHTARG; - } - else { + } + else { mXPUSHs(newRV(MUTABLE_SV(egv))); - } } if (newdefout) { @@ -1253,7 +1276,8 @@ PP(pp_select) PP(pp_getc) { dVAR; dSP; dTARGET; - GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs); + GV * const gv = + MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); if (MAXARG == 0) @@ -1298,7 +1322,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; @@ -1311,8 +1335,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); @@ -1322,8 +1350,8 @@ PP(pp_enterwrite) { dVAR; dSP; - register GV *gv; - register IO *io; + GV *gv; + IO *io; GV *fgv; CV *cv = NULL; SV *tmpsv = NULL; @@ -1346,35 +1374,28 @@ PP(pp_enterwrite) else fgv = gv; - if (!fgv) - goto not_a_format_reference; + assert(fgv); cv = GvFORM(fgv); if (!cv) { - const char *name; tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); - name = SvPV_nolen_const(tmpsv); - if (name && *name) - DIE(aTHX_ "Undefined format \"%s\" called", name); - - 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))) @@ -1395,7 +1416,8 @@ PP(pp_leavewrite) SV *topname; if (!IoFMT_NAME(io)) IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv))); + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP", + HEKfARG(GvNAME_HEK(gv)))); topgv = gv_fetchsv(topname, 0, SVt_PVFM); if ((topgv && GvFORM(topgv)) || !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM)) @@ -1442,13 +1464,8 @@ PP(pp_leavewrite) cv = GvFORM(fgv); if (!cv) { SV * const sv = sv_newmortal(); - const char *name; gv_efullname4(sv, fgv, NULL, FALSE); - name = SvPV_nolen_const(sv); - if (name && *name) - DIE(aTHX_ "Undefined top format \"%s\" called", name); - else - DIE(aTHX_ "Undefined top format called"); + DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); } return doform(cv, gv, PL_op); } @@ -1457,11 +1474,11 @@ PP(pp_leavewrite) POPBLOCK(cx,PL_curpm); POPFORMAT(cx); retop = cx->blk_sub.retop; + 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); @@ -1482,12 +1499,9 @@ 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) @@ -1555,7 +1569,7 @@ PP(pp_sysopen) { dVAR; dSP; - const int perm = (MAXARG > 3) ? POPi : 0666; + const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; SV * const sv = POPs; GV * const gv = MUTABLE_GV(POPs); @@ -1577,12 +1591,12 @@ PP(pp_sysopen) PP(pp_sysread) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; - int offset; + SSize_t offset; IO *io; char *buffer; + STRLEN orig_size; SSize_t length; SSize_t count; - Sock_size_t bufsize; SV *bufsv; STRLEN blen; int fp_utf8; @@ -1612,6 +1626,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); @@ -1633,16 +1649,23 @@ 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)) { + /* offset adjust in characters not bytes */ + /* SV's length cache is only safe for non-magical values */ + if (SvGMAGICAL(bufsv)) + blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen); + else + blen = sv_len_utf8(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__) bufsize = sizeof (struct sockaddr_in); @@ -1681,32 +1704,28 @@ 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 > (int)blen) + if (-offset > (SSize_t)blen) DIE(aTHX_ "Offset outside string"); offset += blen; } 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; } more_bytes: - bufsize = SvCUR(bufsv); + orig_size = SvCUR(bufsv); /* Allocating length + offset + 1 isn't perfect in the case of reading bytes from a byte file handle into a UTF8 buffer, but it won't harm us unduly. (should be 2 * length + offset + 1, or possibly something longer if PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); - if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ - Zero(buffer+bufsize, offset-bufsize, char); + if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */ + Zero(buffer+orig_size, offset-orig_size, char); } buffer = buffer + offset; if (!buffer_utf8) { @@ -1740,6 +1759,7 @@ 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); @@ -2090,7 +2110,7 @@ PP(pp_tell) GV *gv; IO *io; - if (MAXARG != 0) + if (MAXARG != 0 && (TOPs || POPs)) PL_last_in_gv = MUTABLE_GV(POPs); else EXTEND(SP, 1); @@ -2186,14 +2206,14 @@ PP(pp_truncate) /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); { + SV * const sv = POPs; int result = 1; GV *tmpgv; IO *io; - if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO); - - do_ftruncate_gv: + 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; @@ -2215,24 +2235,12 @@ PP(pp_truncate) } } } - else { - SV * const sv = POPs; - const char *name; - - if (isGV_with_GP(sv)) { - tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */ - goto do_ftruncate_gv; - } - else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { - tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */ - goto do_ftruncate_gv; - } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */ goto do_ftruncate_io; - } - - name = SvPV_nolen_const(sv); + } + else { + const char * const name = SvPV_nomg_const_nolen(sv); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) @@ -2340,7 +2348,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; @@ -2372,7 +2380,7 @@ 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) { @@ -2420,8 +2428,8 @@ PP(pp_sockpair) const int domain = POPi; 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; + IO * const io1 = gv1 ? GvIOn(gv1) : NULL; + IO * const io2 = gv2 ? GvIOn(gv2) : NULL; int fd[2]; if (!io1) @@ -2475,7 +2483,7 @@ 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; @@ -2503,7 +2511,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; @@ -2522,8 +2530,8 @@ 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__) Sock_size_t len = sizeof (struct sockaddr_in); @@ -2598,7 +2606,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; @@ -2620,7 +2628,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; @@ -2689,7 +2697,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; @@ -2751,66 +2759,68 @@ PP(pp_stat) dVAR; dSP; GV *gv = NULL; - IO *io; + IO *io = NULL; I32 gimme; I32 max = 13; + SV* sv; - if (PL_op->op_flags & OPf_REF) { - gv = cGVOP_gv; + if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1) + : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) { if (PL_op->op_type == OP_LSTAT) { if (gv != PL_defgv) { do_fstat_warning_check: Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); + "lstat() on filehandle%s%"SVf, + gv ? " " : "", + SVfARG(gv + ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) + : &PL_sv_no)); } else if (PL_laststype != OP_LSTAT) + /* diag_listed_as: The stat preceding %s wasn't an lstat */ Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } - do_fstat: 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; } } else { - SV* const sv = POPs; - if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - goto do_fstat; - } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) { - gv = MUTABLE_GV(SvRV(sv)); - if (PL_op->op_type == OP_LSTAT) - goto do_fstat_warning_check; - goto do_fstat; - } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; goto do_fstat_have_io; } - sv_setpv(PL_statname, SvPV_nolen_const(sv)); + 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; if (PL_op->op_type == OP_LSTAT) @@ -2834,7 +2844,15 @@ PP(pp_stat) EXTEND(SP, max); EXTEND_MORTAL(max); mPUSHi(PL_statcache.st_dev); +#if ST_INO_SIZE > IVSIZE + mPUSHn(PL_statcache.st_ino); +#else +# if ST_INO_SIGN <= 0 mPUSHi(PL_statcache.st_ino); +# else + mPUSHu(PL_statcache.st_ino); +# endif +#endif mPUSHu(PL_statcache.st_mode); mPUSHu(PL_statcache.st_nlink); #if Uid_t_size > IVSIZE @@ -2885,23 +2903,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)) \ - && 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 ((PL_op->op_flags & OPf_KIDS) - && SvAMAGIC(TOPs)) + if (SvAMAGIC(arg)) { const char tmpchr = chr; SV * const tmpsv = amagic_call(arg, @@ -2909,33 +2973,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; @@ -2959,7 +3005,6 @@ PP(pp_ftrread) bool effective = FALSE; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTRREAD: opchar = 'R'; break; @@ -2971,8 +3016,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)) @@ -3025,7 +3068,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); @@ -3042,20 +3085,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) @@ -3064,7 +3106,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; @@ -3075,14 +3116,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. */ @@ -3090,23 +3128,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) @@ -3114,7 +3157,6 @@ PP(pp_ftrowned) dVAR; I32 result; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTROWNED: opchar = 'O'; break; @@ -3132,215 +3174,185 @@ 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'); 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; - SV *tmpsv = NULL; char *name = NULL; STRLEN namelen; tryAMAGICftest_MG('t'); - STACKED_FTEST_CHECK; - if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV_with_GP(TOPs)) - gv = MUTABLE_GV(POPs); - else if (SvROK(TOPs) && isGV(SvRV(TOPs))) - gv = MUTABLE_GV(SvRV(POPs)); else { - 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); + } } if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (tmpsv && SvOK(tmpsv)) { - if (isDIGIT(*name)) + else if (name && isDIGIT(*name)) fd = atoi(name); - else - RETPUSHUNDEF; - } 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; I32 odd = 0; STDCHAR tbuf[512]; - register STDCHAR *s; - register IO *io; - register SV *sv; + 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; - else if (isGV_with_GP(TOPs)) - gv = MUTABLE_GV(POPs); - else if (SvROK(TOPs) && isGV(SvRV(TOPs))) - gv = MUTABLE_GV(SvRV(POPs)); - else - gv = NULL; + else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) + == OPpFT_STACKED) + gv = PL_defgv; + else { + sv = *PL_stack_sp; + gv = MAYBE_DEREF_GV_nomg(sv); + } if (gv) { - EXTEND(SP, 1); if (gv == PL_defgv) { if (PL_statgv) - io = GvIO(PL_statgv); + io = SvTYPE(PL_statgv) == SVt_PVIO + ? (IO *)PL_statgv + : GvIO(PL_statgv); else { - sv = PL_statname; goto really_filename; } } else { PL_statgv = gv; - PL_laststatval = -1; sv_setpvs(PL_statname, ""); io = GvIO(PL_statgv); } + PL_laststatval = -1; + PL_laststype = OP_STAT; if (io && IoIFP(io)) { if (! PerlIO_has_base(IoIFP(io))) 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)); @@ -3348,7 +3360,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 */ @@ -3356,35 +3368,39 @@ PP(pp_fttext) len = 512; } else { - report_evil_fh(cGVOP_gv); SETERRNO(EBADF,RMS_IFI); - RETPUSHUNDEF; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; } } else { - sv = POPs; + sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); really_filename: PL_statgv = NULL; - PL_laststype = OP_STAT; - sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); 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')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); - RETPUSHUNDEF; + 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; } @@ -3438,9 +3454,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. */ @@ -3456,15 +3472,8 @@ PP(pp_chdir) if (PL_op->op_flags & OPf_SPECIAL) { gv = gv_fetchsv(sv, 0, SVt_PVIO); } - else if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - } - else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { - gv = MUTABLE_GV(SvRV(sv)); - } - else { - tmps = SvPV_nolen_const(sv); - } + else if (!(gv = MAYBE_DEREF_GV(sv))) + tmps = SvPV_nomg_const_nolen(sv); } if( !gv && (!tmps || !*tmps) ) { @@ -3561,7 +3570,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); @@ -3763,7 +3772,7 @@ PP(pp_mkdir) STRLEN len; const char *tmps; bool copy = FALSE; - const int mode = (MAXARG > 1) ? POPi : 0777; + const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777; TRIMSLASHES(tmps,len,copy); @@ -3811,15 +3820,15 @@ 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; if ((IoIFP(io) || IoOFP(io))) Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening filehandle %s also as a directory", - GvENAME(gv)); + "Opening filehandle %"HEKf" also as a directory", + HEKfARG(GvENAME_HEK(gv)) ); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) @@ -3849,12 +3858,13 @@ 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), - "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); + "readdir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -3901,11 +3911,12 @@ 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), - "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); + "telldir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -3926,11 +3937,12 @@ 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), - "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); + "seekdir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } (void)PerlDir_seek(IoDIRP(io), along); @@ -3950,11 +3962,12 @@ 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), - "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); + "rewinddir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } (void)PerlDir_rewind(IoDIRP(io)); @@ -3973,11 +3986,12 @@ 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), - "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); + "closedir() attempted on invalid dirhandle %"HEKf, + HEKfARG(GvENAME_HEK(gv))); goto nope; } #ifdef VOID_CLOSEDIR @@ -4007,16 +4021,34 @@ PP(pp_fork) #ifdef HAS_FORK dVAR; dSP; dTARGET; Pid_t childpid; +#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO) + sigset_t oldmask, newmask; +#endif EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; +#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO) + 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; + } +#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO) + { + dSAVE_ERRNO; + sigprocmask(SIG_SETMASK, &oldmask, NULL); + RESTORE_ERRNO; + } +#endif if (childpid < 0) RETSETUNDEF; 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 @@ -4126,9 +4158,17 @@ PP(pp_system) Pid_t childpid; int pp[2]; I32 did_pipes = 0; +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigset_t newset, oldset; +#endif if (PerlProc_pipe(pp) >= 0) did_pipes = 1; +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigemptyset(&newset); + sigaddset(&newset, SIGCHLD); + sigprocmask(SIG_BLOCK, &newset, &oldset); +#endif while ((childpid = PerlProc_fork()) == -1) { if (errno != EAGAIN) { value = -1; @@ -4138,6 +4178,9 @@ PP(pp_system) PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); } +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif RETURN; } sleep(5); @@ -4156,6 +4199,9 @@ PP(pp_system) result = wait4pid(childpid, &status, 0); } while (result == -1 && errno == EINTR); #ifndef PERL_MICRO +#ifdef HAS_SIGPROCMASK + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); #endif @@ -4178,7 +4224,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); } @@ -4186,6 +4232,9 @@ PP(pp_system) XPUSHi(STATUS_CURRENT); RETURN; } +#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)) + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif if (did_pipes) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) @@ -4290,14 +4339,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"); @@ -4309,7 +4351,8 @@ PP(pp_getpgrp) #ifdef HAS_GETPGRP dVAR; dSP; dTARGET; Pid_t pgrp; - const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs); + const Pid_t pid = + (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); @@ -4331,15 +4374,12 @@ PP(pp_setpgrp) dVAR; dSP; dTARGET; Pid_t pgrp; Pid_t pid; - if (MAXARG < 2) { - pgrp = 0; + pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; + if (MAXARG > 0) pid = TOPs && TOPi; + else { pid = 0; XPUSHi(-1); } - else { - pgrp = POPi; - pid = TOPi; - } TAINT_PROPER("setpgrp"); #ifdef BSD_SETPGRP @@ -4468,7 +4508,7 @@ PP(pp_gmtime) {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; - if (MAXARG < 1) { + if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) { time_t now; (void)time(&now); when = (Time64_T)now; @@ -4477,17 +4517,20 @@ PP(pp_gmtime) NV input = Perl_floor(POPn); when = (Time64_T)input; if (when != input) { + /* diag_listed_as: gmtime(%f) too large */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too large", opname, input); } } if ( TIME_LOWER_BOUND > when ) { + /* diag_listed_as: gmtime(%f) too small */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too small", opname, when); err = NULL; } else if( when > TIME_UPPER_BOUND ) { + /* diag_listed_as: gmtime(%f) too small */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too large", opname, when); err = NULL; @@ -4568,7 +4611,7 @@ PP(pp_sleep) Time_t when; (void)time(&lasttime); - if (MAXARG < 1) + if (MAXARG < 1 || (!TOPs && !POPs)) PerlProc_pause(); else { duration = POPi; @@ -4679,8 +4722,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); @@ -4769,7 +4812,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); @@ -4842,7 +4885,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); @@ -4902,7 +4945,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); @@ -5079,7 +5122,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. @@ -5403,10 +5446,10 @@ 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) { while (++MARK <= SP) { @@ -5462,30 +5505,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); @@ -5620,8 +5639,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: */