X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bb4c52e023e0fcade469e46e9a1d5245ff44f3f2..7850f4d6b732ab5f426cd3bcd9757c70a46cfda1:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 8a82573..695199a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -318,13 +318,13 @@ PP(pp_backtick) NOOP; } else if (gimme == G_SCALAR) { - ENTER; + ENTER_with_name("backtick"); SAVESPTR(PL_rs); PL_rs = &PL_sv_undef; sv_setpvs(TARG, ""); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) NOOP; - LEAVE; + LEAVE_with_name("backtick"); XPUSHs(TARG); SvTAINTED_on(TARG); } @@ -364,7 +364,7 @@ PP(pp_glob) * without at the same time croaking, for some reason, or if * perl was built with PERL_EXTERNAL_GLOB */ - ENTER; + ENTER_with_name("glob"); #ifndef VMS if (PL_tainting) { @@ -389,7 +389,7 @@ PP(pp_glob) #endif /* !DOSISH */ result = do_readline(); - LEAVE; + LEAVE_with_name("glob"); return result; } @@ -403,101 +403,91 @@ PP(pp_rcatline) PP(pp_warn) { dVAR; dSP; dMARK; - SV *tmpsv; - const char *tmps; + SV *exsv; + const char *pv; STRLEN len; if (SP - MARK > 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); - tmpsv = TARG; + exsv = TARG; SP = MARK + 1; } else if (SP == MARK) { - tmpsv = &PL_sv_no; + exsv = &PL_sv_no; EXTEND(SP, 1); SP = MARK + 1; } else { - tmpsv = TOPs; + exsv = TOPs; } - tmps = SvPV_const(tmpsv, len); - if ((!tmps || !len) && PL_errgv) { - SV * const error = ERRSV; - SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpvs(error, "\t...caught"); - tmpsv = error; - tmps = SvPV_const(tmpsv, len); - } - if (!tmps || !len) - tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); - Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv)); + if (SvROK(exsv) || (pv = 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 { + exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); + } + warn_sv(exsv); RETSETYES; } PP(pp_die) { dVAR; dSP; dMARK; - const char *tmps; - SV *tmpsv; + SV *exsv; + const char *pv; STRLEN len; - bool multiarg = 0; #ifdef VMS VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); #endif if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); - tmpsv = TARG; - tmps = SvPV_const(tmpsv, len); - multiarg = 1; + exsv = TARG; SP = MARK + 1; } else { - tmpsv = TOPs; - tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len); - } - if (!tmps || !len) { - SV * const error = ERRSV; - SvUPGRADE(error, SVt_PV); - if (multiarg ? SvROK(error) : SvROK(tmpsv)) { - if (!multiarg) - SvSetSV(error,tmpsv); - else if (sv_isobject(error)) { - HV * const stash = SvSTASH(SvRV(error)); - 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(error); - PUSHs(file); - PUSHs(line); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), - G_SCALAR|G_EVAL|G_KEEPERR); - sv_setsv(error,*PL_stack_sp--); - } + exsv = TOPs; + } + + if (SvROK(exsv) || (pv = 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--); } - DIE(aTHX_ NULL); - } - else { - if (SvPOK(error) && SvCUR(error)) - sv_catpvs(error, "\t...propagated"); - tmpsv = error; - if (SvOK(tmpsv)) - tmps = SvPV_const(tmpsv, len); - else - tmps = NULL; } } - if (!tmps || !len) - tmpsv = newSVpvs_flags("Died", SVs_TEMP); - - DIE(aTHX_ "%"SVf, SVfARG(tmpsv)); - RETURN; + 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); } /* I/O. */ @@ -515,7 +505,7 @@ PP(pp_open) GV * const gv = MUTABLE_GV(*++MARK); - if (!isGV(gv)) + if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv))) DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) { @@ -534,9 +524,9 @@ PP(pp_open) *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_OPEN"); call_method("OPEN", G_SCALAR); - LEAVE; + LEAVE_with_name("call_OPEN"); SPAGAIN; RETURN; } @@ -561,28 +551,71 @@ PP(pp_open) RETURN; } +/* These are private to this function, which is private to this file. + Use 0x04 rather than the next available bit, to help the compiler if the + architecture can generate more efficient instructions. */ +#define MORTALIZE_NOT_NEEDED 0x04 +#define TIED_HANDLE_ARGC_SHIFT 3 + +static OP * +S_tied_handle_method(pTHX_ const char *const methname, SV **sp, + IO *const io, MAGIC *const mg, const U32 flags, ...) +{ + U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT; + + PERL_ARGS_ASSERT_TIED_HANDLE_METHOD; + + /* Ensure that our flag bits do not overlap. */ + assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0); + assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0); + + PUSHMARK(sp); + PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); + if (argc) { + const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED; + va_list args; + va_start(args, flags); + do { + SV *const arg = va_arg(args, SV *); + if(mortalize_not_needed) + PUSHs(arg); + else + mPUSHs(arg); + } while (--argc); + va_end(args); + } + + PUTBACK; + ENTER_with_name("call_tied_handle_method"); + call_method(methname, flags & G_WANT); + LEAVE_with_name("call_tied_handle_method"); + return NORMAL; +} + +#define tied_handle_method(a,b,c,d) \ + S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR) +#define tied_handle_method1(a,b,c,d,e) \ + S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e) +#define tied_handle_method2(a,b,c,d,e,f) \ + S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f) + PP(pp_close) { dVAR; dSP; GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs); + if (MAXARG == 0) + EXTEND(SP, 1); + if (gv) { IO * const io = GvIO(gv); if (io) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER; - call_method("CLOSE", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + return tied_handle_method("CLOSE", SP, io, mg); } } } - EXTEND(SP, 1); PUSHs(boolSV(do_close(gv, TRUE))); RETURN; } @@ -661,14 +694,7 @@ PP(pp_fileno) if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER; - call_method("FILENO", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + return tied_handle_method("FILENO", SP, io, mg); } if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) { @@ -734,20 +760,18 @@ PP(pp_binmode) if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - if (discp) - XPUSHs(discp); - PUTBACK; - ENTER; - call_method("BINMODE", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + /* This takes advantage of the implementation of the varargs + function, which I don't think that the optimiser will be able to + figure out. Although, as it's a static function, in theory it + could. */ + return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg, + G_SCALAR|MORTALIZE_NOT_NEEDED + | (discp + ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0), + discp); } } - EXTEND(SP, 1); if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); @@ -784,7 +808,7 @@ PP(pp_tie) { dVAR; dSP; dMARK; HV* stash; - GV *gv; + GV *gv = NULL; SV *sv; const I32 markoff = MARK - PL_stack_base; const char *methname; @@ -801,6 +825,7 @@ PP(pp_tie) methname = "TIEARRAY"; break; case SVt_PVGV: + case SVt_PVLV: if (isGV_with_GP(varsv)) { methname = "TIEHANDLE"; how = PERL_MAGIC_tiedscalar; @@ -819,7 +844,7 @@ PP(pp_tie) } items = SP - MARK++; if (sv_isobject(*MARK)) { /* Calls GET magic. */ - ENTER; + ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,(I32)items); @@ -829,8 +854,10 @@ PP(pp_tie) call_method(methname, G_SCALAR); } else { - /* Not clear why we don't call call_method here too. - * perhaps to get different error message ? + /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO" + * will attempt to invoke IO::File::TIEARRAY, with (best case) the + * wrong error message, and worse case, supreme action at a distance. + * (Sorry obfuscation writers. You're not going to be given this one.) */ STRLEN len; const char *name = SvPV_nomg_const(*MARK, len); @@ -839,7 +866,7 @@ PP(pp_tie) DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); } - ENTER; + ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,(I32)items); @@ -862,7 +889,7 @@ PP(pp_tie) "Self-ties of arrays and hashes are not supported"); sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0); } - LEAVE; + LEAVE_with_name("call_TIE"); SP = PL_stack_base + markoff; PUSHs(sv); RETURN; @@ -886,12 +913,12 @@ PP(pp_untie) CV *cv; if (gv && isGV(gv) && (cv = GvCV(gv))) { PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); + PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); mXPUSHi(SvREFCNT(obj) - 1); PUTBACK; - ENTER; + ENTER_with_name("call_UNTIE"); call_sv(MUTABLE_SV(cv), G_VOID); - LEAVE; + LEAVE_with_name("call_UNTIE"); SPAGAIN; } else if (mg && SvREFCNT(obj) > 1) { @@ -914,7 +941,7 @@ PP(pp_tied) const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) + if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { @@ -932,7 +959,7 @@ PP(pp_dbmopen) dVAR; dSP; dPOPPOPssrl; HV* stash; - GV *gv; + GV *gv = NULL; HV * const hv = MUTABLE_HV(POPs); SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP); @@ -1017,7 +1044,7 @@ PP(pp_sselect) if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0)) - DIE(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(aTHX); } if (!SvPOK(sv)) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); @@ -1159,8 +1186,7 @@ Perl_setdefout(pTHX_ GV *gv) { dVAR; SvREFCNT_inc_simple_void(gv); - if (PL_defoutgv) - SvREFCNT_dec(PL_defoutgv); + SvREFCNT_dec(PL_defoutgv); PL_defoutgv = gv; } @@ -1169,11 +1195,11 @@ PP(pp_select) dVAR; dSP; dTARGET; HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; - GV * egv = GvEGV(PL_defoutgv); + GV * egv = GvEGVx(PL_defoutgv); if (!egv) egv = PL_defoutgv; - hv = GvSTASH(egv); + hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL; if (! hv) XPUSHs(&PL_sv_undef); else { @@ -1202,20 +1228,19 @@ PP(pp_getc) IO *io = NULL; GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs); + if (MAXARG == 0) + EXTEND(SP, 1); + if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - const I32 gimme = GIMME_V; - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER; - call_method("GETC", gimme); - LEAVE; - SPAGAIN; - if (gimme == G_SCALAR) + const U32 gimme = GIMME_V; + S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme); + if (gimme == G_SCALAR) { + SPAGAIN; SvSetMagicSV_nosteal(TARG, TOPs); - RETURN; + } + return NORMAL; } } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ @@ -1251,6 +1276,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PERL_ARGS_ASSERT_DOFORM; + if (cv && CvCLONE(cv)) + cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); + ENTER; SAVETMPS; @@ -1270,17 +1298,18 @@ PP(pp_enterwrite) register GV *gv; register IO *io; GV *fgv; - CV *cv; - SV * tmpsv = NULL; + CV *cv = NULL; + SV *tmpsv = NULL; - if (MAXARG == 0) + if (MAXARG == 0) { gv = PL_defoutgv; + EXTEND(SP, 1); + } else { gv = MUTABLE_GV(POPs); if (!gv) gv = PL_defoutgv; } - EXTEND(SP, 1); io = GvIO(gv); if (!io) { RETPUSHNO; @@ -1305,9 +1334,6 @@ PP(pp_enterwrite) not_a_format_reference: DIE(aTHX_ "Not a format reference"); } - if (CvCLONE(cv)) - cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); - IoFLAGS(io) &= ~IOf_DIDTOP; return doform(cv,gv,PL_op->op_next); } @@ -1322,6 +1348,7 @@ PP(pp_leavewrite) SV **newsp; I32 gimme; register PERL_CONTEXT *cx; + OP *retop; if (!io || !(ofp = IoOFP(io))) goto forget_top; @@ -1396,14 +1423,13 @@ PP(pp_leavewrite) else DIE(aTHX_ "Undefined top format called"); } - if (cv && CvCLONE(cv)) - cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); return doform(cv, gv, PL_op); } forget_top: POPBLOCK(cx,PL_curpm); POPFORMAT(cx); + retop = cx->blk_sub.retop; LEAVE; fp = IoOFP(io); @@ -1436,7 +1462,7 @@ PP(pp_leavewrite) PUTBACK; PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); - return cx->blk_sub.retop; + return retop; } PP(pp_prtf) @@ -1629,6 +1655,9 @@ PP(pp_sysread) (struct sockaddr *)namebuf, &bufsize); if (count < 0) RETPUSHUNDEF; + /* MSG_TRUNC can give oversized count; quietly lose it */ + if (count > length) + count = length; #ifdef EPOC /* Bogus return without padding */ bufsize = sizeof (struct sockaddr_in); @@ -2012,38 +2041,40 @@ PP(pp_eof) GV *gv; IO *io; MAGIC *mg; + /* + * in Perl 5.12 and later, the additional parameter is a bitmask: + * 0 = eof + * 1 = eof(FH) + * 2 = eof() <- ARGV magic + * + * I'll rely on the compiler's trace flow analysis to decide whether to + * actually assign this out here, or punt it into the only block where it is + * used. Doing it out here is DRY on the condition logic. + */ + unsigned int which; - if (MAXARG) + if (MAXARG) { gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */ - else if (PL_op->op_flags & OPf_SPECIAL) - gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */ - else - gv = PL_last_in_gv; /* eof */ + which = 1; + } + else { + EXTEND(SP, 1); + + if (PL_op->op_flags & OPf_SPECIAL) { + gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */ + which = 2; + } + else { + gv = PL_last_in_gv; /* eof */ + which = 0; + } + } if (!gv) RETPUSHNO; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - /* - * in Perl 5.12 and later, the additional paramter is a bitmask: - * 0 = eof - * 1 = eof(FH) - * 2 = eof() <- ARGV magic - */ - if (MAXARG) - mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */ - else if (PL_op->op_flags & OPf_SPECIAL) - mPUSHi(2); /* 2 = eof() - ARGV magic */ - else - mPUSHi(0); /* 0 = eof - simple, implicit FH */ - PUTBACK; - ENTER; - call_method("EOF", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + return tied_handle_method1("EOF", SP, io, mg, newSVuv(which)); } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ @@ -2075,19 +2106,14 @@ PP(pp_tell) if (MAXARG != 0) PL_last_in_gv = MUTABLE_GV(POPs); + else + EXTEND(SP, 1); gv = PL_last_in_gv; if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER; - call_method("TELL", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + return tied_handle_method("TELL", SP, io, mg); } } else if (!gv) { @@ -2121,20 +2147,14 @@ PP(pp_sysseek) if (gv && (io = GvIO(gv))) { MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); #if LSEEKSIZE > IVSIZE - mXPUSHn((NV) offset); + SV *const offset_sv = newSVnv((NV) offset); #else - mXPUSHi(offset); + SV *const offset_sv = newSViv(offset); #endif - mXPUSHi(whence); - PUTBACK; - ENTER; - call_method("SEEK", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + + return tied_handle_method2("SEEK", SP, io, mg, offset_sv, + newSViv(whence)); } } @@ -2948,6 +2968,53 @@ PP(pp_stat) RETURN; } +#define tryAMAGICftest_MG(chr) STMT_START { \ + if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \ + && S_try_amagic_ftest(aTHX_ chr)) \ + return NORMAL; \ + } STMT_END + +STATIC bool +S_try_amagic_ftest(pTHX_ char chr) { + dVAR; + dSP; + SV* const arg = TOPs; + + assert(chr != '?'); + SvGETMAGIC(arg); + + if ((PL_op->op_flags & OPf_KIDS) + && SvAMAGIC(TOPs)) + { + const char tmpchr = chr; + const OP *next; + SV * const tmpsv = amagic_call(arg, + newSVpvn_flags(&tmpchr, 1, SVs_TEMP), + ftest_amg, AMGf_unary); + + if (!tmpsv) + return FALSE; + + SPAGAIN; + + next = PL_op->op_next; + if (next->op_type >= OP_FTRREAD && + next->op_type <= OP_FTBINARY && + next->op_private & OPpFT_STACKED + ) { + if (SvTRUE(tmpsv)) + /* leave the object alone */ + return TRUE; + } + + SETs(tmpsv); + PUTBACK; + return TRUE; + } + return FALSE; +} + + /* 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 @@ -2990,7 +3057,7 @@ PP(pp_ftrread) case OP_FTEWRITE: opchar = 'w'; break; case OP_FTEEXEC: opchar = 'x'; break; } - tryAMAGICftest(opchar); + tryAMAGICftest_MG(opchar); STACKED_FTEST_CHECK; @@ -3070,7 +3137,7 @@ PP(pp_ftrread) #endif } - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3094,11 +3161,11 @@ PP(pp_ftis) case OP_FTCTIME: opchar = 'C'; break; case OP_FTATIME: opchar = 'A'; break; } - tryAMAGICftest(opchar); + tryAMAGICftest_MG(opchar); STACKED_FTEST_CHECK; - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3151,26 +3218,35 @@ PP(pp_ftrowned) case OP_FTSGID: opchar = 'g'; break; case OP_FTSVTX: opchar = 'k'; break; } - tryAMAGICftest(opchar); + tryAMAGICftest_MG(opchar); + + STACKED_FTEST_CHECK; /* I believe that all these three are likely to be defined on most every system these days. */ #ifndef S_ISUID - if(PL_op->op_type == OP_FTSUID) + if(PL_op->op_type == OP_FTSUID) { + if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + (void) POPs; RETPUSHNO; + } #endif #ifndef S_ISGID - if(PL_op->op_type == OP_FTSGID) + if(PL_op->op_type == OP_FTSGID) { + if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + (void) POPs; RETPUSHNO; + } #endif #ifndef S_ISVTX - if(PL_op->op_type == OP_FTSVTX) + if(PL_op->op_type == OP_FTSVTX) { + if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0) + (void) POPs; RETPUSHNO; + } #endif - STACKED_FTEST_CHECK; - - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3239,8 +3315,8 @@ PP(pp_ftlink) dSP; I32 result; - tryAMAGICftest('l'); - result = my_lstat(); + tryAMAGICftest_MG('l'); + result = my_lstat_flags(0); SPAGAIN; if (result < 0) @@ -3257,26 +3333,30 @@ PP(pp_fttty) int fd; GV *gv; SV *tmpsv = NULL; + char *name = NULL; + STRLEN namelen; - tryAMAGICftest('t'); + tryAMAGICftest_MG('t'); STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV(TOPs)) + else if (isGV_with_GP(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); - else - gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO); + else { + tmpsv = POPs; + name = SvPV_nomg(tmpsv, namelen); + gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); + } if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (tmpsv && SvOK(tmpsv)) { - const char *tmps = SvPV_nolen_const(tmpsv); - if (isDIGIT(*tmps)) - fd = atoi(tmps); + if (isDIGIT(*name)) + fd = atoi(name); else RETPUSHUNDEF; } @@ -3309,13 +3389,13 @@ PP(pp_fttext) GV *gv; PerlIO *fp; - tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); + 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(TOPs)) + else if (isGV_with_GP(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); @@ -3377,7 +3457,7 @@ PP(pp_fttext) really_filename: PL_statgv = NULL; PL_laststype = OP_STAT; - sv_setpv(PL_statname, SvPV_nolen_const(sv)); + sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) @@ -3649,7 +3729,6 @@ PP(pp_readlink) #endif tmps = POPpconstx; len = readlink(tmps, buf, sizeof(buf) - 1); - EXTEND(SP, 1); if (len < 0) RETPUSHUNDEF; PUSHp(buf, len); @@ -4378,13 +4457,19 @@ PP(pp_setpgrp) #endif } +#ifdef __GLIBC__ +# define PRIORITY_WHICH_T(which) (__priority_which_t)which +#else +# define PRIORITY_WHICH_T(which) which +#endif + PP(pp_getpriority) { #ifdef HAS_GETPRIORITY dVAR; dSP; dTARGET; const int who = POPi; const int which = TOPi; - SETi( getpriority(which, who) ); + SETi( getpriority(PRIORITY_WHICH_T(which), who) ); RETURN; #else DIE(aTHX_ PL_no_func, "getpriority()"); @@ -4399,13 +4484,15 @@ PP(pp_setpriority) const int who = POPi; const int which = TOPi; TAINT_PROPER("setpriority"); - SETi( setpriority(which, who, niceval) >= 0 ); + SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); #endif } +#undef PRIORITY_WHICH_T + /* Time calls. */ PP(pp_time) @@ -4457,6 +4544,15 @@ PP(pp_tms) #endif /* HAS_TIMES */ } +/* The 32 bit int year limits the times we can represent to these + boundaries with a few days wiggle room to account for time zone + offsets +*/ +/* Sat Jan 3 00:00:00 -2147481748 */ +#define TIME_LOWER_BOUND -67768100567755200.0 +/* Sun Dec 29 12:00:00 2147483647 */ +#define TIME_UPPER_BOUND 67767976233316800.0 + PP(pp_gmtime) { dVAR; @@ -4477,23 +4573,35 @@ PP(pp_gmtime) when = (Time64_T)now; } else { - double input = Perl_floor(POPn); + NV input = Perl_floor(POPn); when = (Time64_T)input; if (when != input) { Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0f) too large", opname, input); + "%s(%.0" NVff ") too large", opname, input); } } - if (PL_op->op_type == OP_LOCALTIME) - err = S_localtime64_r(&when, &tmbuf); - else - err = S_gmtime64_r(&when, &tmbuf); + if ( TIME_LOWER_BOUND > when ) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0" NVff ") too small", opname, when); + err = NULL; + } + else if( when > TIME_UPPER_BOUND ) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0" NVff ") too large", opname, when); + err = NULL; + } + else { + if (PL_op->op_type == OP_LOCALTIME) + err = S_localtime64_r(&when, &tmbuf); + else + err = S_gmtime64_r(&when, &tmbuf); + } if (err == NULL) { /* XXX %lld broken for quads */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0f) failed", opname, (double)when); + "%s(%.0" NVff ") failed", opname, when); } if (GIMME != G_ARRAY) { /* scalar context */ @@ -4542,7 +4650,6 @@ PP(pp_alarm) int anum; anum = POPi; anum = alarm((unsigned int)anum); - EXTEND(SP, 1); if (anum < 0) RETPUSHUNDEF; PUSHi(anum); @@ -4678,7 +4785,7 @@ PP(pp_ghostent) struct hostent *gethostbyname(Netdb_name_t); struct hostent *gethostent(void); #endif - struct hostent *hent; + struct hostent *hent = NULL; unsigned long len; EXTEND(SP, 10); @@ -5415,7 +5522,8 @@ PP(pp_getlogin) EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) RETPUSHUNDEF; - PUSHp(tmps, strlen(tmps)); + sv_setpv_mg(TARG, tmps); + PUSHs(TARG); RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); @@ -5529,6 +5637,7 @@ PP(pp_syscall) static int fcntl_emulate_flock(int fd, int operation) { + int res; struct flock flock; switch (operation & ~LOCK_NB) { @@ -5548,7 +5657,10 @@ fcntl_emulate_flock(int fd, int operation) flock.l_whence = SEEK_SET; flock.l_start = flock.l_len = (Off_t)0; - return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); + res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); + if (res == -1 && ((errno == EAGAIN) || (errno == EACCES))) + errno = EWOULDBLOCK; + return res; } #endif /* FCNTL_EMULATE_FLOCK */