/* pp_sys.c
*
* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007 by Larry Wall and others
+ * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* 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
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
#endif
#endif
Perl_croak(aTHX_ "leaving effective gid failed");
- UNLOCK_CRED_MUTEX;
return res;
}
NOOP;
}
else if (gimme == G_SCALAR) {
- ENTER;
+ ENTER_with_name("backtick");
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
- sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
+ 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 /* !VMS */
SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
- PL_last_in_gv = (GV*)*PL_stack_sp--;
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
SAVESPTR(PL_rs); /* This is not permanent, either. */
PL_rs = newSVpvs_flags("\000", SVs_TEMP);
#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((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);
+ }
+ return die_sv(exsv);
}
/* I/O. */
STRLEN len;
bool ok;
- GV * const gv = (GV *)*++MARK;
+ GV * const gv = MUTABLE_GV(*++MARK);
- if (!isGV(gv))
+ if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
DIE(aTHX_ PL_no_usym, "filehandle");
if ((io = GvIOp(gv))) {
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((SV*)io, PERL_MAGIC_tiedscalar);
+ mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- *MARK-- = SvTIED_obj((SV*)io, mg);
+ *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 : (GV*)POPs;
+ 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((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((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;
}
register IO *wstio;
int fd[2];
- GV * const wgv = (GV*)POPs;
- GV * const rgv = (GV*)POPs;
+ GV * const wgv = MUTABLE_GV(POPs);
+ GV * const rgv = MUTABLE_GV(POPs);
if (!rgv || !wgv)
goto badexit;
if (MAXARG < 1)
RETPUSHUNDEF;
- gv = (GV*)POPs;
+ gv = MUTABLE_GV(POPs);
if (gv && (io = GvIO(gv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((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))) {
discp = POPs;
}
- gv = (GV*)POPs;
+ gv = MUTABLE_GV(POPs);
if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((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;
switch(SvTYPE(varsv)) {
case SVt_PVHV:
methname = "TIEHASH";
- HvEITER_set((HV *)varsv, 0);
+ HvEITER_set(MUTABLE_HV(varsv), 0);
break;
case SVt_PVAV:
methname = "TIEARRAY";
break;
case SVt_PVGV:
+ case SVt_PVLV:
if (isGV_with_GP(varsv)) {
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)varsv)) {
- Perl_croak(aTHX_ "Attempt to tie unique GV");
+ if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
+ deprecate("tie on a handle without *");
+ GvFLAGS(varsv) |= GVf_TIEWARNED;
}
-#endif
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
/* For tied filehandles, we apply tiedscalar magic to the IO
slot of the GP rather than the GV itself. AMS 20010812 */
if (!GvIOp(varsv))
GvIOp(varsv) = newIO();
- varsv = (SV *)GvIOp(varsv);
+ varsv = MUTABLE_SV(GvIOp(varsv));
break;
}
/* FALL THROUGH */
}
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);
while (items--)
PUSHs(*MARK++);
PUTBACK;
- call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
}
SPAGAIN;
"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;
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv)))
+ if (isGV_with_GP(sv)) {
+ if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
+ deprecate("untie on a handle without *");
+ GvFLAGS(sv) |= GVf_TIEWARNED;
+ }
+ if (!(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
+ }
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
CV *cv;
if (gv && isGV(gv) && (cv = GvCV(gv))) {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
mXPUSHi(SvREFCNT(obj) - 1);
PUTBACK;
- ENTER;
- call_sv((SV *)cv, G_VOID);
- LEAVE;
+ ENTER_with_name("call_UNTIE");
+ call_sv(MUTABLE_SV(cv), G_VOID);
+ 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 ) ;
}
}
}
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv)))
+ if (isGV_with_GP(sv)) {
+ if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
+ deprecate("tied on a handle without *");
+ GvFLAGS(sv) |= GVf_TIEWARNED;
+ }
+ if (!(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
+ }
if ((mg = SvTIED_mg(sv, how))) {
SV *osv = SvTIED_obj(sv, mg);
dVAR; dSP;
dPOPPOPssrl;
HV* stash;
- GV *gv;
+ GV *gv = NULL;
- HV * const hv = (HV*)POPs;
+ HV * const hv = MUTABLE_HV(POPs);
SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
stash = gv_stashsv(sv, 0);
if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
mPUSHu(O_RDWR);
PUSHs(right);
PUTBACK;
- call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
SPAGAIN;
if (!sv_isobject(TOPs)) {
mPUSHu(O_RDONLY);
PUSHs(right);
PUTBACK;
- call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
SPAGAIN;
}
if (sv_isobject(TOPs)) {
- sv_unmagic((SV *) hv, PERL_MAGIC_tied);
- sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
+ sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
+ sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
}
LEAVE;
RETURN;
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- DIE(aTHX_ PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
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);
#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;
}
{
dVAR; dSP; dTARGET;
HV *hv;
- GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
- GV * egv = GvEGV(PL_defoutgv);
+ GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
+ 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 {
XPUSHTARG;
}
else {
- mXPUSHs(newRV((SV*)egv));
+ mXPUSHs(newRV(MUTABLE_SV(egv)));
}
}
{
dVAR; dSP; dTARGET;
IO *io = NULL;
- GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
+ 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((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- const I32 gimme = GIMME_V;
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((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 */
RETPUSHUNDEF;
}
TAINT;
- sv_setpvn(TARG, " ", 1);
+ sv_setpvs(TARG, " ");
*SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
/* Find out how many bytes the char needs */
PERL_ARGS_ASSERT_DOFORM;
+ if (cv && CvCLONE(cv))
+ cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
+
ENTER;
SAVETMPS;
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 = (GV*)POPs;
+ gv = MUTABLE_GV(POPs);
if (!gv)
gv = PL_defoutgv;
}
- EXTEND(SP, 1);
io = GvIO(gv);
if (!io) {
RETPUSHNO;
not_a_format_reference:
DIE(aTHX_ "Not a format reference");
}
- if (CvCLONE(cv))
- cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
-
IoFLAGS(io) &= ~IOf_DIDTOP;
return doform(cv,gv,PL_op->op_next);
}
SV **newsp;
I32 gimme;
register PERL_CONTEXT *cx;
+ OP *retop;
if (!io || !(ofp = IoOFP(io)))
goto forget_top;
else
DIE(aTHX_ "Undefined top format called");
}
- if (cv && CvCLONE(cv))
- cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
return doform(cv, gv, PL_op);
}
forget_top:
POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
+ retop = cx->blk_sub.retop;
LEAVE;
fp = IoOFP(io);
}
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);
PUTBACK;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
- return cx->blk_sub.retop;
+ return retop;
}
PP(pp_prtf)
PerlIO *fp;
SV *sv;
- GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
+ GV * const gv
+ = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)io, mg);
+ *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
PUTBACK;
ENTER;
call_method("PRINTF", G_SCALAR);
const int perm = (MAXARG > 3) ? POPi : 0666;
const int mode = POPi;
SV * const sv = POPs;
- GV * const gv = (GV *)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
STRLEN len;
/* Need TIEHANDLE method ? */
STRLEN charskip = 0;
STRLEN skip = 0;
- GV * const gv = (GV*)*++MARK;
+ GV * const gv = MUTABLE_GV(*++MARK);
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
&& gv && (io = GvIO(gv)) )
{
- const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
SV *sv;
PUSHMARK(MARK-1);
- *MARK = SvTIED_obj((SV*)io, mg);
+ *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
ENTER;
call_method("READ", G_SCALAR);
LEAVE;
goto say_undef;
bufsv = *++MARK;
if (! SvOK(bufsv))
- sv_setpvn(bufsv, "", 0);
+ sv_setpvs(bufsv, "");
length = SvIVx(*++MARK);
SETERRNO(0,0);
if (MARK < SP)
(struct sockaddr *)namebuf, &bufsize);
if (count < 0)
RETPUSHUNDEF;
+ /* MSG_TRUNC can give oversized count; quietly lose it */
+ if (count > length)
+ count = length;
#ifdef EPOC
/* Bogus return without padding */
bufsize = sizeof (struct sockaddr_in);
bool doing_utf8;
U8 *tmpbuf = NULL;
- GV *const gv = (GV*)*++MARK;
+ GV *const gv = MUTABLE_GV(*++MARK);
if (PL_op->op_type == OP_SYSWRITE
&& gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
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;
}
PUSHMARK(ORIGMARK);
- *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
+ *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
ENTER;
call_method("WRITE", G_SCALAR);
LEAVE;
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");
}
{
dVAR; dSP;
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 == 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_setpvn(GvSV(gv), "-", 1);
- }
- else {
- GvSV(gv) = newSVpvn("-", 1);
- }
- SvSETMAGIC(GvSV(gv));
- }
- else if (!nextargv(gv))
- RETPUSHYES;
- }
+ if (MAXARG) {
+ gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
+ 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
+ else {
gv = PL_last_in_gv; /* eof */
+ which = 0;
+ }
}
- else
- gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
- if (gv) {
- IO * const io = GvIO(gv);
- MAGIC * mg;
- if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- PUTBACK;
- ENTER;
- call_method("EOF", G_SCALAR);
- LEAVE;
- SPAGAIN;
- RETURN;
+ if (!gv)
+ RETPUSHNO;
+
+ if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
+ return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
+ }
+
+ 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;
}
IO *io;
if (MAXARG != 0)
- PL_last_in_gv = (GV*)POPs;
+ 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((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((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 (!errno)
+ SETERRNO(EBADF,RMS_IFI);
+ PUSHi(-1);
+ RETURN;
+ }
#if LSEEKSIZE > IVSIZE
PUSHn( do_tell(gv) );
const Off_t offset = (Off_t)SvIVx(POPs);
#endif
- GV * const gv = PL_last_in_gv = (GV*)POPs;
+ GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
IO *io;
if (gv && (io = GvIO(gv))) {
- MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((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));
}
}
const char *name;
if (isGV_with_GP(sv)) {
- tmpgv = (GV*)sv; /* *main::FRED for example */
+ tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
goto do_ftruncate_gv;
}
else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
+ tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
goto do_ftruncate_gv;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
- io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
+ io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
goto do_ftruncate_io;
}
SV * const argsv = POPs;
const unsigned int func = POPu;
const int optype = PL_op->op_type;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
IO * const io = gv ? GvIOn(gv) : NULL;
char *s;
IV retval;
IO *io = NULL;
PerlIO *fp;
const int argtype = POPi;
- GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
+ GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
if (gv && (io = GvIO(gv)))
fp = IoIFP(io);
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = gv ? GvIOn(gv) : NULL;
int fd;
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
- GV * const gv2 = (GV*)POPs;
- GV * const gv1 = (GV*)POPs;
+ GV * const gv2 = MUTABLE_GV(POPs);
+ GV * const gv1 = MUTABLE_GV(POPs);
register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
int fd[2];
SV * const addrsv = POPs;
/* OK, so on what platform does bind modify addr? */
const char *addr;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
STRLEN len;
#ifdef HAS_SOCKET
dVAR; dSP;
SV * const addrsv = POPs;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
const char *addr;
STRLEN len;
#ifdef HAS_SOCKET
dVAR; dSP;
const int backlog = POPi;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = gv ? GvIOn(gv) : NULL;
if (!gv || !io || !IoIFP(io))
#else
Sock_size_t len = sizeof namebuf;
#endif
- GV * const ggv = (GV*)POPs;
- GV * const ngv = (GV*)POPs;
+ GV * const ggv = MUTABLE_GV(POPs);
+ GV * const ngv = MUTABLE_GV(POPs);
int fd;
if (!ngv)
#ifdef HAS_SOCKET
dVAR; dSP; dTARGET;
const int how = POPi;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
if (!io || !IoIFP(io))
SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
const unsigned int optname = (unsigned int) POPi;
const unsigned int lvl = (unsigned int) POPi;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
int fd;
Sock_size_t len;
#ifdef HAS_SOCKET
dVAR; dSP;
const int optype = PL_op->op_type;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
Sock_size_t len;
SV *sv;
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");
}
if (gv != PL_defgv) {
PL_laststype = OP_STAT;
PL_statgv = gv;
- sv_setpvn(PL_statname, "", 0);
+ sv_setpvs(PL_statname, "");
if(gv) {
io = GvIO(gv);
do_fstat_have_io:
else {
SV* const sv = POPs;
if (isGV_with_GP(sv)) {
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
goto do_fstat;
} else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- gv = (GV*)SvRV(sv);
+ gv = MUTABLE_GV(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
goto do_fstat;
} else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
- io = (IO*)SvRV(sv);
+ io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
goto do_fstat_have_io;
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
*/
#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
- if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
+ if (!SvTRUE(TOPs)) { RETURN; } \
else { (void)POPs; PUTBACK; } \
}
conditional compiling below much clearer. */
I32 use_access = 0;
#endif
- int stat_mode = S_IRUSR;
+ Mode_t 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_MG(opchar);
+
STACKED_FTEST_CHECK;
switch (PL_op->op_type) {
access_mode = W_OK;
#endif
stat_mode = S_IWUSR;
- /* Fall through */
+ /* fall through */
case OP_FTEREAD:
#ifndef PERL_EFF_ACCESS
#endif
}
- result = my_stat();
+ result = my_stat_flags(0);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
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_MG(opchar);
+
STACKED_FTEST_CHECK;
- result = my_stat();
+
+ result = my_stat_flags(0);
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
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_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;
PP(pp_ftlink)
{
dVAR;
- I32 result = my_lstat();
dSP;
+ I32 result;
+
+ tryAMAGICftest_MG('l');
+ result = my_lstat_flags(0);
+ SPAGAIN;
+
if (result < 0)
RETPUSHUNDEF;
if (S_ISLNK(PL_statcache.st_mode))
int fd;
GV *gv;
SV *tmpsv = NULL;
+ char *name = NULL;
+ STRLEN namelen;
+
+ tryAMAGICftest_MG('t');
STACKED_FTEST_CHECK;
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV(TOPs))
- gv = (GV*)POPs;
+ else if (isGV_with_GP(TOPs))
+ gv = MUTABLE_GV(POPs);
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = (GV*)SvRV(POPs);
- else
- gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
+ gv = MUTABLE_GV(SvRV(POPs));
+ 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;
}
GV *gv;
PerlIO *fp;
+ tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
+
STACKED_FTEST_CHECK;
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
- else if (isGV(TOPs))
- gv = (GV*)POPs;
+ else if (isGV_with_GP(TOPs))
+ gv = MUTABLE_GV(POPs);
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = (GV*)SvRV(POPs);
+ gv = MUTABLE_GV(SvRV(POPs));
else
gv = NULL;
else {
PL_statgv = gv;
PL_laststatval = -1;
- sv_setpvn(PL_statname, "", 0);
+ sv_setpvs(PL_statname, "");
io = GvIO(PL_statgv);
}
if (io && IoIFP(io)) {
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'))
gv = gv_fetchsv(sv, 0, SVt_PVIO);
}
else if (isGV_with_GP(sv)) {
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
}
else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
- gv = (GV*)SvRV(sv);
+ gv = MUTABLE_GV(SvRV(sv));
}
else {
tmps = SvPV_nolen_const(sv);
#endif
tmps = POPpconstx;
len = readlink(tmps, buf, sizeof(buf) - 1);
- EXTEND(SP, 1);
if (len < 0)
RETPUSHUNDEF;
PUSHp(buf, len);
#if defined(Direntry_t) && defined(HAS_READDIR)
dVAR; dSP;
const char * const dirname = POPpconstx;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register IO * const io = GvIOn(gv);
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)))
SV *sv;
const I32 gimme = GIMME;
- GV * const gv = (GV *)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
register const Direntry_t *dp;
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;
}
# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
long telldir (DIR *);
# endif
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
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;
}
#if defined(HAS_SEEKDIR) || defined(seekdir)
dVAR; dSP;
const long along = POPl;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
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);
{
#if defined(HAS_REWINDDIR) || defined(rewinddir)
dVAR; dSP;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
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));
{
#if defined(Direntry_t) && defined(HAS_READDIR)
dVAR; dSP;
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
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
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;
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;
if (MAXARG < 2) {
pgrp = 0;
pid = 0;
+ XPUSHi(-1);
}
else {
pgrp = POPi;
#endif
}
+#if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
+# 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()");
const int who = POPi;
const int which = TOPi;
TAINT_PROPER("setpriority");
- SETi( setpriority(which, who, niceval) >= 0 );
+ SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpriority()");
#endif
}
+#undef PRIORITY_WHICH_T
+
/* Time calls. */
PP(pp_time)
#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;
Time64_T when;
struct TM tmbuf;
struct TM *err;
- char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
+ 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[] =
when = (Time64_T)now;
}
else {
- double now = POPn;
- when = (Time64_T)now;
- if( when != now ) {
- Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "%.0f too large for %s", now, opname);
+ NV input = Perl_floor(POPn);
+ when = (Time64_T)input;
+ if (when != input) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "%s(%.0" NVff ") too large", opname, input);
}
}
- if (PL_op->op_type == OP_LOCALTIME)
- err = localtime64_r(&when, &tmbuf);
- else
- err = 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 ) {
- Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "%s under/overflowed the year", opname);
+ if (err == NULL) {
+ /* XXX %lld broken for quads */
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "%s(%.0" NVff ") failed", opname, 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 (err == NULL)
RETPUSHUNDEF;
- tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %lld",
+ 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,
- tmbuf.tm_year + 1900);
+ year);
mPUSHs(tsv);
}
else { /* list context */
int anum;
anum = POPi;
anum = alarm((unsigned int)anum);
- EXTEND(SP, 1);
if (anum < 0)
RETPUSHUNDEF;
PUSHi(anum);
struct hostent *gethostbyname(Netdb_name_t);
struct hostent *gethostent(void);
#endif
- struct hostent *hent;
+ struct hostent *hent = NULL;
unsigned long len;
EXTEND(SP, 10);
* 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);
}
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);
}
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
EXTEND(SP, 1);
if (!(tmps = PerlProc_getlogin()))
RETPUSHUNDEF;
- PUSHp(tmps, strlen(tmps));
+ sv_setpv_mg(TARG, tmps);
+ PUSHs(TARG);
RETURN;
#else
DIE(aTHX_ PL_no_func, "getlogin");
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 */
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) {
https://perl5.git.perl.org / perl5.git / blobdiff