/* 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
#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
#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)
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;
}
ENTER;
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;
SvREFCNT_dec(sv);
break;
}
- XPUSHs(sv_2mortal(sv));
+ mXPUSHs(sv);
if (SvLEN(sv) - SvCUR(sv) > 20) {
SvPV_shrink_to_cur(sv);
}
#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 = sv_2mortal(newSVpvs("\000"));
+ PL_rs = newSVpvs_flags("\000", SVs_TEMP);
#ifndef DOSISH
#ifndef CSH
*SvPVX(PL_rs) = '\n';
tmps = SvPV_const(tmpsv, len);
}
if (!tmps || !len)
- tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
+ tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
RETSETYES;
PUSHs(file);
PUSHs(line);
PUTBACK;
- call_sv((SV*)GvCV(gv),
+ call_sv(MUTABLE_SV(GvCV(gv)),
G_SCALAR|G_EVAL|G_KEEPERR);
sv_setsv(error,*PL_stack_sp--);
}
}
}
if (!tmps || !len)
- tmpsv = sv_2mortal(newSVpvs("Died"));
+ tmpsv = newSVpvs_flags("Died", SVs_TEMP);
DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
}
STRLEN len;
bool ok;
- GV * const gv = (GV *)*++MARK;
+ GV * const gv = MUTABLE_GV(*++MARK);
if (!isGV(gv))
DIE(aTHX_ PL_no_usym, "filehandle");
Perl_warner(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;
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 (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));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
ENTER;
call_method("CLOSE", G_SCALAR);
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 (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
+ if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
DIE(aTHX_ PL_no_usym, "filehandle");
rstio = GvIOn(rgv);
wstio = GvIOn(wgv);
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));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
ENTER;
call_method("FILENO", G_SCALAR);
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));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
if (discp)
XPUSHs(discp);
PUTBACK;
PUTBACK;
{
- const int mode = mode_from_discipline(discp);
- const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
+ STRLEN len = 0;
+ const char *d = NULL;
+ int mode;
+ if (discp)
+ d = SvPV_const(discp, len);
+ mode = mode_from_discipline(d, len);
if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
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:
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)varsv)) {
- Perl_croak(aTHX_ "Attempt to tie unique GV");
+ if (isGV_with_GP(varsv)) {
+ 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 = MUTABLE_SV(GvIOp(varsv));
+ break;
}
-#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);
- break;
+ /* FALL THROUGH */
default:
methname = "TIESCALAR";
how = PERL_MAGIC_tiedscalar;
break;
}
items = SP - MARK++;
- if (sv_isobject(*MARK)) {
+ if (sv_isobject(*MARK)) { /* Calls GET magic. */
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
/* Not clear why we don't call call_method here too.
* perhaps to get different error message ?
*/
- stash = gv_stashsv(*MARK, 0);
+ STRLEN len;
+ const char *name = SvPV_nomg_const(*MARK, len);
+ stash = gv_stashpvn(name, len, 0);
if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
- methname, SVfARG(*MARK));
+ methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
}
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
while (items--)
PUSHs(*MARK++);
PUTBACK;
- call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
}
SPAGAIN;
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
CV *cv;
if (gv && isGV(gv) && (cv = GvCV(gv))) {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
- XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
+ mXPUSHi(SvREFCNT(obj) - 1);
PUTBACK;
ENTER;
- call_sv((SV *)cv, G_VOID);
+ call_sv(MUTABLE_SV(cv), G_VOID);
LEAVE;
SPAGAIN;
}
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
if ((mg = SvTIED_mg(sv, how))) {
HV* stash;
GV *gv;
- HV * const hv = (HV*)POPs;
- SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
+ 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"))) {
PUTBACK;
require_pv("AnyDBM_File.pm");
SPAGAIN;
- if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
+ if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
DIE(aTHX_ "No dbm on this machine");
}
PUSHs(sv);
PUSHs(left);
if (SvIV(right))
- PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
+ mPUSHu(O_RDWR|O_CREAT);
else
- PUSHs(sv_2mortal(newSVuv(O_RDWR)));
+ 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)) {
PUSHMARK(SP);
PUSHs(sv);
PUSHs(left);
- PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
+ 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);
+ DIE(aTHX_ "%s", PL_no_modify);
}
if (!SvPOK(sv)) {
if (ckWARN(WARN_MISC))
if (GIMME == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
- PUSHs(sv_2mortal(newSVnv(value)));
+ mPUSHn(value);
}
RETURN;
#else
#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; dSP; dTARGET;
HV *hv;
- GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
+ GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
GV * egv = GvEGV(PL_defoutgv);
if (!egv)
XPUSHTARG;
}
else {
- XPUSHs(sv_2mortal(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 (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));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
ENTER;
call_method("GETC", gimme);
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 */
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
+ PERL_ARGS_ASSERT_DOFORM;
+
ENTER;
SAVETMPS;
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
- PUSHFORMAT(cx);
- cx->blk_sub.retop = retop;
+ PUSHFORMAT(cx, retop);
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
if (MAXARG == 0)
gv = PL_defoutgv;
else {
- gv = (GV*)POPs;
+ gv = MUTABLE_GV(POPs);
if (!gv)
gv = PL_defoutgv;
}
DIE(aTHX_ "Not a format reference");
}
if (CvCLONE(cv))
- cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
IoFLAGS(io) &= ~IOf_DIDTOP;
return doform(cv,gv,PL_op->op_next);
PP(pp_leavewrite)
{
dVAR; dSP;
- GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
+ GV * const gv = cxstack[cxstack_ix].blk_format.gv;
register IO * const io = GvIOp(gv);
PerlIO *ofp;
PerlIO *fp;
DIE(aTHX_ "Undefined top format called");
}
if (cv && CvCLONE(cv))
- cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
return doform(cv, gv, PL_op);
}
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)
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;
- 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) */
+ 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 */
+
+ 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 = (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 (!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);
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));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
ENTER;
call_method("TELL", G_SCALAR);
RETURN;
}
}
+ 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));
+ XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
#if LSEEKSIZE > IVSIZE
- XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+ mXPUSHn((NV) offset);
#else
- XPUSHs(sv_2mortal(newSViv(offset)));
+ mXPUSHi(offset);
#endif
- XPUSHs(sv_2mortal(newSViv(whence)));
+ mXPUSHi(whence);
PUTBACK;
ENTER;
call_method("SEEK", G_SCALAR);
newSViv(sought)
#endif
: newSVpvn(zero_but_true, ZBTLEN);
- PUSHs(sv_2mortal(sv));
+ mPUSHs(sv);
}
}
RETURN;
SV * const sv = POPs;
const char *name;
- if (SvTYPE(sv) == SVt_PVGV) {
- tmpgv = (GV*)sv; /* *main::FRED for example */
+ if (isGV_with_GP(sv)) {
+ tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
goto do_ftruncate_gv;
}
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
- tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
+ else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
+ 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 (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 (SvTYPE(sv) == SVt_PVGV) {
- gv = (GV*)sv;
+ if (isGV_with_GP(sv)) {
+ gv = MUTABLE_GV(sv);
goto do_fstat;
- } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
- gv = (GV*)SvRV(sv);
+ } else if(SvROK(sv) && isGV_with_GP(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;
if (max) {
EXTEND(SP, max);
EXTEND_MORTAL(max);
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
+ mPUSHi(PL_statcache.st_dev);
+ mPUSHi(PL_statcache.st_ino);
+ mPUSHu(PL_statcache.st_mode);
+ mPUSHu(PL_statcache.st_nlink);
#if Uid_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
+ mPUSHn(PL_statcache.st_uid);
#else
# if Uid_t_sign <= 0
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
+ mPUSHi(PL_statcache.st_uid);
# else
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
+ mPUSHu(PL_statcache.st_uid);
# endif
#endif
#if Gid_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
+ mPUSHn(PL_statcache.st_gid);
#else
# if Gid_t_sign <= 0
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
+ mPUSHi(PL_statcache.st_gid);
# else
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
+ mPUSHu(PL_statcache.st_gid);
# endif
#endif
#ifdef USE_STAT_RDEV
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
+ mPUSHi(PL_statcache.st_rdev);
#else
- PUSHs(sv_2mortal(newSVpvs("")));
+ PUSHs(newSVpvs_flags("", SVs_TEMP));
#endif
#if Off_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
+ mPUSHn(PL_statcache.st_size);
#else
- PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
+ mPUSHi(PL_statcache.st_size);
#endif
#ifdef BIG_TIME
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
+ mPUSHn(PL_statcache.st_atime);
+ mPUSHn(PL_statcache.st_mtime);
+ mPUSHn(PL_statcache.st_ctime);
#else
- PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
- PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
- PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
+ mPUSHi(PL_statcache.st_atime);
+ mPUSHi(PL_statcache.st_mtime);
+ mPUSHi(PL_statcache.st_ctime);
#endif
#ifdef USE_STAT_BLOCKS
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
- PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
+ mPUSHu(PL_statcache.st_blksize);
+ mPUSHu(PL_statcache.st_blocks);
#else
- PUSHs(sv_2mortal(newSVpvs("")));
- PUSHs(sv_2mortal(newSVpvs("")));
+ PUSHs(newSVpvs_flags("", SVs_TEMP));
+ PUSHs(newSVpvs_flags("", SVs_TEMP));
#endif
}
RETURN;
* 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; } \
}
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) {
access_mode = W_OK;
#endif
stat_mode = S_IWUSR;
- /* Fall through */
+ /* fall through */
case OP_FTEREAD:
#ifndef PERL_EFF_ACCESS
effective = TRUE;
break;
-
case OP_FTEEXEC:
#ifdef PERL_EFF_ACCESS
- access_mode = W_OK;
+ access_mode = X_OK;
#else
use_access = 0;
#endif
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)
{
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
#endif
STACKED_FTEST_CHECK;
+
result = my_stat();
SPAGAIN;
if (result < 0)
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))
GV *gv;
SV *tmpsv = NULL;
+ tryAMAGICftest('t');
+
STACKED_FTEST_CHECK;
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
else if (isGV(TOPs))
- gv = (GV*)POPs;
+ gv = MUTABLE_GV(POPs);
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
- gv = (GV*)SvRV(POPs);
+ gv = MUTABLE_GV(SvRV(POPs));
else
gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
GV *gv;
PerlIO *fp;
+ tryAMAGICftest(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;
+ 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)) {
if (PL_op->op_flags & OPf_SPECIAL) {
gv = gv_fetchsv(sv, 0, SVt_PVIO);
}
- else if (SvTYPE(sv) == SVt_PVGV) {
- gv = (GV*)sv;
+ else if (isGV_with_GP(sv)) {
+ gv = MUTABLE_GV(sv);
}
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
- gv = (GV*)SvRV(sv);
+ else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
+ gv = MUTABLE_GV(SvRV(sv));
}
else {
tmps = SvPV_nolen_const(sv);
int anum = 1;
Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
+ PERL_ARGS_ASSERT_DOONELINER;
+
Newx(cmdline, size, char);
my_strlcpy(cmdline, cmd, size);
my_strlcat(cmdline, " ", size);
#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)
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 (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(sv);
#endif
- XPUSHs(sv_2mortal(sv));
+ mXPUSHs(sv);
} while (gimme == G_ARRAY);
if (!dp && gimme != G_ARRAY)
# 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 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 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 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)) {
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;
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV * const really = *++MARK;
-# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
+# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
value = (I32)do_aspawn(really, MARK, SP);
# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
# endif
}
else if (SP - MARK != 1) {
-# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
+# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
value = (I32)do_aspawn(NULL, MARK, SP);
# else
value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
if (MAXARG < 2) {
pgrp = 0;
pid = 0;
+ XPUSHi(-1);
}
else {
pgrp = POPi;
/* is returned. */
#endif
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
+ mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
+ mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
+ mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
+ mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
}
RETURN;
#else
# ifdef PERL_MICRO
dSP;
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ mPUSHn(0.0);
EXTEND(SP, 4);
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
- PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ mPUSHn(0.0);
+ mPUSHn(0.0);
+ mPUSHn(0.0);
}
RETURN;
# else
#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
-
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 && ckWARN(WARN_OVERFLOW)) {
+ Perl_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
+ err = S_localtime64_r(&when, &tmbuf);
else
- tmbuf = gmtime(&when);
+ err = S_gmtime64_r(&when, &tmbuf);
- if (GIMME != G_ARRAY) {
+ if (err == NULL && ckWARN(WARN_OVERFLOW)) {
+ /* XXX %lld broken for quads */
+ Perl_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);
- PUSHs(sv_2mortal(tsv));
- }
- else if (tmbuf) {
+
+ 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 { /* list context */
+ if ( err == NULL )
+ RETURN;
+
EXTEND(SP, 9);
EXTEND_MORTAL(9);
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
- PUSHs(sv_2mortal(newSViv(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;
}
{
SV *target;
+ PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
+
if (array && *array) {
- target = sv_2mortal(newSVpvs(""));
+ target = newSVpvs_flags("", SVs_TEMP);
while (1) {
sv_catpv(target, *array);
if (!*++array)
}
if (hent) {
- PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
+ mPUSHs(newSVpv((char*)hent->h_name, 0));
PUSHs(space_join_names_mortal(hent->h_aliases));
- PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
+ mPUSHi(hent->h_addrtype);
len = hent->h_length;
- PUSHs(sv_2mortal(newSViv((IV)len)));
+ mPUSHi(len);
#ifdef h_addr
for (elem = hent->h_addr_list; elem && *elem; elem++) {
- XPUSHs(newSVpvn_flags(*elem, len, SVs_TEMP));
+ mXPUSHp(*elem, len);
}
#else
if (hent->h_addr)
- PUSHs(newSVpvn(hent->h_addr, len));
+ mPUSHp(hent->h_addr, len);
else
PUSHs(sv_mortalcopy(&PL_sv_no));
#endif /* h_addr */
}
if (nent) {
- PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
+ mPUSHs(newSVpv(nent->n_name, 0));
PUSHs(space_join_names_mortal(nent->n_aliases));
- PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
- PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
+ mPUSHi(nent->n_addrtype);
+ mPUSHi(nent->n_net);
}
RETURN;
}
if (pent) {
- PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
+ mPUSHs(newSVpv(pent->p_name, 0));
PUSHs(space_join_names_mortal(pent->p_aliases));
- PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
+ mPUSHi(pent->p_proto);
}
RETURN;
}
if (sent) {
- PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
+ mPUSHs(newSVpv(sent->s_name, 0));
PUSHs(space_join_names_mortal(sent->s_aliases));
#ifdef HAS_NTOHS
- PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
+ mPUSHi(PerlSock_ntohs(sent->s_port));
#else
- PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
+ mPUSHi(sent->s_port);
#endif
- PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
+ mPUSHs(newSVpv(sent->s_proto, 0));
}
RETURN;
{
#ifdef HAS_SETNETENT
dVAR; dSP;
- PerlSock_setnetent(TOPi);
+ (void)PerlSock_setnetent(TOPi);
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setnetent");
{
#ifdef HAS_SETPROTOENT
dVAR; dSP;
- PerlSock_setprotoent(TOPi);
+ (void)PerlSock_setprotoent(TOPi);
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setprotoent");
{
#ifdef HAS_SETSERVENT
dVAR; dSP;
- PerlSock_setservent(TOPi);
+ (void)PerlSock_setservent(TOPi);
RETSETYES;
#else
DIE(aTHX_ PL_no_sock_func, "setservent");
}
if (pwent) {
- PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
+ mPUSHs(newSVpv(pwent->pw_name, 0));
- PUSHs(sv = sv_2mortal(newSViv(0)));
+ sv = newSViv(0);
+ mPUSHs(sv);
/* If we have getspnam(), we try to dig up the shadow
* password. If we are underprivileged, the shadow
* interface will set the errno to EACCES or similar,
* 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);
}
# endif
# if Uid_t_sign <= 0
- PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
+ mPUSHi(pwent->pw_uid);
# else
- PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
+ mPUSHu(pwent->pw_uid);
# endif
# if Uid_t_sign <= 0
- PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
+ mPUSHi(pwent->pw_gid);
# else
- PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
+ mPUSHu(pwent->pw_gid);
# endif
/* pw_change, pw_quota, and pw_age are mutually exclusive--
* because of the poor interface of the Perl getpw*(),
* A better interface would have been to return a hash,
* but we are accursed by our history, alas. --jhi. */
# ifdef PWCHANGE
- PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
+ mPUSHi(pwent->pw_change);
# else
# ifdef PWQUOTA
- PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
+ mPUSHi(pwent->pw_quota);
# else
# ifdef PWAGE
- PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
+ mPUSHs(newSVpv(pwent->pw_age, 0));
# else
/* I think that you can never get this compiled, but just in case. */
PUSHs(sv_mortalcopy(&PL_sv_no));
/* pw_class and pw_comment are mutually exclusive--.
* see the above note for pw_change, pw_quota, and pw_age. */
# ifdef PWCLASS
- PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
+ mPUSHs(newSVpv(pwent->pw_class, 0));
# else
# ifdef PWCOMMENT
- PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
+ mPUSHs(newSVpv(pwent->pw_comment, 0));
# else
/* I think that you can never get this compiled, but just in case. */
PUSHs(sv_mortalcopy(&PL_sv_no));
SvTAINTED_on(sv);
# endif
- PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
+ mPUSHs(newSVpv(pwent->pw_dir, 0));
PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
# ifndef INCOMPLETE_TAINTS
# endif
# ifdef PWEXPIRE
- PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
+ mPUSHi(pwent->pw_expire);
# endif
}
RETURN;
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);
}
}
if (grent) {
- PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
+ mPUSHs(newSVpv(grent->gr_name, 0));
#ifdef GRPASSWD
- PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
+ mPUSHs(newSVpv(grent->gr_passwd, 0));
#else
PUSHs(sv_mortalcopy(&PL_sv_no));
#endif
- PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
+#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
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