* 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;
}
break;
case SVt_PVGV:
if (isGV_with_GP(varsv)) {
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((const GV *)varsv)) {
- Perl_croak(aTHX_ "Attempt to tie unique GV");
- }
-#endif
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
/* For tied filehandles, we apply tiedscalar magic to the IO
#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)
{
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;
}
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_setpvs(GvSV(gv), "-");
- }
- else {
- GvSV(gv) = newSVpvs("-");
- }
- 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 = MUTABLE_GV(POPs); /* eof(FH) */
- if (gv) {
- IO * const io = GvIO(gv);
- MAGIC * mg;
- if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj(MUTABLE_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;
}
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
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 *gv;
PerlIO *fp;
+ tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
+
STACKED_FTEST_CHECK;
if (PL_op->op_flags & OPf_REF)
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 /* 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);
+
+ 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 if (tmbuf) {
+ else { /* list context */
+ if ( err == NULL )
+ RETURN;
+
EXTEND(SP, 9);
EXTEND_MORTAL(9);
- mPUSHi(tmbuf->tm_sec);
- mPUSHi(tmbuf->tm_min);
- mPUSHi(tmbuf->tm_hour);
- mPUSHi(tmbuf->tm_mday);
- mPUSHi(tmbuf->tm_mon);
- mPUSHi(tmbuf->tm_year);
- mPUSHi(tmbuf->tm_wday);
- mPUSHi(tmbuf->tm_yday);
- mPUSHi(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;
}
* 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
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