X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a2a5de9516c1b256b060768ac6dad252a3aa3be7..9f4a55d4a28d81a94e54fa1913ec5c7affbce6fe:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 4c00651..f57bd1a 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,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. */ @@ -522,8 +514,9 @@ PP(pp_open) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; if (IoDIRP(io)) - Perl_ck_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening dirhandle %s also as a file", GvENAME(gv)); + 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) { @@ -532,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; } @@ -572,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; } @@ -641,6 +634,7 @@ badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); + return NORMAL; #endif } @@ -662,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; } @@ -737,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; } @@ -782,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; @@ -817,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); @@ -837,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); @@ -860,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; @@ -887,9 +881,9 @@ 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) { @@ -930,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); @@ -1138,6 +1132,7 @@ PP(pp_sselect) RETURN; #else DIE(aTHX_ "select not implemented"); + return NORMAL; #endif } @@ -1157,8 +1152,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; } @@ -1167,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 { @@ -1268,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; @@ -1917,7 +1911,7 @@ PP(pp_send) DIE(aTHX_ "Offset outside string"); } offset += blen_chars; - } else if (offset >= (IV)blen_chars) { + } else if (offset > (IV)blen_chars) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } @@ -2014,7 +2008,7 @@ PP(pp_eof) 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 */ + gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */ else gv = PL_last_in_gv; /* eof */ @@ -2357,6 +2351,7 @@ PP(pp_flock) RETURN; #else DIE(aTHX_ PL_no_func, "flock()"); + return NORMAL; #endif } @@ -2409,6 +2404,7 @@ PP(pp_socket) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socket"); + return NORMAL; #endif } @@ -2470,6 +2466,7 @@ PP(pp_sockpair) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "socketpair"); + return NORMAL; #endif } @@ -2501,6 +2498,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); + return NORMAL; #endif } @@ -2531,6 +2529,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); + return NORMAL; #endif } @@ -2557,6 +2556,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); + return NORMAL; #endif } @@ -2636,6 +2636,7 @@ badexit: #else DIE(aTHX_ PL_no_sock_func, "accept"); + return NORMAL; #endif } @@ -2660,6 +2661,7 @@ nuts: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); + return NORMAL; #endif } @@ -2737,6 +2739,7 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -2801,6 +2804,7 @@ nuts2: #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -3555,6 +3559,7 @@ PP(pp_chroot) RETURN; #else DIE(aTHX_ PL_no_func, "chroot"); + return NORMAL; #endif } @@ -3629,6 +3634,7 @@ PP(pp_link) { /* Have neither. */ DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; } #endif @@ -3829,8 +3835,9 @@ PP(pp_open_dir) goto nope; if ((IoIFP(io) || IoOFP(io))) - Perl_ck_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening filehandle %s also as a directory", GvENAME(gv)); + 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))) @@ -3843,6 +3850,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); + return NORMAL; #endif } @@ -3850,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 *); @@ -3928,6 +3937,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); + return NORMAL; #endif } @@ -3953,6 +3963,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); + return NORMAL; #endif } @@ -3976,6 +3987,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); + return NORMAL; #endif } @@ -4008,6 +4020,7 @@ nope: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); + return NORMAL; #endif } @@ -4054,6 +4067,7 @@ PP(pp_fork) RETURN; # else DIE(aTHX_ PL_no_func, "fork"); + return NORMAL; # endif #endif } @@ -4083,6 +4097,7 @@ PP(pp_wait) RETURN; #else DIE(aTHX_ PL_no_func, "wait"); + return NORMAL; #endif } @@ -4113,6 +4128,7 @@ PP(pp_waitpid) RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); + return NORMAL; #endif } @@ -4318,6 +4334,7 @@ PP(pp_getppid) RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); + return NORMAL; #endif } @@ -4339,6 +4356,7 @@ PP(pp_getpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "getpgrp()"); + return NORMAL; #endif } @@ -4372,6 +4390,7 @@ PP(pp_setpgrp) RETURN; #else DIE(aTHX_ PL_no_func, "setpgrp()"); + return NORMAL; #endif } @@ -4385,6 +4404,7 @@ PP(pp_getpriority) RETURN; #else DIE(aTHX_ PL_no_func, "getpriority()"); + return NORMAL; #endif } @@ -4400,6 +4420,7 @@ PP(pp_setpriority) RETURN; #else DIE(aTHX_ PL_no_func, "setpriority()"); + return NORMAL; #endif } @@ -4450,10 +4471,20 @@ 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; @@ -4482,10 +4513,22 @@ PP(pp_gmtime) } } - 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(%.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 (err == NULL) { /* XXX %lld broken for quads */ @@ -4546,6 +4589,7 @@ PP(pp_alarm) RETURN; #else DIE(aTHX_ PL_no_func, "alarm"); + return NORMAL; #endif } @@ -4615,6 +4659,7 @@ PP(pp_semget) RETURN; #else DIE(aTHX_ "System V IPC is not implemented on this machine"); + return NORMAL; #endif } @@ -4675,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); @@ -4750,6 +4795,7 @@ PP(pp_ghostent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "gethostent"); + return NORMAL; #endif } @@ -4823,6 +4869,7 @@ PP(pp_gnetent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getnetent"); + return NORMAL; #endif } @@ -4883,6 +4930,7 @@ PP(pp_gprotoent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getprotoent"); + return NORMAL; #endif } @@ -4958,6 +5006,7 @@ PP(pp_gservent) RETURN; #else DIE(aTHX_ PL_no_sock_func, "getservent"); + return NORMAL; #endif } @@ -4969,6 +5018,7 @@ PP(pp_shostent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "sethostent"); + return NORMAL; #endif } @@ -4980,6 +5030,7 @@ PP(pp_snetent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setnetent"); + return NORMAL; #endif } @@ -4991,6 +5042,7 @@ PP(pp_sprotoent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setprotoent"); + return NORMAL; #endif } @@ -5002,6 +5054,7 @@ PP(pp_sservent) RETSETYES; #else DIE(aTHX_ PL_no_sock_func, "setservent"); + return NORMAL; #endif } @@ -5014,6 +5067,7 @@ PP(pp_ehostent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endhostent"); + return NORMAL; #endif } @@ -5026,6 +5080,7 @@ PP(pp_enetent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endnetent"); + return NORMAL; #endif } @@ -5038,6 +5093,7 @@ PP(pp_eprotoent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endprotoent"); + return NORMAL; #endif } @@ -5050,6 +5106,7 @@ PP(pp_eservent) RETPUSHYES; #else DIE(aTHX_ PL_no_sock_func, "endservent"); + return NORMAL; #endif } @@ -5283,6 +5340,7 @@ PP(pp_gpwent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -5294,6 +5352,7 @@ PP(pp_spwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setpwent"); + return NORMAL; #endif } @@ -5305,6 +5364,7 @@ PP(pp_epwent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endpwent"); + return NORMAL; #endif } @@ -5379,6 +5439,7 @@ PP(pp_ggrent) RETURN; #else DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + return NORMAL; #endif } @@ -5390,6 +5451,7 @@ PP(pp_sgrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "setgrent"); + return NORMAL; #endif } @@ -5401,6 +5463,7 @@ PP(pp_egrent) RETPUSHYES; #else DIE(aTHX_ PL_no_func, "endgrent"); + return NORMAL; #endif } @@ -5416,6 +5479,7 @@ PP(pp_getlogin) RETURN; #else DIE(aTHX_ PL_no_func, "getlogin"); + return NORMAL; #endif } @@ -5514,6 +5578,7 @@ PP(pp_syscall) RETURN; #else DIE(aTHX_ PL_no_func, "syscall"); + return NORMAL; #endif } @@ -5526,6 +5591,7 @@ PP(pp_syscall) static int fcntl_emulate_flock(int fd, int operation) { + int res; struct flock flock; switch (operation & ~LOCK_NB) { @@ -5545,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 */