#ifdef HAS_PASSWD
# ifdef I_PWD
# include <pwd.h>
-# else
-# if !defined(VMS)
+# elif !defined(VMS)
struct passwd *getpwnam (char *);
struct passwd *getpwuid (Uid_t);
-# endif
# endif
# ifdef HAS_GETPWENT
-#ifndef getpwent
+# ifndef getpwent
struct passwd *getpwent (void);
-#elif defined (VMS) && defined (my_getpwent)
+# elif defined (VMS) && defined (my_getpwent)
struct passwd *Perl_my_getpwent (pTHX);
-#endif
+# endif
# endif
#endif
struct group *getgrgid (Gid_t);
# endif
# ifdef HAS_GETGRENT
-#ifndef getgrent
+# ifndef getgrent
struct group *getgrent (void);
-#endif
+# endif
# endif
#endif
# undef my_chsize
# endif
# define my_chsize PerlLIO_chsize
+#elif defined(HAS_TRUNCATE)
+# define my_chsize PerlLIO_chsize
#else
-# ifdef HAS_TRUNCATE
-# define my_chsize PerlLIO_chsize
-# else
I32 my_chsize(int fd, Off_t length);
-# endif
#endif
#ifdef HAS_FLOCK
# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
# define FLOCK fcntl_emulate_flock
# define FCNTL_EMULATE_FLOCK
-# else /* no flock() or fcntl(F_SETLK,...) */
-# ifdef HAS_LOCKF
-# define FLOCK lockf_emulate_flock
-# define LOCKF_EMULATE_FLOCK
-# endif /* lockf */
-# endif /* no flock() or fcntl(F_SETLK,...) */
+# elif defined(HAS_LOCKF)
+# define FLOCK lockf_emulate_flock
+# define LOCKF_EMULATE_FLOCK
+# endif
# ifdef FLOCK
static int FLOCK (int, int);
#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
Perl_croak(aTHX_ "switching effective uid is not implemented");
#else
-#ifdef HAS_SETREUID
+# ifdef HAS_SETREUID
if (setreuid(euid, ruid))
-#else
-#ifdef HAS_SETRESUID
+# elif defined(HAS_SETRESUID)
if (setresuid(euid, ruid, (Uid_t)-1))
-#endif
-#endif
+# endif
/* diag_listed_as: entering effective %s failed */
Perl_croak(aTHX_ "entering effective uid failed");
#endif
#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
Perl_croak(aTHX_ "switching effective gid is not implemented");
#else
-#ifdef HAS_SETREGID
+# ifdef HAS_SETREGID
if (setregid(egid, rgid))
-#else
-#ifdef HAS_SETRESGID
+# elif defined(HAS_SETRESGID)
if (setresgid(egid, rgid, (Gid_t)-1))
-#endif
-#endif
+# endif
/* diag_listed_as: entering effective %s failed */
Perl_croak(aTHX_ "entering effective gid failed");
#endif
#ifdef HAS_SETREUID
if (setreuid(ruid, euid))
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
if (setresuid(ruid, euid, (Uid_t)-1))
#endif
-#endif
/* diag_listed_as: leaving effective %s failed */
Perl_croak(aTHX_ "leaving effective uid failed");
#ifdef HAS_SETREGID
if (setregid(rgid, egid))
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
if (setresgid(rgid, egid, (Gid_t)-1))
#endif
-#endif
/* diag_listed_as: leaving effective %s failed */
Perl_croak(aTHX_ "leaving effective gid failed");
dSP; dTARGET;
PerlIO *fp;
const char * const tmps = POPpconstx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
const char *mode = "r";
TAINT_PROPER("``");
ENTER_with_name("backtick");
SAVESPTR(PL_rs);
PL_rs = &PL_sv_undef;
- sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
+ SvPVCLEAR(TARG); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
NOOP;
LEAVE_with_name("backtick");
}
}
if (SvROK(exsv) && !PL_warnhook)
- Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
+ Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
else warn_sv(exsv);
RETSETYES;
}
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
if (IoDIRP(io))
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening dirhandle %"HEKf" also as a file",
+ Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
HEKfARG(GvENAME_HEK(gv)));
mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (ok)
PUSHi( (I32)PL_forkprocess );
else if (PL_forkprocess == 0) /* we are a new child */
- PUSHi(0);
+ PUSHs(&PL_sv_zero);
else
RETPUSHUNDEF;
RETURN;
PP(pp_close)
{
dSP;
+ /* pp_coreargs pushes a NULL to indicate no args passed to
+ * CORE::close() */
GV * const gv =
MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
if (PerlProc_pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
- IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
+ IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
+ IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
* (Sorry obfuscation writers. You're not going to be given this one.)
*/
stash = gv_stashsv(*MARK, 0);
- if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
- methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
- }
+ if (!stash) {
+ if (SvROK(*MARK))
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ methname, SVfARG(*MARK));
+ else if (isGV(*MARK)) {
+ /* If the glob doesn't name an existing package, using
+ * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
+ * generate the name for the error message explicitly. */
+ SV *stashname = sv_2mortal(newSV(0));
+ gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ methname, SVfARG(stashname));
+ }
+ else {
+ SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
+ : SvCUR(*MARK) ? *MARK
+ : sv_2mortal(newSVpvs("main"));
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
+ " (perhaps you forgot to load \"%" SVf "\"?)",
+ methname, SVfARG(stashname), SVfARG(stashname));
+ }
+ }
+ else if (!(gv = gv_fetchmethod(stash, methname))) {
+ /* The effective name can only be NULL for stashes that have
+ * been deleted from the symbol table, which this one can't
+ * be, since we just looked it up by name.
+ */
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
+ methname, HvENAME_HEK_NN(stash));
+ }
ENTER_with_name("call_TIE");
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
- if (obj) {
+ if (obj && SvSTASH(obj)) {
GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
CV *cv;
if (gv && isGV(gv) && (cv = GvCV(gv))) {
}
else if (mg && SvREFCNT(obj) > 1) {
Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
- "untie attempted while %"UVuf" inner references still exist",
+ "untie attempted while %" UVuf " inner references still exist",
(UV)SvREFCNT(obj) - 1 ) ;
}
}
struct timeval *tbuf = &timebuf;
I32 growsize;
char *fd_sets[4];
+ SV *svs[4];
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
I32 masksize;
I32 offset;
SP -= 4;
for (i = 1; i <= 3; i++) {
- SV * const sv = SP[i];
+ SV * const sv = svs[i] = SP[i];
SvGETMAGIC(sv);
if (!SvOK(sv))
continue;
if (!SvPOKp(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Non-string passed as bitmask");
- SvPV_force_nomg_nolen(sv); /* force string conversion */
+ if (SvGAMAGIC(sv)) {
+ svs[i] = sv_newmortal();
+ sv_copypv_nomg(svs[i], sv);
+ }
+ else
+ SvPV_force_nomg_nolen(sv); /* force string conversion */
}
- j = SvCUR(sv);
+ j = SvCUR(svs[i]);
if (maxlen < j)
maxlen = j;
}
tbuf = NULL;
for (i = 1; i <= 3; i++) {
- sv = SP[i];
+ sv = svs[i];
if (!SvOK(sv) || SvCUR(sv) == 0) {
fd_sets[i] = 0;
continue;
#endif
for (i = 1; i <= 3; i++) {
if (fd_sets[i]) {
- sv = SP[i];
+ sv = svs[i];
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
s = SvPVX(sv);
for (offset = 0; offset < growsize; offset += masksize) {
}
Safefree(fd_sets[i]);
#endif
- SvSETMAGIC(sv);
+ if (sv != SP[i])
+ SvSetMagicSV(SP[i], sv);
+ else
+ SvSETMAGIC(sv);
}
}
PP(pp_getc)
{
dSP; dTARGET;
+ /* pp_coreargs pushes a NULL to indicate no args passed to
+ * CORE::getc() */
GV * const gv =
MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
IO *const io = GvIO(gv);
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- const U32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
PERL_ARGS_ASSERT_DOFORM;
if (CvCLONE(cv))
cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
- PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp, PL_savestack_ix);
- PUSHFORMAT(cx, retop);
+ cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
+ cx_pushformat(cx, cv, retop, gv);
if (CvDEPTH(cv) >= 2)
pad_push(CvPADLIST(cv), CvDEPTH(cv));
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
IO *io;
GV *fgv;
CV *cv = NULL;
- SV *tmpsv = NULL;
if (MAXARG == 0) {
EXTEND(SP, 1);
cv = GvFORM(fgv);
if (!cv) {
- tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
gv_efullname4(tmpsv, fgv, NULL, FALSE);
- DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
+ DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
}
IoFLAGS(io) &= ~IOf_DIDTOP;
RETURNOP(doform(cv,gv,PL_op->op_next));
SV *topname;
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
+ topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
HEKfARG(GvNAME_HEK(gv))));
topgv = gv_fetchsv(topname, 0, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
I32 lines = IoLINES_LEFT(io);
const char *s = SvPVX_const(PL_formtarget);
+ const char *e = SvEND(PL_formtarget);
if (lines <= 0) /* Yow, header didn't even fit!!! */
goto forget_top;
while (lines-- > 0) {
- s = strchr(s, '\n');
+ s = (char *) memchr(s, '\n', e - s);
if (!s)
break;
s++;
if (!cv) {
SV * const sv = sv_newmortal();
gv_efullname4(sv, fgv, NULL, FALSE);
- DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
+ DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
}
return doform(cv, gv, PL_op);
}
assert(CxTYPE(cx) == CXt_FORMAT);
SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
CX_LEAVE_SCOPE(cx);
- CX_POPFORMAT(cx);
- CX_POPBLOCK(cx);
+ cx_popformat(cx);
+ cx_popblock(cx);
retop = cx->blk_sub.retop;
CX_POP(cx);
+ EXTEND(SP, 1);
+
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
/* Need TIEHANDLE method ? */
const char * const tmps = SvPV_const(sv, len);
- if (do_open_raw(gv, tmps, len, mode, perm)) {
+ if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
IoLINES(GvIOp(gv)) = 0;
PUSHs(&PL_sv_yes);
}
goto say_undef;
bufsv = *++MARK;
if (! SvOK(bufsv))
- sv_setpvs(bufsv, "");
+ SvPVCLEAR(bufsv);
length = SvIVx(*++MARK);
if (length < 0)
DIE(aTHX_ "Negative length");
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));
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "%s() is deprecated on :utf8 handles. "
+ "This will be a fatal error in Perl 5.30",
+ OP_DESC(PL_op));
}
buffer = SvPVutf8_force(bufsv, blen);
/* UTF-8 may not have been set if they are all low bytes */
char namebuf[MAXPATHLEN];
if (fd < 0) {
SETERRNO(EBADF,SS_IVCHAN);
- RETPUSHUNDEF;
+ goto say_undef;
}
#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
count = PerlSock_recvfrom(fd, buffer, length, offset,
(struct sockaddr *)namebuf, &bufsize);
if (count < 0)
- RETPUSHUNDEF;
+ goto say_undef;
/* MSG_TRUNC can give oversized count; quietly lose it */
if (count > length)
count = length;
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));
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "%s() is deprecated on :utf8 handles. "
+ "This will be a fatal error in Perl 5.30",
+ OP_DESC(PL_op));
if (!SvUTF8(bufsv)) {
/* We don't modify the original scalar. */
tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
else
#ifndef HAS_FCNTL
DIE(aTHX_ "fcntl is not implemented");
-#else
-#if defined(OS2) && defined(__EMX__)
+#elif defined(OS2) && defined(__EMX__)
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
-#endif
#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
if (SvPOK(argsv)) {
TAINT_PROPER("socket");
fd = PerlSock_socket(domain, type, protocol);
if (fd < 0) {
- SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
- IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
- IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
+ IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
+ IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
IoTYPE(io) = IoTYPE_SOCKET;
if (!IoIFP(io) || !IoOFP(io)) {
if (IoIFP(io)) PerlIO_close(IoIFP(io));
TAINT_PROPER("socketpair");
if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
- IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
- IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
+ IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
+ IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
IoTYPE(io1) = IoTYPE_SOCKET;
- IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
- IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
+ IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
+ IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
IoTYPE(io2) = IoTYPE_SOCKET;
if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
goto badexit;
if (IoIFP(nstio))
do_close(ngv, FALSE);
- IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
- IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
+ IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
dSP;
GV *gv = NULL;
IO *io = NULL;
- I32 gimme;
+ U8 gimme;
I32 max = 13;
SV* sv;
if (gv != PL_defgv) {
do_fstat_warning_check:
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "lstat() on filehandle%s%"SVf,
+ "lstat() on filehandle%s%" SVf,
gv ? " " : "",
SVfARG(gv
? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
havefp = FALSE;
PL_laststype = OP_STAT;
PL_statgv = gv ? gv : (GV *)io;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
if(gv) {
io = GvIO(gv);
}
}
else {
const char *file;
+ const char *temp;
+ STRLEN len;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
goto do_fstat_warning_check;
goto do_fstat_have_io;
}
-
SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
+ temp = SvPV_nomg_const(sv, len);
+ sv_setpv(PL_statname, temp);
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
file = SvPV_nolen_const(PL_statname);
- if (PL_op->op_type == OP_LSTAT)
+ if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
+ PL_laststatval = -1;
+ }
+ else if (PL_op->op_type == OP_LSTAT)
PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
else
PL_laststatval = PerlLIO_stat(file, &PL_statcache);
EXTEND(SP, max);
EXTEND_MORTAL(max);
mPUSHi(PL_statcache.st_dev);
-#if ST_INO_SIZE > IVSIZE
- mPUSHn(PL_statcache.st_ino);
-#else
-# if ST_INO_SIGN <= 0
- mPUSHi(PL_statcache.st_ino);
-# else
- mPUSHu(PL_statcache.st_ino);
-# endif
-#endif
+ {
+ /*
+ * We try to represent st_ino as a native IV or UV where
+ * possible, but fall back to a decimal string where
+ * necessary. The code to generate these decimal strings
+ * is quite obtuse, because (a) we're portable to non-POSIX
+ * platforms where st_ino might be signed; (b) we didn't
+ * necessarily detect at Configure time whether st_ino is
+ * signed; (c) we're portable to non-POSIX platforms where
+ * ino_t isn't defined, so have no name for the type of
+ * st_ino; and (d) sprintf() doesn't necessarily support
+ * integers as large as st_ino.
+ */
+ bool neg;
+ Stat_t s;
+ GCC_DIAG_IGNORE(-Wtype-limits);
+ neg = PL_statcache.st_ino < 0;
+ GCC_DIAG_RESTORE;
+ if (neg) {
+ s.st_ino = (IV)PL_statcache.st_ino;
+ if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
+ mPUSHi(s.st_ino);
+ } else {
+ char buf[sizeof(s.st_ino)*3+1], *p;
+ s.st_ino = PL_statcache.st_ino;
+ for (p = buf + sizeof(buf); p != buf+1; ) {
+ Stat_t t;
+ t.st_ino = s.st_ino / 10;
+ *--p = '0' + (int)(t.st_ino*10 - s.st_ino);
+ s.st_ino = t.st_ino;
+ }
+ while (*p == '0')
+ p++;
+ *--p = '-';
+ mPUSHp(p, buf+sizeof(buf) - p);
+ }
+ } else {
+ s.st_ino = (UV)PL_statcache.st_ino;
+ if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
+ mPUSHu(s.st_ino);
+ } else {
+ char buf[sizeof(s.st_ino)*3], *p;
+ s.st_ino = PL_statcache.st_ino;
+ for (p = buf + sizeof(buf); p != buf; ) {
+ Stat_t t;
+ t.st_ino = s.st_ino / 10;
+ *--p = '0' + (int)(s.st_ino - t.st_ino*10);
+ s.st_ino = t.st_ino;
+ }
+ while (*p == '0')
+ p++;
+ mPUSHp(p, buf+sizeof(buf) - p);
+ }
+ }
+ }
mPUSHu(PL_statcache.st_mode);
mPUSHu(PL_statcache.st_nlink);
if (use_access) {
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
- const char *name = SvPV_nolen(*PL_stack_sp);
- if (effective) {
+ STRLEN len;
+ const char *name = SvPV(*PL_stack_sp, len);
+ if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
+ result = -1;
+ }
+ else if (effective) {
# ifdef PERL_EFF_ACCESS
result = PERL_EFF_ACCESS(name, access_mode);
# else
break;
}
SvSETMAGIC(TARG);
- return SvTRUE_nomg(TARG)
+ return SvTRUE_nomg_NN(TARG)
? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
}
}
}
else {
PL_statgv = gv;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
io = GvIO(PL_statgv);
}
PL_laststatval = -1;
}
else {
const char *file;
+ const char *temp;
+ STRLEN temp_len;
int fd;
assert(sv);
- sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
+ temp = SvPV_nomg_const(sv, temp_len);
+ sv_setpv(PL_statname, temp);
+ if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
+ PL_laststatval = -1;
+ PL_laststype = OP_STAT;
+ FT_RETURNUNDEF;
+ }
really_filename:
file = SvPVX_const(PL_statname);
PL_statgv = NULL;
}
PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0) {
+ dSAVE_ERRNO;
(void)PerlIO_close(fp);
- SETERRNO(EBADF,RMS_IFI);
+ RESTORE_ERRNO;
FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
#endif
assert(len);
- if (! is_invariant_string((U8 *) s, len)) {
- const U8 *ep;
+ if (! is_utf8_invariant_string((U8 *) s, len)) {
/* Here contains a variant under UTF-8 . See if the entire string is
- * UTF-8. But the buffer may end in a partial character, so consider
- * it UTF-8 if the first non-UTF8 char is an ending partial */
- if (is_utf8_string_loc((U8 *) s, len, &ep)
- || ep + UTF8SKIP(ep) > (U8 *) (s + len))
- {
+ * UTF-8. */
+ if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) {
if (PL_op->op_type == OP_FTTEXT) {
FT_RETURNYES;
}
}
else
#endif
- if (isPRINT_A(*s)
- /* VT occurs so rarely in text, that we consider it odd */
- || (isSPACE_A(*s) && *s != VT_NATIVE)
+ if ( isPRINT_A(*s)
+ /* VT occurs so rarely in text, that we consider it odd */
+ || (isSPACE_A(*s) && *s != VT_NATIVE)
/* But there is a fair amount of backspaces and escapes in
* some text */
- || *s == '\b'
- || *s == ESC_NATIVE)
+ || *s == '\b'
+ || *s == ESC_NATIVE)
{
continue;
}
"chdir() on unopened filehandle %" SVf, sv);
}
SETERRNO(EBADF,RMS_IFI);
- PUSHi(0);
+ PUSHs(&PL_sv_zero);
TAINT_PROPER("chdir");
RETURN;
}
HV * const table = GvHVn(PL_envgv);
SV **svp;
+ EXTEND(SP, 1);
if ( (svp = hv_fetchs(table, "HOME", FALSE))
|| (svp = hv_fetchs(table, "LOGDIR", FALSE))
#ifdef VMS
tmps = SvPV_nolen_const(*svp);
}
else {
- PUSHi(0);
+ PUSHs(&PL_sv_zero);
SETERRNO(EINVAL, LIB_INVARG);
TAINT_PROPER("chdir");
RETURN;
nuts:
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
- PUSHi(0);
+ PUSHs(&PL_sv_zero);
RETURN;
#endif
}
const char * const tmps = SvPV_nolen_const(TOPs);
TAINT_PROPER(PL_op_desc[op_type]);
result =
-# if defined(HAS_LINK)
-# if defined(HAS_SYMLINK)
+# if defined(HAS_LINK) && defined(HAS_SYMLINK)
/* Both present - need to choose which. */
(op_type == OP_LINK) ?
PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
-# else
+# elif defined(HAS_LINK)
/* Only have link, so calls to pp_symlink will have DIE()d above. */
PerlLIO_link(tmps, tmps2);
-# endif
-# else
-# if defined(HAS_SYMLINK)
+# elif defined(HAS_SYMLINK)
/* Only have symlink, so calls to pp_link will have DIE()d above. */
symlink(tmps, tmps2);
-# endif
# endif
}
IO * const io = GvIOn(gv);
if ((IoIFP(io) || IoOFP(io)))
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
- "Opening filehandle %"HEKf" also as a directory",
- HEKfARG(GvENAME_HEK(gv)) );
+ Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
+ HEKfARG(GvENAME_HEK(gv)));
if (IoDIRP(io))
PerlDir_close(IoDIRP(io));
if (!(IoDIRP(io) = PerlDir_open(dirname)))
dSP;
SV *sv;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
GV * const gv = MUTABLE_GV(POPs);
const Direntry_t *dp;
IO * const io = GvIOn(gv);
if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "readdir() attempted on invalid dirhandle %"HEKf,
+ "readdir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "telldir() attempted on invalid dirhandle %"HEKf,
+ "telldir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "seekdir() attempted on invalid dirhandle %"HEKf,
+ "seekdir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "rewinddir() attempted on invalid dirhandle %"HEKf,
+ "rewinddir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
- "closedir() attempted on invalid dirhandle %"HEKf,
+ "closedir() attempted on invalid dirhandle %" HEKf,
HEKfARG(GvENAME_HEK(gv)));
goto nope;
}
}
PUSHi(childpid);
RETURN;
-#else
-# if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
+#elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
dSP; dTARGET;
Pid_t childpid;
RETPUSHUNDEF;
PUSHi(childpid);
RETURN;
-# else
+#else
DIE(aTHX_ PL_no_func, "fork");
-# endif
#endif
}
if (did_pipes) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
}
RETURN;
-#else
-# ifdef PERL_MICRO
+#elif defined(PERL_MICRO)
dSP;
mPUSHn(0.0);
EXTEND(SP, 4);
mPUSHn(0.0);
}
RETURN;
-# else
+#else
DIE(aTHX_ "times not implemented");
-# endif
#endif /* HAS_TIMES */
}
else {
dTARGET;
PUSHs(TARG);
- Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
+ Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
dayname[tmbuf.tm_wday],
monname[tmbuf.tm_mon],
tmbuf.tm_mday,
PP(pp_sleep)
{
dSP; dTARGET;
- I32 duration;
Time_t lasttime;
Time_t when;
if (MAXARG < 1 || (!TOPs && !POPs))
PerlProc_pause();
else {
- duration = POPi;
+ const I32 duration = POPi;
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);
+ XPUSHs(&PL_sv_zero);
RETURN;
} else {
PerlProc_sleep((unsigned int)duration);
{
SV *target;
- PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
-
- if (*array) {
+ if (array && *array) {
target = newSVpvs_flags("", SVs_TEMP);
while (1) {
sv_catpv(target, *array);
* but we are accursed by our history, alas. --jhi. */
# ifdef PWCHANGE
mPUSHi(pwent->pw_change);
-# else
-# ifdef PWQUOTA
+# elif defined(PWQUOTA)
mPUSHi(pwent->pw_quota);
-# else
-# ifdef PWAGE
+# elif defined(PWAGE)
mPUSHs(newSVpv(pwent->pw_age, 0));
-# else
+# else
/* I think that you can never get this compiled, but just in case. */
PUSHs(sv_mortalcopy(&PL_sv_no));
-# endif
-# endif
# endif
/* pw_class and pw_comment are mutually exclusive--.
* see the above note for pw_change, pw_quota, and pw_age. */
# ifdef PWCLASS
mPUSHs(newSVpv(pwent->pw_class, 0));
-# else
-# ifdef PWCOMMENT
+# elif defined(PWCOMMENT)
mPUSHs(newSVpv(pwent->pw_comment, 0));
-# else
+# else
/* I think that you can never get this compiled, but just in case. */
PUSHs(sv_mortalcopy(&PL_sv_no));
-# endif
# endif
# ifdef PWGECOS
https://perl5.git.perl.org / perl5.git / blobdiff