X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fd9e8b45c89ee5d36539a3655dae7737fb78c21e..92d234245893f4c155fc0cf044826a030195c3ba:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index bea4b7d..1bc072d 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -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; - } - 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); + exsv = TOPs; } - 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. */ @@ -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_with_name("call_CLOSE"); - call_method("CLOSE", G_SCALAR); - LEAVE_with_name("call_CLOSE"); - SPAGAIN; - RETURN; + return tied_handle_method("CLOSE", SP, io, mg); } } } - EXTEND(SP, 1); PUSHs(boolSV(do_close(gv, TRUE))); RETURN; } @@ -643,7 +676,6 @@ badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); - return NORMAL; #endif } @@ -662,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_with_name("call_FILENO"); - call_method("FILENO", G_SCALAR); - LEAVE_with_name("call_FILENO"); - SPAGAIN; - RETURN; + return tied_handle_method("FILENO", SP, io, mg); } if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) { @@ -735,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_with_name("call_BINMODE"); - call_method("BINMODE", G_SCALAR); - LEAVE_with_name("call_BINMODE"); - 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); @@ -785,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; @@ -830,8 +853,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); @@ -887,7 +912,7 @@ 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_with_name("call_UNTIE"); @@ -933,7 +958,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); @@ -1018,7 +1043,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"); @@ -1141,7 +1166,6 @@ PP(pp_sselect) RETURN; #else DIE(aTHX_ "select not implemented"); - return NORMAL; #endif } @@ -1170,11 +1194,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 { @@ -1203,20 +1227,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 */ @@ -1252,6 +1275,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; @@ -1271,17 +1297,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; @@ -1306,9 +1333,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); } @@ -1397,8 +1421,6 @@ 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); } @@ -2013,38 +2035,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() */ @@ -2076,19 +2100,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) { @@ -2122,20 +2141,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)); } } @@ -2360,7 +2373,6 @@ PP(pp_flock) RETURN; #else DIE(aTHX_ PL_no_func, "flock()"); - return NORMAL; #endif } @@ -2413,7 +2425,6 @@ PP(pp_socket) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); - return NORMAL; #endif } @@ -2475,7 +2486,6 @@ PP(pp_sockpair) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socketpair"); - return NORMAL; #endif } @@ -2507,7 +2517,6 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); - return NORMAL; #endif } @@ -2538,7 +2547,6 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); - return NORMAL; #endif } @@ -2565,7 +2573,6 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); - return NORMAL; #endif } @@ -2645,7 +2652,6 @@ badexit: #else DIE(aTHX_ PL_no_sock_func, "accept"); - return NORMAL; #endif } @@ -2670,7 +2676,6 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); - return NORMAL; #endif } @@ -2748,7 +2753,6 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -2813,7 +2817,6 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -2959,6 +2962,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 @@ -3001,7 +3051,7 @@ PP(pp_ftrread) case OP_FTEWRITE: opchar = 'w'; break; case OP_FTEEXEC: opchar = 'x'; break; } - tryAMAGICftest(opchar); + tryAMAGICftest_MG(opchar); STACKED_FTEST_CHECK; @@ -3081,7 +3131,7 @@ PP(pp_ftrread) #endif } - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3105,11 +3155,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; @@ -3162,26 +3212,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; @@ -3250,8 +3309,8 @@ PP(pp_ftlink) dSP; I32 result; - tryAMAGICftest('l'); - result = my_lstat(); + tryAMAGICftest_MG('l'); + result = my_lstat_flags(0); SPAGAIN; if (result < 0) @@ -3268,8 +3327,10 @@ PP(pp_fttty) int fd; GV *gv; SV *tmpsv = NULL; + char *name = NULL; + STRLEN namelen; - tryAMAGICftest('t'); + tryAMAGICftest_MG('t'); STACKED_FTEST_CHECK; @@ -3279,15 +3340,17 @@ PP(pp_fttty) 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; } @@ -3320,7 +3383,7 @@ 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; @@ -3388,7 +3451,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')) @@ -3568,7 +3631,6 @@ PP(pp_chroot) RETURN; #else DIE(aTHX_ PL_no_func, "chroot"); - return NORMAL; #endif } @@ -3643,7 +3705,6 @@ PP(pp_link) { /* Have neither. */ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); - return NORMAL; } #endif @@ -3662,7 +3723,6 @@ PP(pp_readlink) #endif tmps = POPpconstx; len = readlink(tmps, buf, sizeof(buf) - 1); - EXTEND(SP, 1); if (len < 0) RETPUSHUNDEF; PUSHp(buf, len); @@ -3859,7 +3919,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); - return NORMAL; #endif } @@ -3867,7 +3926,6 @@ PP(pp_readdir) { #if !defined(Direntry_t) || !defined(HAS_READDIR) DIE(aTHX_ PL_no_dir_func, "readdir"); - return NORMAL; #else #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); @@ -3946,7 +4004,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); - return NORMAL; #endif } @@ -3972,7 +4029,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); - return NORMAL; #endif } @@ -3996,7 +4052,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); - return NORMAL; #endif } @@ -4029,7 +4084,6 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); - return NORMAL; #endif } @@ -4076,7 +4130,6 @@ PP(pp_fork) RETURN; # else DIE(aTHX_ PL_no_func, "fork"); - return NORMAL; # endif #endif } @@ -4106,7 +4159,6 @@ PP(pp_wait) RETURN; #else DIE(aTHX_ PL_no_func, "wait"); - return NORMAL; #endif } @@ -4137,7 +4189,6 @@ PP(pp_waitpid) RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); - return NORMAL; #endif } @@ -4343,7 +4394,6 @@ PP(pp_getppid) RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); - return NORMAL; #endif } @@ -4365,7 +4415,6 @@ PP(pp_getpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "getpgrp()"); - return NORMAL; #endif } @@ -4399,21 +4448,25 @@ PP(pp_setpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "setpgrp()"); - return NORMAL; #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()"); - return NORMAL; #endif } @@ -4425,14 +4478,15 @@ PP(pp_setpriority) const int who = POPi; const int which = TOPi; TAINT_PROPER("setpriority"); - SETi( setpriority(which, who, niceval) >= 0 ); + SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); - return NORMAL; #endif } +#undef PRIORITY_WHICH_T + /* Time calls. */ PP(pp_time) @@ -4480,11 +4534,19 @@ PP(pp_tms) RETURN; # else DIE(aTHX_ "times not implemented"); - return NORMAL; # endif #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; @@ -4505,23 +4567,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 */ @@ -4570,14 +4644,12 @@ PP(pp_alarm) int anum; anum = POPi; anum = alarm((unsigned int)anum); - EXTEND(SP, 1); if (anum < 0) RETPUSHUNDEF; PUSHi(anum); RETURN; #else DIE(aTHX_ PL_no_func, "alarm"); - return NORMAL; #endif } @@ -4647,7 +4719,6 @@ PP(pp_semget) RETURN; #else DIE(aTHX_ "System V IPC is not implemented on this machine"); - return NORMAL; #endif } @@ -4708,7 +4779,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); @@ -4783,7 +4854,6 @@ PP(pp_ghostent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "gethostent"); - return NORMAL; #endif } @@ -4857,7 +4927,6 @@ PP(pp_gnetent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getnetent"); - return NORMAL; #endif } @@ -4918,7 +4987,6 @@ PP(pp_gprotoent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); - return NORMAL; #endif } @@ -4994,7 +5062,6 @@ PP(pp_gservent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getservent"); - return NORMAL; #endif } @@ -5006,7 +5073,6 @@ PP(pp_shostent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "sethostent"); - return NORMAL; #endif } @@ -5018,7 +5084,6 @@ PP(pp_snetent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setnetent"); - return NORMAL; #endif } @@ -5030,7 +5095,6 @@ PP(pp_sprotoent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setprotoent"); - return NORMAL; #endif } @@ -5042,7 +5106,6 @@ PP(pp_sservent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setservent"); - return NORMAL; #endif } @@ -5055,7 +5118,6 @@ PP(pp_ehostent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endhostent"); - return NORMAL; #endif } @@ -5068,7 +5130,6 @@ PP(pp_enetent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endnetent"); - return NORMAL; #endif } @@ -5081,7 +5142,6 @@ PP(pp_eprotoent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endprotoent"); - return NORMAL; #endif } @@ -5094,7 +5154,6 @@ PP(pp_eservent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endservent"); - return NORMAL; #endif } @@ -5328,7 +5387,6 @@ PP(pp_gpwent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -5340,7 +5398,6 @@ PP(pp_spwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); - return NORMAL; #endif } @@ -5352,7 +5409,6 @@ PP(pp_epwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); - return NORMAL; #endif } @@ -5427,7 +5483,6 @@ PP(pp_ggrent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); - return NORMAL; #endif } @@ -5439,7 +5494,6 @@ PP(pp_sgrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setgrent"); - return NORMAL; #endif } @@ -5451,7 +5505,6 @@ PP(pp_egrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endgrent"); - return NORMAL; #endif } @@ -5467,7 +5520,6 @@ PP(pp_getlogin) RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); - return NORMAL; #endif } @@ -5566,7 +5618,6 @@ PP(pp_syscall) RETURN; #else DIE(aTHX_ PL_no_func, "syscall"); - return NORMAL; #endif }