X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2ad48547234bdf521daff432b65a0b173efd2a19..88621eaff54e5f5ea9adea13440d1750968643a6:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 7767764..b233942 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -363,7 +363,7 @@ PP(pp_glob) * 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: @@ -438,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)); @@ -500,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"); } @@ -660,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); @@ -1050,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; @@ -1227,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; } @@ -1312,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; @@ -1325,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); @@ -1336,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; @@ -1360,33 +1374,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))) @@ -1456,10 +1465,7 @@ PP(pp_leavewrite) 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); } @@ -1468,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); @@ -1493,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) @@ -1623,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); @@ -1644,13 +1649,19 @@ 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) { @@ -1693,10 +1704,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 +1711,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; @@ -2204,9 +2211,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 +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; @@ -2373,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) { @@ -2421,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) @@ -2476,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; @@ -2504,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; @@ -2523,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); @@ -2599,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; @@ -2621,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; @@ -2690,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; @@ -2752,7 +2759,7 @@ PP(pp_stat) dVAR; dSP; GV *gv = NULL; - IO *io; + IO *io = NULL; I32 gimme; I32 max = 13; SV* sv; @@ -2774,28 +2781,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 +2816,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; @@ -2893,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)) \ - && 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 +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; @@ -2967,7 +3005,6 @@ PP(pp_ftrread) bool effective = FALSE; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTRREAD: opchar = 'R'; break; @@ -2979,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)) @@ -3033,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); @@ -3050,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) @@ -3072,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; @@ -3083,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. */ @@ -3098,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) @@ -3122,7 +3157,6 @@ PP(pp_ftrowned) dVAR; I32 result; char opchar = '?'; - dSP; switch (PL_op->op_type) { case OP_FTROWNED: opchar = 'O'; break; @@ -3140,117 +3174,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 +3279,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 +3294,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; 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 +3347,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 +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 */ @@ -3362,32 +3371,36 @@ PP(pp_fttext) 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')) 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; } @@ -3441,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. */ @@ -3557,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); @@ -3807,7 +3820,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; @@ -3845,8 +3858,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), @@ -3898,7 +3911,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), @@ -3924,7 +3937,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), @@ -3949,7 +3962,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), @@ -3973,7 +3986,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), @@ -4008,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 @@ -4193,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); } @@ -4308,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"); @@ -4698,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); @@ -4788,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); @@ -4861,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); @@ -4921,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); @@ -5098,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. @@ -5422,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) { @@ -5481,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); @@ -5639,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: */