X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f1f66076265cc2bac3adabd54c01b0dea28ca3f0..9f4a55d4a28d81a94e54fa1913ec5c7affbce6fe:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 91b9d77..f57bd1a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -13,6 +13,8 @@ * cloven by a great fissure, out of which the red glare came, now leaping * up, now dying down into darkness; and all the while far below there was * a rumour and a trouble as of great engines throbbing and labouring. + * + * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"] */ /* This file contains system pp ("push/pop") functions that @@ -27,6 +29,8 @@ #include "EXTERN.h" #define PERL_IN_PP_SYS_C #include "perl.h" +#include "time64.h" +#include "time64.c" #ifdef I_SHADOW /* Shadow password support for solaris - pdo@cs.umd.edu @@ -199,15 +203,6 @@ void endservent(void); #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ -/* AIX 5.2 and below use mktime for localtime, and defines the edge case - * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64 - * available in the 32bit environment, which could warrant Configure - * checks in the future. - */ -#ifdef _AIX -#define LOCALTIME_EDGECASE_BROKEN -#endif - /* F_OK unused: if stat() cannot find it... */ #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) @@ -247,7 +242,6 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) const Gid_t egid = getegid(); int res; - LOCK_CRED_MUTEX; #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) Perl_croak(aTHX_ "switching effective uid is not implemented"); #else @@ -293,7 +287,6 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #endif #endif Perl_croak(aTHX_ "leaving effective gid failed"); - UNLOCK_CRED_MUTEX; return res; } @@ -325,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); } @@ -371,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) { @@ -396,7 +389,7 @@ PP(pp_glob) #endif /* !DOSISH */ result = do_readline(); - LEAVE; + LEAVE_with_name("glob"); return result; } @@ -410,100 +403,92 @@ 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)); + else if (SvPOK(ERRSV) && SvCUR(ERRSV)) { + exsv = sv_mortalcopy(ERRSV); + sv_catpvs(exsv, "\t...propagated"); + } + else { + exsv = newSVpvs_flags("Died", SVs_TEMP); + } + die_sv(exsv); + RETURN; } /* I/O. */ @@ -528,9 +513,10 @@ PP(pp_open) MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED)) - Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening dirhandle %s also as a file", GvENAME(gv)); + if (IoDIRP(io)) + Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), + "Opening dirhandle %s also as a file", + GvENAME(gv)); mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { @@ -539,9 +525,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; } @@ -579,9 +565,9 @@ PP(pp_close) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_CLOSE"); call_method("CLOSE", G_SCALAR); - LEAVE; + LEAVE_with_name("call_CLOSE"); SPAGAIN; RETURN; } @@ -648,6 +634,7 @@ badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); + return NORMAL; #endif } @@ -669,9 +656,9 @@ PP(pp_fileno) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_FILENO"); call_method("FILENO", G_SCALAR); - LEAVE; + LEAVE_with_name("call_FILENO"); SPAGAIN; RETURN; } @@ -744,9 +731,9 @@ PP(pp_binmode) if (discp) XPUSHs(discp); PUTBACK; - ENTER; + ENTER_with_name("call_BINMODE"); call_method("BINMODE", G_SCALAR); - LEAVE; + LEAVE_with_name("call_BINMODE"); SPAGAIN; RETURN; } @@ -789,7 +776,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; @@ -807,11 +794,6 @@ PP(pp_tie) break; case SVt_PVGV: if (isGV_with_GP(varsv)) { -#ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((const GV *)varsv)) { - Perl_croak(aTHX_ "Attempt to tie unique GV"); - } -#endif methname = "TIEHANDLE"; how = PERL_MAGIC_tiedscalar; /* For tied filehandles, we apply tiedscalar magic to the IO @@ -829,7 +811,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); @@ -849,7 +831,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); @@ -872,7 +854,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; @@ -899,15 +881,15 @@ PP(pp_untie) XPUSHs(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 && ckWARN(WARN_UNTIE)) { - Perl_warner(aTHX_ packWARN(WARN_UNTIE), - "untie attempted while %"UVuf" inner references still exist", - (UV)SvREFCNT(obj) - 1 ) ; + else if (mg && SvREFCNT(obj) > 1) { + Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE), + "untie attempted while %"UVuf" inner references still exist", + (UV)SvREFCNT(obj) - 1 ) ; } } } @@ -942,7 +924,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); @@ -1030,8 +1012,7 @@ PP(pp_sselect) DIE(aTHX_ "%s", PL_no_modify); } if (!SvPOK(sv)) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); SvPV_force_nolen(sv); /* force string conversion */ } j = SvCUR(sv); @@ -1151,16 +1132,27 @@ PP(pp_sselect) RETURN; #else DIE(aTHX_ "select not implemented"); + return NORMAL; #endif } +/* +=for apidoc setdefout + +Sets PL_defoutgv, the default file handle for output, to the passed in +typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference +count of the passed in typeglob is increased by one, and the reference count +of the typeglob that PL_defoutgv points to is decreased by one. + +=cut +*/ + void 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 +1161,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 { @@ -1270,8 +1262,8 @@ 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) gv = PL_defoutgv; @@ -1418,8 +1410,7 @@ PP(pp_leavewrite) } else { if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { - if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow"); + Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow"); } if (!do_print(PL_formtarget, fp)) PUSHs(&PL_sv_no); @@ -1810,9 +1801,8 @@ PP(pp_send) SV *sv; if (MARK == SP - 1) { - EXTEND(SP, 1000); - sv = sv_2mortal(newSViv(sv_len(*SP))); - PUSHs(sv); + sv = *SP; + mXPUSHi(sv_len(sv)); PUTBACK; } @@ -1921,7 +1911,7 @@ PP(pp_send) DIE(aTHX_ "Offset outside string"); } offset += blen_chars; - } else if (offset >= (IV)blen_chars && blen_chars > 0) { + } else if (offset > (IV)blen_chars) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } @@ -2012,51 +2002,60 @@ PP(pp_eof) { dVAR; dSP; GV *gv; + IO *io; + MAGIC *mg; - if (MAXARG == 0) { - if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ - IO *io; - gv = PL_last_in_gv = GvEGV(PL_argvgv); - io = GvIO(gv); - if (io && !IoIFP(io)) { - if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { - IoLINES(io) = 0; - IoFLAGS(io) &= ~IOf_START; - do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); - if ( GvSV(gv) ) { - sv_setpvs(GvSV(gv), "-"); - } - else { - GvSV(gv) = newSVpvs("-"); - } - SvSETMAGIC(GvSV(gv)); - } - else if (!nextargv(gv)) - RETPUSHYES; - } - } + 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 = GvEGVx(PL_argvgv); /* eof() - ARGV magic */ + else + gv = PL_last_in_gv; /* eof */ + + 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 - gv = PL_last_in_gv; /* eof */ + mPUSHi(0); /* 0 = eof - simple, implicit FH */ + PUTBACK; + ENTER; + call_method("EOF", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; } - else - gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */ - if (gv) { - IO * const io = GvIO(gv); - MAGIC * mg; - if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - PUTBACK; - ENTER; - call_method("EOF", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ + if (io && !IoIFP(io)) { + if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { + IoLINES(io) = 0; + IoFLAGS(io) &= ~IOf_START; + do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); + if (GvSV(gv)) + sv_setpvs(GvSV(gv), "-"); + else + GvSV(gv) = newSVpvs("-"); + SvSETMAGIC(GvSV(gv)); + } + else if (!nextargv(gv)) + RETPUSHYES; } } - PUSHs(boolSV(!gv || do_eof(gv))); + PUSHs(boolSV(do_eof(gv))); RETURN; } @@ -2083,6 +2082,12 @@ PP(pp_tell) RETURN; } } + else if (!gv) { + if (!errno) + SETERRNO(EBADF,RMS_IFI); + PUSHi(-1); + RETURN; + } #if LSEEKSIZE > IVSIZE PUSHn( do_tell(gv) ); @@ -2346,6 +2351,7 @@ PP(pp_flock) RETURN; #else DIE(aTHX_ PL_no_func, "flock()"); + return NORMAL; #endif } @@ -2398,6 +2404,7 @@ PP(pp_socket) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); + return NORMAL; #endif } @@ -2459,6 +2466,7 @@ PP(pp_sockpair) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socketpair"); + return NORMAL; #endif } @@ -2490,6 +2498,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); + return NORMAL; #endif } @@ -2520,6 +2529,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); + return NORMAL; #endif } @@ -2546,6 +2556,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); + return NORMAL; #endif } @@ -2625,6 +2636,7 @@ badexit: #else DIE(aTHX_ PL_no_sock_func, "accept"); + return NORMAL; #endif } @@ -2649,6 +2661,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); + return NORMAL; #endif } @@ -2726,6 +2739,7 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -2790,6 +2804,7 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -2809,9 +2824,8 @@ PP(pp_stat) if (PL_op->op_type == OP_LSTAT) { if (gv != PL_defgv) { do_fstat_warning_check: - if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); } else if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } @@ -2967,8 +2981,19 @@ PP(pp_ftrread) int stat_mode = S_IRUSR; bool effective = FALSE; + char opchar = '?'; dSP; + switch (PL_op->op_type) { + case OP_FTRREAD: opchar = 'R'; break; + case OP_FTRWRITE: opchar = 'W'; break; + case OP_FTREXEC: opchar = 'X'; break; + case OP_FTEREAD: opchar = 'r'; break; + case OP_FTEWRITE: opchar = 'w'; break; + case OP_FTEEXEC: opchar = 'x'; break; + } + tryAMAGICftest(opchar); + STACKED_FTEST_CHECK; switch (PL_op->op_type) { @@ -3001,7 +3026,7 @@ PP(pp_ftrread) access_mode = W_OK; #endif stat_mode = S_IWUSR; - /* Fall through */ + /* fall through */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS @@ -3061,8 +3086,20 @@ PP(pp_ftis) dVAR; I32 result; const int op_type = PL_op->op_type; + char opchar = '?'; dSP; + + switch (op_type) { + case OP_FTIS: opchar = 'e'; break; + case OP_FTSIZE: opchar = 's'; break; + case OP_FTMTIME: opchar = 'M'; break; + case OP_FTCTIME: opchar = 'C'; break; + case OP_FTATIME: opchar = 'A'; break; + } + tryAMAGICftest(opchar); + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) @@ -3099,8 +3136,25 @@ PP(pp_ftrowned) { dVAR; I32 result; + char opchar = '?'; dSP; + switch (PL_op->op_type) { + case OP_FTROWNED: opchar = 'O'; break; + case OP_FTEOWNED: opchar = 'o'; break; + case OP_FTZERO: opchar = 'z'; break; + case OP_FTSOCK: opchar = 'S'; break; + case OP_FTCHR: opchar = 'c'; break; + case OP_FTBLK: opchar = 'b'; break; + case OP_FTFILE: opchar = 'f'; break; + case OP_FTDIR: opchar = 'd'; break; + case OP_FTPIPE: opchar = 'p'; break; + case OP_FTSUID: opchar = 'u'; break; + case OP_FTSGID: opchar = 'g'; break; + case OP_FTSVTX: opchar = 'k'; break; + } + tryAMAGICftest(opchar); + /* I believe that all these three are likely to be defined on most every system these days. */ #ifndef S_ISUID @@ -3117,6 +3171,7 @@ PP(pp_ftrowned) #endif STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) @@ -3183,8 +3238,13 @@ PP(pp_ftrowned) PP(pp_ftlink) { dVAR; - I32 result = my_lstat(); dSP; + I32 result; + + tryAMAGICftest('l'); + result = my_lstat(); + SPAGAIN; + if (result < 0) RETPUSHUNDEF; if (S_ISLNK(PL_statcache.st_mode)) @@ -3200,6 +3260,8 @@ PP(pp_fttty) GV *gv; SV *tmpsv = NULL; + tryAMAGICftest('t'); + STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) @@ -3249,6 +3311,8 @@ PP(pp_fttext) GV *gv; PerlIO *fp; + tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); + STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) @@ -3495,6 +3559,7 @@ PP(pp_chroot) RETURN; #else DIE(aTHX_ PL_no_func, "chroot"); + return NORMAL; #endif } @@ -3569,6 +3634,7 @@ PP(pp_link) { /* Have neither. */ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; } #endif @@ -3768,9 +3834,10 @@ PP(pp_open_dir) if (!io) goto nope; - if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED)) - Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening filehandle %s also as a directory", GvENAME(gv)); + if ((IoIFP(io) || IoOFP(io))) + Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), + "Opening filehandle %s also as a directory", + GvENAME(gv)); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) @@ -3783,6 +3850,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); + return NORMAL; #endif } @@ -3790,6 +3858,7 @@ 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 *); @@ -3804,10 +3873,8 @@ PP(pp_readdir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } @@ -3857,10 +3924,8 @@ PP(pp_telldir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } @@ -3872,6 +3937,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); + return NORMAL; #endif } @@ -3884,10 +3950,8 @@ PP(pp_seekdir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } (void)PerlDir_seek(IoDIRP(io), along); @@ -3899,6 +3963,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); + return NORMAL; #endif } @@ -3910,10 +3975,8 @@ PP(pp_rewinddir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } (void)PerlDir_rewind(IoDIRP(io)); @@ -3924,6 +3987,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); + return NORMAL; #endif } @@ -3935,10 +3999,8 @@ PP(pp_closedir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } #ifdef VOID_CLOSEDIR @@ -3958,6 +4020,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); + return NORMAL; #endif } @@ -4004,13 +4067,14 @@ PP(pp_fork) RETURN; # else DIE(aTHX_ PL_no_func, "fork"); + return NORMAL; # endif #endif } PP(pp_wait) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) dVAR; dSP; dTARGET; Pid_t childpid; int argflags; @@ -4033,12 +4097,13 @@ PP(pp_wait) RETURN; #else DIE(aTHX_ PL_no_func, "wait"); + return NORMAL; #endif } PP(pp_waitpid) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) dVAR; dSP; dTARGET; const int optype = POPi; const Pid_t pid = TOPi; @@ -4063,6 +4128,7 @@ PP(pp_waitpid) RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); + return NORMAL; #endif } @@ -4268,6 +4334,7 @@ PP(pp_getppid) RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); + return NORMAL; #endif } @@ -4289,6 +4356,7 @@ PP(pp_getpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "getpgrp()"); + return NORMAL; #endif } @@ -4301,6 +4369,7 @@ PP(pp_setpgrp) if (MAXARG < 2) { pgrp = 0; pid = 0; + XPUSHi(-1); } else { pgrp = POPi; @@ -4321,6 +4390,7 @@ PP(pp_setpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "setpgrp()"); + return NORMAL; #endif } @@ -4334,6 +4404,7 @@ PP(pp_getpriority) RETURN; #else DIE(aTHX_ PL_no_func, "getpriority()"); + return NORMAL; #endif } @@ -4349,6 +4420,7 @@ PP(pp_setpriority) RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); + return NORMAL; #endif } @@ -4399,108 +4471,106 @@ PP(pp_tms) RETURN; # else DIE(aTHX_ "times not implemented"); + return NORMAL; # endif #endif /* HAS_TIMES */ } -#ifdef LOCALTIME_EDGECASE_BROKEN -static struct tm *S_my_localtime (pTHX_ Time_t *tp) -{ - auto time_t T; - auto struct tm *P; - - /* No workarounds in the valid range */ - if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000) - return (localtime (tp)); - - /* This edge case is to workaround the undefined behaviour, where the - * TIMEZONE makes the time go beyond the defined range. - * gmtime (0x7fffffff) => 2038-01-19 03:14:07 - * If there is a negative offset in TZ, like MET-1METDST, some broken - * implementations of localtime () (like AIX 5.2) barf with bogus - * return values: - * 0x7fffffff gmtime 2038-01-19 03:14:07 - * 0x7fffffff localtime 1901-12-13 21:45:51 - * 0x7fffffff mylocaltime 2038-01-19 04:14:07 - * 0x3c19137f gmtime 2001-12-13 20:45:51 - * 0x3c19137f localtime 2001-12-13 21:45:51 - * 0x3c19137f mylocaltime 2001-12-13 21:45:51 - * Given that legal timezones are typically between GMT-12 and GMT+12 - * we turn back the clock 23 hours before calling the localtime - * function, and add those to the return value. This will never cause - * day wrapping problems, since the edge case is Tue Jan *19* - */ - T = *tp - 82800; /* 23 hour. allows up to GMT-23 */ - P = localtime (&T); - P->tm_hour += 23; - if (P->tm_hour >= 24) { - P->tm_hour -= 24; - P->tm_mday++; /* 18 -> 19 */ - P->tm_wday++; /* Mon -> Tue */ - P->tm_yday++; /* 18 -> 19 */ - } - return (P); -} /* S_my_localtime */ -#endif +/* 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; dSP; - Time_t when; - const struct tm *tmbuf; + Time64_T when; + struct TM tmbuf; + struct TM *err; + const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime"; static const char * const dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; static const char * const monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; - if (MAXARG < 1) - (void)time(&when); - else -#ifdef BIG_TIME - when = (Time_t)SvNVx(POPs); -#else - when = (Time_t)SvIVx(POPs); -#endif + if (MAXARG < 1) { + time_t now; + (void)time(&now); + when = (Time64_T)now; + } + else { + double input = Perl_floor(POPn); + when = (Time64_T)input; + if (when != input) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) too large", opname, input); + } + } - if (PL_op->op_type == OP_LOCALTIME) -#ifdef LOCALTIME_EDGECASE_BROKEN - tmbuf = S_my_localtime(aTHX_ &when); -#else - tmbuf = localtime(&when); -#endif - else - tmbuf = gmtime(&when); + if ( TIME_LOWER_BOUND > when ) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) too small", opname, when); + err = NULL; + } + else if( when > TIME_UPPER_BOUND ) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) 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 (GIMME != G_ARRAY) { + if (err == NULL) { + /* XXX %lld broken for quads */ + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) failed", opname, (double)when); + } + + if (GIMME != G_ARRAY) { /* scalar context */ SV *tsv; + /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */ + double year = (double)tmbuf.tm_year + 1900; + EXTEND(SP, 1); EXTEND_MORTAL(1); - if (!tmbuf) + if (err == NULL) RETPUSHUNDEF; - tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d", - dayname[tmbuf->tm_wday], - monname[tmbuf->tm_mon], - tmbuf->tm_mday, - tmbuf->tm_hour, - tmbuf->tm_min, - tmbuf->tm_sec, - tmbuf->tm_year + 1900); + + tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", + dayname[tmbuf.tm_wday], + monname[tmbuf.tm_mon], + tmbuf.tm_mday, + tmbuf.tm_hour, + tmbuf.tm_min, + tmbuf.tm_sec, + year); mPUSHs(tsv); } - else if (tmbuf) { + else { /* list context */ + if ( err == NULL ) + RETURN; + EXTEND(SP, 9); EXTEND_MORTAL(9); - mPUSHi(tmbuf->tm_sec); - mPUSHi(tmbuf->tm_min); - mPUSHi(tmbuf->tm_hour); - mPUSHi(tmbuf->tm_mday); - mPUSHi(tmbuf->tm_mon); - mPUSHi(tmbuf->tm_year); - mPUSHi(tmbuf->tm_wday); - mPUSHi(tmbuf->tm_yday); - mPUSHi(tmbuf->tm_isdst); + mPUSHi(tmbuf.tm_sec); + mPUSHi(tmbuf.tm_min); + mPUSHi(tmbuf.tm_hour); + mPUSHi(tmbuf.tm_mday); + mPUSHi(tmbuf.tm_mon); + mPUSHn(tmbuf.tm_year); + mPUSHi(tmbuf.tm_wday); + mPUSHi(tmbuf.tm_yday); + mPUSHi(tmbuf.tm_isdst); } RETURN; } @@ -4519,6 +4589,7 @@ PP(pp_alarm) RETURN; #else DIE(aTHX_ PL_no_func, "alarm"); + return NORMAL; #endif } @@ -4588,6 +4659,7 @@ PP(pp_semget) RETURN; #else DIE(aTHX_ "System V IPC is not implemented on this machine"); + return NORMAL; #endif } @@ -4648,7 +4720,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); @@ -4723,6 +4795,7 @@ PP(pp_ghostent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "gethostent"); + return NORMAL; #endif } @@ -4796,6 +4869,7 @@ PP(pp_gnetent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getnetent"); + return NORMAL; #endif } @@ -4856,6 +4930,7 @@ PP(pp_gprotoent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); + return NORMAL; #endif } @@ -4931,6 +5006,7 @@ PP(pp_gservent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getservent"); + return NORMAL; #endif } @@ -4942,6 +5018,7 @@ PP(pp_shostent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "sethostent"); + return NORMAL; #endif } @@ -4953,6 +5030,7 @@ PP(pp_snetent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setnetent"); + return NORMAL; #endif } @@ -4964,6 +5042,7 @@ PP(pp_sprotoent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setprotoent"); + return NORMAL; #endif } @@ -4975,6 +5054,7 @@ PP(pp_sservent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setservent"); + return NORMAL; #endif } @@ -4987,6 +5067,7 @@ PP(pp_ehostent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endhostent"); + return NORMAL; #endif } @@ -4999,6 +5080,7 @@ PP(pp_enetent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endnetent"); + return NORMAL; #endif } @@ -5011,6 +5093,7 @@ PP(pp_eprotoent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endprotoent"); + return NORMAL; #endif } @@ -5023,6 +5106,7 @@ PP(pp_eservent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endservent"); + return NORMAL; #endif } @@ -5165,13 +5249,13 @@ PP(pp_gpwent) * has a different API than the Solaris/IRIX one. */ # if defined(HAS_GETSPNAM) && !defined(_AIX) { - const int saverrno = errno; + dSAVE_ERRNO; const struct spwd * const spwent = getspnam(pwent->pw_name); /* Save and restore errno so that * underprivileged attempts seem * to have never made the unsccessful * attempt to retrieve the shadow password. */ - errno = saverrno; + RESTORE_ERRNO; if (spwent && spwent->sp_pwdp) sv_setpv(sv, spwent->sp_pwdp); } @@ -5256,6 +5340,7 @@ PP(pp_gpwent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -5267,6 +5352,7 @@ PP(pp_spwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); + return NORMAL; #endif } @@ -5278,6 +5364,7 @@ PP(pp_epwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); + return NORMAL; #endif } @@ -5310,7 +5397,11 @@ PP(pp_ggrent) PUSHs(sv); if (grent) { if (which == OP_GGRNAM) +#if Gid_t_sign <= 0 sv_setiv(sv, (IV)grent->gr_gid); +#else + sv_setuv(sv, (UV)grent->gr_gid); +#endif else sv_setpv(sv, grent->gr_name); } @@ -5326,7 +5417,11 @@ PP(pp_ggrent) PUSHs(sv_mortalcopy(&PL_sv_no)); #endif +#if Gid_t_sign <= 0 mPUSHi(grent->gr_gid); +#else + mPUSHu(grent->gr_gid); +#endif #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API)) /* In UNICOS/mk (_CRAYMPP) the multithreading @@ -5344,6 +5439,7 @@ PP(pp_ggrent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -5355,6 +5451,7 @@ PP(pp_sgrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setgrent"); + return NORMAL; #endif } @@ -5366,6 +5463,7 @@ PP(pp_egrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endgrent"); + return NORMAL; #endif } @@ -5381,6 +5479,7 @@ PP(pp_getlogin) RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); + return NORMAL; #endif } @@ -5479,6 +5578,7 @@ PP(pp_syscall) RETURN; #else DIE(aTHX_ PL_no_func, "syscall"); + return NORMAL; #endif } @@ -5491,6 +5591,7 @@ PP(pp_syscall) static int fcntl_emulate_flock(int fd, int operation) { + int res; struct flock flock; switch (operation & ~LOCK_NB) { @@ -5510,7 +5611,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 */ @@ -5549,15 +5653,15 @@ static int lockf_emulate_flock(int fd, int operation) { int i; - const int save_errno = errno; Off_t pos; + dSAVE_ERRNO; /* flock locks entire file so for lockf we need to do the same */ pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ if (pos > 0) /* is seekable and needs to be repositioned */ if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) pos = -1; /* seek failed, so don't seek back afterwards */ - errno = save_errno; + RESTORE_ERRNO; switch (operation) {