#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
#endif
RETPUSHYES;
-badexit:
+ badexit:
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_func, "pipe");
PUTBACK;
call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
SPAGAIN;
+ if (sv_isobject(TOPs))
+ goto retie;
}
-
- if (sv_isobject(TOPs)) {
+ else {
+ retie:
sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
}
}
PUSHi(nfound);
- if (GIMME == G_ARRAY && tbuf) {
+ if (GIMME_V == G_ARRAY && tbuf) {
value = (NV)(timebuf.tv_sec) +
(NV)(timebuf.tv_usec) / 1000000.0;
mPUSHn(value);
I32 gimme;
PERL_CONTEXT *cx;
OP *retop;
+ bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
- if (!io || !(ofp = IoOFP(io)))
+ if (is_return || !io || !(ofp = IoOFP(io)))
goto forget_top;
DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
SP = newsp; /* ignore retval of formline */
LEAVE;
- if (!io || !(fp = IoOFP(io))) {
+ if (is_return)
+ /* XXX the semantics of doing 'return' in a format aren't documented.
+ * Currently we ignore any args to 'return' and just return
+ * a single undef in both scalar and list contexts
+ */
+ PUSHs(&PL_sv_undef);
+ else if (!io || !(fp = IoOFP(io))) {
if (io && IoIFP(io))
report_wrongway_fh(gv, '<');
else
fd = PerlIO_fileno(IoIFP(io));
if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
+ if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "%s() is deprecated on :utf8 handles",
+ OP_DESC(PL_op));
+ }
buffer = SvPVutf8_force(bufsv, blen);
/* UTF-8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
doing_utf8 = DO_UTF8(bufsv);
if (PerlIO_isutf8(IoIFP(io))) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "%s() is deprecated on :utf8 handles",
+ OP_DESC(PL_op));
if (!SvUTF8(bufsv)) {
/* We don't modify the original scalar. */
tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
SETERRNO(EBADF,RMS_IFI);
result = 0;
} else {
- PerlIO_flush(fp);
+ if (len < 0) {
+ SETERRNO(EINVAL, LIB_INVARG);
+ result = 0;
+ } else {
+ PerlIO_flush(fp);
#ifdef HAS_TRUNCATE
- if (ftruncate(fd, len) < 0)
+ if (ftruncate(fd, len) < 0)
#else
- if (my_chsize(fd, len) < 0)
+ if (my_chsize(fd, len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
}
}
result = 0;
#else
{
- const int tmpfd = PerlLIO_open(name, O_RDWR);
+ int mode = O_RDWR;
+ int tmpfd;
+
+#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
+ mode |= O_LARGEFILE; /* Transparently largefiley. */
+#endif
+#ifdef O_BINARY
+ /* On open(), the Win32 CRT tries to seek around text
+ * files using 32-bit offsets, which causes the open()
+ * to fail on large files, so open in binary mode.
+ */
+ mode |= O_BINARY;
+#endif
+ tmpfd = PerlLIO_open(name, mode);
if (tmpfd < 0) {
- SETERRNO(EBADF,RMS_IFI);
result = 0;
} else {
if (my_chsize(tmpfd, len) < 0)
else
RETPUSHUNDEF;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
else
RETPUSHUNDEF;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
PUSHp(namebuf, len);
RETURN;
-nuts:
+ nuts:
report_evil_fh(ggv);
SETERRNO(EBADF,SS_IVCHAN);
-badexit:
+ badexit:
RETPUSHUNDEF;
}
PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
RETURN;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
}
RETURN;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
-nuts2:
+ nuts2:
RETPUSHUNDEF;
}
PUSHs(sv);
RETURN;
-nuts:
+ nuts:
report_evil_fh(gv);
SETERRNO(EBADF,SS_IVCHAN);
-nuts2:
+ nuts2:
RETPUSHUNDEF;
}
GV *gv;
char *name = NULL;
STRLEN namelen;
+ UV uv;
tryAMAGICftest_MG('t');
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
- else if (name && isDIGIT(*name))
- fd = grok_atou(name, NULL);
+ else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
+ fd = (int)uv;
else
FT_RETURNUNDEF;
if (fd < 0) {
SV * const sv = POPs;
if (PL_op->op_flags & OPf_SPECIAL) {
gv = gv_fetchsv(sv, 0, SVt_PVIO);
+ if (!gv) {
+ if (ckWARN(WARN_UNOPENED)) {
+ Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
+ "chdir() on unopened filehandle %" SVf, sv);
+ }
+ SETERRNO(EBADF,RMS_IFI);
+ PUSHi(0);
+ TAINT_PROPER("chdir");
+ RETURN;
+ }
}
else if (!(gv = MAYBE_DEREF_GV(sv)))
tmps = SvPV_nomg_const_nolen(sv);
}
-
- if( !gv && (!tmps || !*tmps) ) {
+ else {
HV * const table = GvHVn(PL_envgv);
SV **svp;
#endif
)
{
- if( MAXARG == 1 )
- deprecate("chdir('') or chdir(undef) as chdir()");
tmps = SvPV_nolen_const(*svp);
}
else {
PUSHi(0);
+ SETERRNO(EINVAL, LIB_INVARG);
TAINT_PROPER("chdir");
RETURN;
}
#endif
RETURN;
+#ifdef HAS_FCHDIR
nuts:
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
PUSHi(0);
RETURN;
+#endif
}
STRLEN len;
const char *tmps;
bool copy = FALSE;
- const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
+ const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
TRIMSLASHES(tmps,len,copy);
goto nope;
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_DIR);
RETPUSHUNDEF;
dSP;
SV *sv;
- const I32 gimme = GIMME;
+ const I32 gimme = GIMME_V;
GV * const gv = MUTABLE_GV(POPs);
const Direntry_t *dp;
IO * const io = GvIOn(gv);
RETURN;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
- if (GIMME == G_ARRAY)
+ if (gimme == G_ARRAY)
RETURN;
else
RETPUSHUNDEF;
PUSHi( PerlDir_tell(IoDIRP(io)) );
RETURN;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
(void)PerlDir_seek(IoDIRP(io), along);
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
}
(void)PerlDir_rewind(IoDIRP(io));
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
IoDIRP(io) = 0;
RETPUSHYES;
-nope:
+ nope:
if (!errno)
SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
(void)PerlProc_times(×buf);
mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
dSP;
mPUSHn(0.0);
EXTEND(SP, 4);
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
mPUSHn(0.0);
mPUSHn(0.0);
mPUSHn(0.0);
}
else {
NV input = Perl_floor(POPn);
+ const bool pl_isnan = Perl_isnan(input);
when = (Time64_T)input;
- if (when != input) {
+ if (UNLIKELY(pl_isnan || when != input)) {
/* diag_listed_as: gmtime(%f) too large */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") too large", opname, input);
+ if (pl_isnan) {
+ err = NULL;
+ goto failed;
+ }
}
}
}
else {
if (PL_op->op_type == OP_LOCALTIME)
- err = S_localtime64_r(&when, &tmbuf);
+ err = Perl_localtime64_r(&when, &tmbuf);
else
- err = S_gmtime64_r(&when, &tmbuf);
+ err = Perl_gmtime64_r(&when, &tmbuf);
}
if (err == NULL) {
/* diag_listed_as: gmtime(%f) failed */
/* XXX %lld broken for quads */
+ failed:
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") failed", opname, when);
}
- if (GIMME != G_ARRAY) { /* scalar context */
+ if (GIMME_V != G_ARRAY) { /* scalar context */
EXTEND(SP, 1);
- EXTEND_MORTAL(1);
if (err == NULL)
RETPUSHUNDEF;
else {
- mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %"IVdf,
+ dTARGET;
+ PUSHs(TARG);
+ Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
dayname[tmbuf.tm_wday],
monname[tmbuf.tm_mon],
tmbuf.tm_mday,
tmbuf.tm_hour,
tmbuf.tm_min,
tmbuf.tm_sec,
- (IV)tmbuf.tm_year + 1900));
+ (IV)tmbuf.tm_year + 1900);
}
}
else { /* list context */
{
#ifdef HAS_ALARM
dSP; dTARGET;
- int anum;
- anum = POPi;
- anum = alarm((unsigned int)anum);
- if (anum < 0)
- RETPUSHUNDEF;
- PUSHi(anum);
- RETURN;
+ /* alarm() takes an unsigned int number of seconds, and return the
+ * unsigned int number of seconds remaining in the previous alarm
+ * (alarms don't stack). Therefore negative return values are not
+ * possible. */
+ int anum = POPi;
+ if (anum < 0) {
+ /* Note that while the C library function alarm() as such has
+ * no errors defined (or in other words, properly behaving client
+ * code shouldn't expect any), alarm() being obsoleted by
+ * setitimer() and often being implemented in terms of
+ * setitimer(), can fail. */
+ /* diag_listed_as: %s() with negative argument */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
+ "alarm() with negative argument");
+ SETERRNO(EINVAL, LIB_INVARG);
+ RETPUSHUNDEF;
+ }
+ else {
+ unsigned int retval = alarm(anum);
+ if ((int)retval < 0) /* Strictly speaking "cannot happen". */
+ RETPUSHUNDEF;
+ PUSHu(retval);
+ RETURN;
+ }
#else
DIE(aTHX_ PL_no_func, "alarm");
#endif
PerlProc_pause();
else {
duration = POPi;
- PerlProc_sleep((unsigned int)duration);
+ if (duration < 0) {
+ /* diag_listed_as: %s() with negative argument */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
+ "sleep() with negative argument");
+ SETERRNO(EINVAL, LIB_INVARG);
+ XPUSHi(0);
+ RETURN;
+ } else {
+ PerlProc_sleep((unsigned int)duration);
+ }
}
(void)time(&when);
XPUSHi(when - lasttime);
PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
- if (array && *array) {
+ if (*array) {
target = newSVpvs_flags("", SVs_TEMP);
while (1) {
sv_catpv(target, *array);
}
#endif
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (hent) {
if (which == OP_GHBYNAME) {
#endif
EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (nent) {
if (which == OP_GNBYNAME)
#endif
EXTEND(SP, 3);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (pent) {
if (which == OP_GPBYNAME)
#endif
EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (sent) {
if (which == OP_GSBYNAME) {
}
EXTEND(SP, 10);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
grent = (const struct group *)getgrnam(name);
}
else if (which == OP_GGRGID) {
+#if Gid_t_sign == 1
+ const Gid_t gid = POPu;
+#elif Gid_t_sign == -1
const Gid_t gid = POPi;
+#else
+# error "Unexpected Gid_t_sign"
+#endif
grent = (const struct group *)getgrgid(gid);
}
else
#endif
EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
SV * const sv = sv_newmortal();
PUSHs(sv);
#endif /* LOCKF_EMULATE_FLOCK */
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff