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);
}
* 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) {
#endif /* !DOSISH */
result = do_readline();
- LEAVE;
+ LEAVE_with_name("glob");
return result;
}
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. */
*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;
}
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;
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_func, "pipe");
- return NORMAL;
#endif
}
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))) {
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);
{
dVAR; dSP; dMARK;
HV* stash;
- GV *gv;
+ GV *gv = NULL;
SV *sv;
const I32 markoff = MARK - PL_stack_base;
const char *methname;
}
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);
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);
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);
"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;
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) {
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);
RETURN;
#else
DIE(aTHX_ "select not implemented");
- return NORMAL;
#endif
}
{
dVAR;
SvREFCNT_inc_simple_void(gv);
- if (PL_defoutgv)
- SvREFCNT_dec(PL_defoutgv);
+ SvREFCNT_dec(PL_defoutgv);
PL_defoutgv = gv;
}
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 {
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 */
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;
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() */
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) {
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));
}
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "flock()");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "socket");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "socketpair");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "bind");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "connect");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "listen");
- return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, "accept");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "shutdown");
- return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
#else
DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
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
case OP_FTEWRITE: opchar = 'w'; break;
case OP_FTEEXEC: opchar = 'x'; break;
}
- tryAMAGICftest(opchar);
+ tryAMAGICftest_MG(opchar);
STACKED_FTEST_CHECK;
case OP_FTCTIME: opchar = 'C'; break;
case OP_FTATIME: opchar = 'A'; break;
}
- tryAMAGICftest(opchar);
+ tryAMAGICftest_MG(opchar);
STACKED_FTEST_CHECK;
case OP_FTSGID: opchar = 'g'; break;
case OP_FTSVTX: opchar = 'k'; break;
}
- tryAMAGICftest(opchar);
+ tryAMAGICftest_MG(opchar);
/* I believe that all these three are likely to be defined on most every
system these days. */
dSP;
I32 result;
- tryAMAGICftest('l');
+ tryAMAGICftest_MG('l');
result = my_lstat();
SPAGAIN;
GV *gv;
SV *tmpsv = NULL;
- tryAMAGICftest('t');
+ tryAMAGICftest_MG('t');
STACKED_FTEST_CHECK;
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;
RETURN;
#else
DIE(aTHX_ PL_no_func, "chroot");
- return NORMAL;
#endif
}
{
/* Have neither. */
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
}
#endif
#endif
tmps = POPpconstx;
len = readlink(tmps, buf, sizeof(buf) - 1);
- EXTEND(SP, 1);
if (len < 0)
RETPUSHUNDEF;
PUSHp(buf, len);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "opendir");
- return NORMAL;
#endif
}
{
#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 *);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "telldir");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "seekdir");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "rewinddir");
- return NORMAL;
#endif
}
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "closedir");
- return NORMAL;
#endif
}
RETURN;
# else
DIE(aTHX_ PL_no_func, "fork");
- return NORMAL;
# endif
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "wait");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "waitpid");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpgrp()");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpgrp()");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpriority()");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpriority()");
- return NORMAL;
#endif
}
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;
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 */
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
}
RETURN;
#else
DIE(aTHX_ "System V IPC is not implemented on this machine");
- return NORMAL;
#endif
}
struct hostent *gethostbyname(Netdb_name_t);
struct hostent *gethostent(void);
#endif
- struct hostent *hent;
+ struct hostent *hent = NULL;
unsigned long len;
EXTEND(SP, 10);
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "gethostent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getnetent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getprotoent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_sock_func, "getservent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "sethostent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setnetent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setprotoent");
- return NORMAL;
#endif
}
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setservent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endhostent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endnetent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endprotoent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_sock_func, "endservent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setpwent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endpwent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "setgrent");
- return NORMAL;
#endif
}
RETPUSHYES;
#else
DIE(aTHX_ PL_no_func, "endgrent");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "getlogin");
- return NORMAL;
#endif
}
RETURN;
#else
DIE(aTHX_ PL_no_func, "syscall");
- return NORMAL;
#endif
}
static int
fcntl_emulate_flock(int fd, int operation)
{
+ int res;
struct flock flock;
switch (operation & ~LOCK_NB) {
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 */
https://perl5.git.perl.org / perl5.git / blobdiff