X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=0d2c970ff177ab961f7067e0c7efaa1636968ac4;hb=0598b5ab3697b872539de6ed6dc1522b873602e1;hp=1e445da087b5af1bc373ad82fc1d71260ae34a45;hpb=a272e669f4b28ef6839df6dcd80d81421a1924dc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 1e445da..0d2c970 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,7 +1,7 @@ /* 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. @@ -13,6 +13,8 @@ * cloven by a great fissure, out of which the red glare came, now leaping * up, now dying down into darkness; and all the while far below there was * a rumour and a trouble as of great engines throbbing and labouring. + * + * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"] */ /* This file contains system pp ("push/pop") functions that @@ -27,8 +29,10 @@ #include "EXTERN.h" #define PERL_IN_PP_SYS_C #include "perl.h" -#include "localtime64.h" -#include "localtime64.c" +#ifndef PERL_MICRO +# include "time64.h" +# include "time64.c" +#endif #ifdef I_SHADOW /* Shadow password support for solaris - pdo@cs.umd.edu @@ -201,15 +205,6 @@ void endservent(void); #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ -/* AIX 5.2 and below use mktime for localtime, and defines the edge case - * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64 - * available in the 32bit environment, which could warrant Configure - * checks in the future. - */ -#ifdef _AIX -#define LOCALTIME_EDGECASE_BROKEN -#endif - /* F_OK unused: if stat() cannot find it... */ #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) @@ -330,7 +325,7 @@ PP(pp_backtick) 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; @@ -387,7 +382,7 @@ PP(pp_glob) #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); @@ -485,7 +480,7 @@ PP(pp_die) 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--); } @@ -521,7 +516,7 @@ PP(pp_open) STRLEN len; bool ok; - GV * const gv = (GV *)*++MARK; + GV * const gv = MUTABLE_GV(*++MARK); if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); @@ -534,11 +529,11 @@ PP(pp_open) 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; @@ -571,15 +566,15 @@ PP(pp_open) 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); @@ -603,8 +598,8 @@ PP(pp_pipe_op) 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; @@ -663,13 +658,13 @@ PP(pp_fileno) 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); @@ -736,13 +731,13 @@ PP(pp_binmode) 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; @@ -802,7 +797,7 @@ PP(pp_tie) 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"; @@ -810,7 +805,7 @@ PP(pp_tie) case SVt_PVGV: if (isGV_with_GP(varsv)) { #ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((GV*)varsv)) { + if (GvUNIQUE((const GV *)varsv)) { Perl_croak(aTHX_ "Attempt to tie unique GV"); } #endif @@ -820,7 +815,7 @@ PP(pp_tie) 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 */ @@ -858,7 +853,7 @@ PP(pp_tie) while (items--) PUSHs(*MARK++); PUTBACK; - call_sv((SV*)GvCV(gv), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); } SPAGAIN; @@ -888,7 +883,7 @@ PP(pp_untie) 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) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { @@ -898,11 +893,11 @@ PP(pp_untie) CV *cv; if (gv && isGV(gv) && (cv = GvCV(gv))) { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + 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; } @@ -926,7 +921,7 @@ PP(pp_tied) 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) && !(sv = MUTABLE_SV(GvIOp(sv)))) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { @@ -946,7 +941,7 @@ PP(pp_dbmopen) HV* stash; GV *gv; - 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"))) { @@ -969,7 +964,7 @@ PP(pp_dbmopen) 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)) { @@ -980,13 +975,13 @@ PP(pp_dbmopen) 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; @@ -1029,7 +1024,7 @@ PP(pp_sselect) 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)) @@ -1156,6 +1151,17 @@ PP(pp_sselect) #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) { @@ -1170,7 +1176,7 @@ PP(pp_select) { 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) @@ -1185,7 +1191,7 @@ PP(pp_select) XPUSHTARG; } else { - mXPUSHs(newRV((SV*)egv)); + mXPUSHs(newRV(MUTABLE_SV(egv))); } } @@ -1202,14 +1208,14 @@ PP(pp_getc) { 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); @@ -1228,7 +1234,7 @@ PP(pp_getc) 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 */ @@ -1278,7 +1284,7 @@ PP(pp_enterwrite) if (MAXARG == 0) gv = PL_defoutgv; else { - gv = (GV*)POPs; + gv = MUTABLE_GV(POPs); if (!gv) gv = PL_defoutgv; } @@ -1308,7 +1314,7 @@ PP(pp_enterwrite) 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); @@ -1399,7 +1405,7 @@ PP(pp_leavewrite) 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); } @@ -1449,10 +1455,11 @@ 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); @@ -1461,7 +1468,7 @@ PP(pp_prtf) ++SP; } PUSHMARK(MARK - 1); - *MARK = SvTIED_obj((SV*)io, mg); + *MARK = SvTIED_obj(MUTABLE_SV(io), mg); PUTBACK; ENTER; call_method("PRINTF", G_SCALAR); @@ -1521,7 +1528,7 @@ PP(pp_sysopen) 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 ? */ @@ -1557,15 +1564,15 @@ PP(pp_sysread) 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; @@ -1581,7 +1588,7 @@ PP(pp_sysread) goto say_undef; bufsv = *++MARK; if (! SvOK(bufsv)) - sv_setpvn(bufsv, "", 0); + sv_setpvs(bufsv, ""); length = SvIVx(*++MARK); SETERRNO(0,0); if (MARK < SP) @@ -1803,10 +1810,10 @@ PP(pp_send) 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; @@ -1818,7 +1825,7 @@ PP(pp_send) } PUSHMARK(ORIGMARK); - *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg); + *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg); ENTER; call_method("WRITE", G_SCALAR); LEAVE; @@ -2013,51 +2020,60 @@ PP(pp_eof) { dVAR; dSP; GV *gv; + IO *io; + MAGIC *mg; - if (MAXARG == 0) { - if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ - IO *io; - gv = PL_last_in_gv = GvEGV(PL_argvgv); - io = GvIO(gv); - if (io && !IoIFP(io)) { - if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { - IoLINES(io) = 0; - IoFLAGS(io) &= ~IOf_START; - do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); - if ( GvSV(gv) ) { - sv_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; } @@ -2068,14 +2084,14 @@ PP(pp_tell) 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); @@ -2103,14 +2119,14 @@ PP(pp_sysseek) 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 mXPUSHn((NV) offset); #else @@ -2201,15 +2217,15 @@ PP(pp_truncate) 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; } @@ -2247,7 +2263,7 @@ PP(pp_ioctl) 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; @@ -2324,7 +2340,7 @@ PP(pp_flock) 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); @@ -2359,7 +2375,7 @@ PP(pp_socket) 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; @@ -2409,8 +2425,8 @@ PP(pp_sockpair) 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]; @@ -2470,7 +2486,7 @@ PP(pp_bind) 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; @@ -2499,7 +2515,7 @@ PP(pp_connect) #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; @@ -2529,7 +2545,7 @@ PP(pp_listen) #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)) @@ -2562,8 +2578,8 @@ PP(pp_accept) #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) @@ -2634,7 +2650,7 @@ PP(pp_shutdown) #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)) @@ -2661,7 +2677,7 @@ PP(pp_ssockopt) 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; @@ -2735,7 +2751,7 @@ PP(pp_getpeername) #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; @@ -2821,7 +2837,7 @@ PP(pp_stat) 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: @@ -2848,15 +2864,15 @@ PP(pp_stat) 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; @@ -2942,7 +2958,7 @@ PP(pp_stat) * 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; } \ } @@ -3206,9 +3222,9 @@ PP(pp_fttty) 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); @@ -3255,9 +3271,9 @@ PP(pp_fttext) 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; @@ -3274,7 +3290,7 @@ PP(pp_fttext) else { PL_statgv = gv; PL_laststatval = -1; - sv_setpvn(PL_statname, "", 0); + sv_setpvs(PL_statname, ""); io = GvIO(PL_statgv); } if (io && IoIFP(io)) { @@ -3407,10 +3423,10 @@ PP(pp_chdir) 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); @@ -3763,7 +3779,7 @@ PP(pp_open_dir) #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) @@ -3800,7 +3816,7 @@ PP(pp_readdir) 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); @@ -3854,7 +3870,7 @@ PP(pp_telldir) # 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)) { @@ -3881,7 +3897,7 @@ PP(pp_seekdir) #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)) { @@ -3907,7 +3923,7 @@ PP(pp_rewinddir) { #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)) { @@ -3932,7 +3948,7 @@ PP(pp_closedir) { #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)) { @@ -4302,6 +4318,7 @@ PP(pp_setpgrp) if (MAXARG < 2) { pgrp = 0; pid = 0; + XPUSHi(-1); } else { pgrp = POPi; @@ -4404,91 +4421,88 @@ PP(pp_tms) #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; - Time64_T when; +#ifdef PERL_MICRO + Time_t when; + const struct tm *err; struct tm tmbuf; - struct tm *err; +#else + Time64_T when; + struct TM tmbuf; + struct TM *err; +#endif + 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"}; +#ifdef PERL_MICRO + if (MAXARG < 1) + (void)time(&when); + else + when = (Time_t)SvIVx(POPs); + + if (PL_op->op_type == OP_LOCALTIME) + err = localtime(&when); + else + err = gmtime(&when); + + if (!err) + tmbuf = *err; +#else if (MAXARG < 1) { time_t now; (void)time(&now); when = (Time64_T)now; } - else - when = (Time64_T)SvNVx(POPs); + else { + /* XXX POPq uses an SvIV so it won't work with 32 bit integer scalars + using a double causes an unfortunate loss of accuracy on high numbers. + What we really need is an SvQV. + */ + double input = POPn; + when = (Time64_T)input; + if( when != input ) { + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) too large", opname, input); + } + } if (PL_op->op_type == OP_LOCALTIME) err = localtime64_r(&when, &tmbuf); else err = gmtime64_r(&when, &tmbuf); +#endif - if( (tmbuf.tm_year + 1900) < 0 ) + if( err == NULL ) { + /* XXX %lld broken for quads */ Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "local/gmtime under/overflowed the year"); + "%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 (err == NULL) RETPUSHUNDEF; - tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d", + 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 */ @@ -4502,7 +4516,7 @@ PP(pp_gmtime) mPUSHi(tmbuf.tm_hour); mPUSHi(tmbuf.tm_mday); mPUSHi(tmbuf.tm_mon); - mPUSHi(tmbuf.tm_year); + mPUSHn(tmbuf.tm_year); mPUSHi(tmbuf.tm_wday); mPUSHi(tmbuf.tm_yday); mPUSHi(tmbuf.tm_isdst); @@ -5170,13 +5184,13 @@ PP(pp_gpwent) * has a different API than the Solaris/IRIX one. */ # if defined(HAS_GETSPNAM) && !defined(_AIX) { - const int saverrno = errno; + dSAVE_ERRNO; const struct spwd * const spwent = getspnam(pwent->pw_name); /* Save and restore errno so that * underprivileged attempts seem * to have never made the unsccessful * attempt to retrieve the shadow password. */ - errno = saverrno; + RESTORE_ERRNO; if (spwent && spwent->sp_pwdp) sv_setpv(sv, spwent->sp_pwdp); } @@ -5554,15 +5568,15 @@ static int lockf_emulate_flock(int fd, int operation) { int i; - const int save_errno = errno; Off_t pos; + dSAVE_ERRNO; /* flock locks entire file so for lockf we need to do the same */ pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ if (pos > 0) /* is seekable and needs to be repositioned */ if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) pos = -1; /* seek failed, so don't seek back afterwards */ - errno = save_errno; + RESTORE_ERRNO; switch (operation) {