dVAR;
OP *result;
dSP;
+ GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
+
+ PUTBACK;
+
/* make a copy of the pattern if it is gmagical, to ensure that magic
* is called once and only once */
- if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
+ if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
- tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
+ tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
if (PL_op->op_flags & OPf_SPECIAL) {
/* call Perl-level glob function instead. Stack args are:
- * MARK, wildcard, csh_glob context index
+ * MARK, wildcard
* and following OPs should be: gv(CORE::GLOBAL::glob), entersub
* */
return NORMAL;
}
- /* stack args are: wildcard, gv(_GEN_n) */
-
if (PL_globhook) {
- SETs(GvSV(TOPs));
PL_globhook(aTHX);
return NORMAL;
}
ENTER_with_name("glob");
#ifndef VMS
- if (PL_tainting) {
+ if (TAINTING_get) {
/*
* The external globbing program may use things we can't control,
* so for security reasons we must assume the worst.
#endif /* !VMS */
SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ PL_last_in_gv = gv;
SAVESPTR(PL_rs); /* This is not permanent, either. */
PL_rs = newSVpvs_flags("\000", SVs_TEMP);
/* well-formed exception supplied */
}
else {
- SvGETMAGIC(ERRSV);
- if (SvROK(ERRSV)) {
- if (SvGMAGICAL(ERRSV)) {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ if (SvGMAGICAL(errsv)) {
exsv = sv_newmortal();
- sv_setsv_nomg(exsv, ERRSV);
+ sv_setsv_nomg(exsv, errsv);
}
- else exsv = ERRSV;
+ else exsv = errsv;
}
- else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) {
+ else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
exsv = sv_newmortal();
- sv_setsv_nomg(exsv, ERRSV);
+ sv_setsv_nomg(exsv, errsv);
sv_catpvs(exsv, "\t...caught");
}
else {
SV *exsv;
STRLEN len;
#ifdef VMS
- VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
+ VMSISH_HUSHED =
+ VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
#endif
if (SP - MARK != 1) {
dTARGET;
if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
/* well-formed exception supplied */
}
- else if (SvROK(ERRSV)) {
- exsv = ERRSV;
- if (sv_isobject(exsv)) {
- HV * const stash = SvSTASH(SvRV(exsv));
- GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
- if (gv) {
- SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
- SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
- EXTEND(SP, 3);
- PUSHMARK(SP);
- PUSHs(exsv);
- PUSHs(file);
- PUSHs(line);
- PUTBACK;
- call_sv(MUTABLE_SV(GvCV(gv)),
- G_SCALAR|G_EVAL|G_KEEPERR);
- exsv = sv_mortalcopy(*PL_stack_sp--);
+ else {
+ SV * const errsv = ERRSV;
+ SvGETMAGIC(errsv);
+ if (SvROK(errsv)) {
+ exsv = errsv;
+ if (sv_isobject(exsv)) {
+ HV * const stash = SvSTASH(SvRV(exsv));
+ GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
+ if (gv) {
+ SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+ SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ EXTEND(SP, 3);
+ PUSHMARK(SP);
+ PUSHs(exsv);
+ PUSHs(file);
+ PUSHs(line);
+ PUTBACK;
+ call_sv(MUTABLE_SV(GvCV(gv)),
+ G_SCALAR|G_EVAL|G_KEEPERR);
+ exsv = sv_mortalcopy(*PL_stack_sp--);
+ }
}
}
- }
- else if (SvPV_const(ERRSV, len), len) {
- exsv = sv_mortalcopy(ERRSV);
- sv_catpvs(exsv, "\t...propagated");
- }
- else {
- exsv = newSVpvs_flags("Died", SVs_TEMP);
+ else if (SvPOK(errsv) && SvCUR(errsv)) {
+ exsv = sv_mortalcopy(errsv);
+ sv_catpvs(exsv, "\t...propagated");
+ }
+ else {
+ exsv = newSVpvs_flags("Died", SVs_TEMP);
+ }
}
return die_sv(exsv);
}
/* I/O. */
OP *
-Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
+Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
const MAGIC *const mg, const U32 flags, U32 argc, ...)
{
SV **orig_sp = sp;
SAVEGENERICSV(PL_ors_sv);
PL_ors_sv = newSVpvs("\n");
}
- ret_args = call_method(methname, flags & G_WANT);
+ ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
SPAGAIN;
orig_sp = sp;
POPSTACK;
if (mg) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
}
tmps = SvPV_const(sv, len);
- ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
+ ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
SP = ORIGMARK;
if (ok)
PUSHi( (I32)PL_forkprocess );
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
}
}
}
GV * const wgv = MUTABLE_GV(POPs);
GV * const rgv = MUTABLE_GV(POPs);
- if (!rgv || !wgv)
- goto badexit;
-
- if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
- DIE(aTHX_ PL_no_usym, "filehandle");
+ assert (isGV_with_GP(rgv));
+ assert (isGV_with_GP(wgv));
rstio = GvIOn(rgv);
- wstio = GvIOn(wgv);
-
if (IoIFP(rstio))
do_close(rgv, FALSE);
+
+ wstio = GvIOn(wgv);
if (IoIFP(wstio))
do_close(wgv, FALSE);
goto badexit;
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
- fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
+ /* ensure close-on-exec */
+ if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+ (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+ goto badexit;
#endif
RETPUSHYES;
if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
- return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
}
if (!io || !(fp = IoIFP(io))) {
function, which I don't think that the optimiser will be able to
figure out. Although, as it's a static function, in theory it
could. */
- return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
discp ? 1 : 0, discp);
}
switch(SvTYPE(varsv)) {
case SVt_PVHV:
+ {
+ HE *entry;
methname = "TIEHASH";
+ if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
+ HvLAZYDEL_off(varsv);
+ hv_free_ent((HV *)varsv, entry);
+ }
HvEITER_set(MUTABLE_HV(varsv), 0);
break;
+ }
case SVt_PVAV:
methname = "TIEARRAY";
if (!AvREAL(varsv)) {
varsv = MUTABLE_SV(GvIOp(varsv));
break;
}
+ if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
+ vivify_defelem(varsv);
+ varsv = LvTARG(varsv);
+ }
/* FALL THROUGH */
default:
methname = "TIESCALAR";
if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHYES;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
if ((mg = SvTIED_mg(sv, how))) {
SV * const obj = SvRV(SvTIED_obj(sv, mg));
if (obj) {
if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
RETPUSHUNDEF;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
+ !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
+
if ((mg = SvTIED_mg(sv, how))) {
PUSHs(SvTIED_obj(sv, mg));
RETURN;
if (!SvOK(sv))
continue;
if (SvREADONLY(sv)) {
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
- if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
- Perl_croak_no_modify(aTHX);
+ if (!(SvPOK(sv) && SvCUR(sv) == 0))
+ Perl_croak_no_modify();
}
+ else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
if (!SvPOK(sv)) {
if (!SvPOKp(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
# endif
sv = SP[4];
+ SvGETMAGIC(sv);
if (SvOK(sv)) {
- value = SvNV(sv);
+ value = SvNV_nomg(sv);
if (value < 0.0)
value = 0.0;
timebuf.tv_sec = (long)value;
=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
+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.
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
const U32 gimme = GIMME_V;
- Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
+ Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetMagicSV_nosteal(TARG, TOPs);
}
SvUTF8_on(TARG);
}
+ else SvUTF8_off(TARG);
PUSHTARG;
RETURN;
}
PERL_ARGS_ASSERT_DOFORM;
- if (cv && CvCLONE(cv))
+ if (CvCLONE(cv))
cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
ENTER;
SV *tmpsv = NULL;
if (MAXARG == 0) {
- gv = PL_defoutgv;
EXTEND(SP, 1);
+ gv = PL_defoutgv;
}
else {
gv = MUTABLE_GV(POPs);
PL_formtarget = PL_toptarget;
IoFLAGS(io) |= IOf_DIDTOP;
fgv = IoTOP_GV(io);
- if (!fgv)
- DIE(aTHX_ "bad top format reference");
+ assert(fgv); /* IoTOP_GV(io) should have been set above */
cv = GvFORM(fgv);
if (!cv) {
SV * const sv = sv_newmortal();
forget_top:
POPBLOCK(cx,PL_curpm);
- POPFORMAT(cx);
retop = cx->blk_sub.retop;
+ POPFORMAT(cx);
SP = newsp; /* ignore retval of formline */
LEAVE;
{
dVAR; dSP; dMARK; dORIGMARK;
PerlIO *fp;
- SV *sv;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
IO *const io = GvIO(gv);
+ /* Treat empty list as "" */
+ if (MARK == SP) XPUSHs(&PL_sv_no);
+
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
+ return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
}
- sv = newSV(0);
if (!io) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else {
+ SV *sv = sv_newmortal();
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_yes);
RETURN;
just_say_no:
- SvREFCNT_dec(sv);
SP = ORIGMARK;
PUSHs(&PL_sv_undef);
RETURN;
/* Need TIEHANDLE method ? */
const char * const tmps = SvPV_const(sv, len);
- /* FIXME? do_open should do const */
- if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
+ if (do_open_raw(gv, tmps, len, mode, perm)) {
IoLINES(GvIOp(gv)) = 0;
PUSHs(&PL_sv_yes);
}
bool charstart = FALSE;
STRLEN charskip = 0;
STRLEN skip = 0;
-
GV * const gv = MUTABLE_GV(*++MARK);
+ int fd;
+
if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
&& gv && (io = GvIO(gv)) )
{
const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
+
+ /* Note that fd can here validly be -1, don't check it yet. */
+ fd = PerlIO_fileno(IoIFP(io));
+
if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
buffer = SvPVutf8_force(bufsv, blen);
/* UTF-8 may not have been set if they are all low bytes */
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- /* SV's length cache is only safe for non-magical values */
- if (SvGMAGICAL(bufsv))
- blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
- else
- blen = sv_len_utf8(bufsv);
+ blen = sv_len_utf8_nomg(bufsv);
}
charstart = TRUE;
if (PL_op->op_type == OP_RECV) {
Sock_size_t bufsize;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ RETPUSHUNDEF;
+ }
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
#endif
buffer = SvGROW(bufsv, (STRLEN)(length+1));
/* 'offset' means 'flags' here */
- count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+ count = PerlSock_recvfrom(fd, buffer, length, offset,
(struct sockaddr *)namebuf, &bufsize);
if (count < 0)
RETPUSHUNDEF;
/* MSG_TRUNC can give oversized count; quietly lose it */
if (count > length)
count = length;
-#ifdef EPOC
- /* Bogus return without padding */
- bufsize = sizeof (struct sockaddr_in);
-#endif
SvCUR_set(bufsv, count);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(bufsv);
SP = ORIGMARK;
+#if defined(__CYGWIN__)
+ /* recvfrom() on cygwin doesn't set bufsize at all for
+ connected sockets, leaving us with trash in the returned
+ name, so use the same test as the Win32 code to check if it
+ wasn't set, and set it [perl #118843] */
+ if (bufsize == sizeof namebuf)
+ bufsize = 0;
+#endif
sv_setpvn(TARG, namebuf, bufsize);
PUSHs(TARG);
RETURN;
else
offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
}
+
more_bytes:
+ /* Reestablish the fd in case it shifted from underneath us. */
+ fd = PerlIO_fileno(IoIFP(io));
+
orig_size = SvCUR(bufsv);
/* Allocating length + offset + 1 isn't perfect in the case of reading
bytes from a byte file handle into a UTF8 buffer, but it won't harm us
if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
if (IoTYPE(io) == IoTYPE_SOCKET) {
- count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ count = -1;
+ }
+ else
+ count = PerlSock_recv(fd, buffer, length, 0);
}
else
#endif
{
- count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
- buffer, length);
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ count = -1;
+ }
+ else
+ count = PerlLIO_read(fd, buffer, length);
}
}
else
-#ifdef HAS_SOCKET__bad_code_maybe
- if (IoTYPE(io) == IoTYPE_SOCKET) {
- Sock_size_t bufsize;
- char namebuf[MAXPATHLEN];
-#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
- bufsize = sizeof (struct sockaddr_in);
-#else
- bufsize = sizeof namebuf;
-#endif
- count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
- (struct sockaddr *)namebuf, &bufsize);
- }
- else
-#endif
{
count = PerlIO_read(IoIFP(io), buffer, length);
/* PerlIO_read() - like fread() returns 0 on both error and EOF */
U8 *tmpbuf = NULL;
GV *const gv = MUTABLE_GV(*++MARK);
IO *const io = GvIO(gv);
+ int fd;
if (op_type == OP_SYSWRITE && io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
PUTBACK;
}
- return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
+ return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
sp - mark);
}
SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
+ fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ retval = -1;
+ goto say_undef;
+ }
/* Do this first to trigger any overloading. */
buffer = SvPV_const(bufsv, blen);
if (SP > MARK) {
STRLEN mlen;
char * const sockbuf = SvPVx(*++MARK, mlen);
- retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ retval = PerlSock_sendto(fd, buffer, blen,
flags, (struct sockaddr *)sockbuf, mlen);
}
else {
- retval
- = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+ retval = PerlSock_send(fd, buffer, blen, flags);
}
}
else
blen_chars = orig_blen_bytes;
} else {
/* The SV really is UTF-8. */
- if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
- /* Don't call sv_len_utf8 again because it will call magic
- or overloading a second time, and we might get back a
- different result. */
- blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
- } else {
- /* It's safe, and it may well be cached. */
- blen_chars = sv_len_utf8(bufsv);
- }
+ /* Don't call sv_len_utf8 on a magical or overloaded
+ scalar, as we might get back a different result. */
+ blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
}
} else {
blen_chars = blen;
}
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
if (IoTYPE(io) == IoTYPE_SOCKET) {
- retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ retval = PerlSock_send(fd, buffer, length, 0);
}
else
#endif
{
/* See the note at doio.c:do_print about filesize limits. --jhi */
- retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
- buffer, length);
+ retval = PerlLIO_write(fd, buffer, length);
}
}
RETPUSHNO;
if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
- return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
+ return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
}
if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
if (io && !IoIFP(io)) {
- if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
+ if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
- do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
+ do_open6(gv, "-", 1, NULL, NULL, 0);
if (GvSV(gv))
sv_setpvs(GvSV(gv), "-");
else
if (io) {
const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
+ return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
}
}
else if (!gv) {
SV *const offset_sv = newSViv(offset);
#endif
- return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
+ return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
newSViv(whence));
}
}
result = 0;
}
else {
- PerlIO_flush(fp);
+ int fd = PerlIO_fileno(fp);
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ result = 0;
+ } else {
+ PerlIO_flush(fp);
#ifdef HAS_TRUNCATE
- if (ftruncate(PerlIO_fileno(fp), len) < 0)
+ if (ftruncate(fd, len) < 0)
#else
- if (my_chsize(PerlIO_fileno(fp), len) < 0)
+ if (my_chsize(fd, len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
}
}
{
const int tmpfd = PerlLIO_open(name, O_RDWR);
- if (tmpfd < 0)
+ if (tmpfd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
result = 0;
- else {
+ } else {
if (my_chsize(tmpfd, len) < 0)
result = 0;
PerlLIO_close(tmpfd);
dVAR; dSP; dTARGET;
SV * const argsv = POPs;
const unsigned int func = POPu;
- const int optype = PL_op->op_type;
+ int optype;
GV * const gv = MUTABLE_GV(POPs);
- IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = GvIOn(gv);
char *s;
IV retval;
- if (!io || !argsv || !IoIFP(io)) {
+ if (!IoIFP(io)) {
report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
s = INT2PTR(char*,retval); /* ouch */
}
+ optype = PL_op->op_type;
TAINT_PROPER(PL_op_desc[optype]);
if (optype == OP_IOCTL)
const int type = POPi;
const int domain = POPi;
GV * const gv = MUTABLE_GV(POPs);
- IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = GvIOn(gv);
int fd;
- if (!io) {
- report_evil_fh(gv);
- if (io && IoIFP(io))
- do_close(gv, FALSE);
- SETERRNO(EBADF,LIB_INVARG);
- RETPUSHUNDEF;
- }
-
if (IoIFP(io))
do_close(gv, FALSE);
TAINT_PROPER("socket");
fd = PerlSock_socket(domain, type, protocol);
- if (fd < 0)
+ 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);
IoTYPE(io) = IoTYPE_SOCKET;
RETPUSHUNDEF;
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
-#endif
-
-#ifdef EPOC
- setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
+ if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
+ RETPUSHUNDEF;
#endif
RETPUSHYES;
{
#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
dVAR; dSP;
+ int fd[2];
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
+
GV * const gv2 = MUTABLE_GV(POPs);
+ IO * const io2 = GvIOn(gv2);
GV * const gv1 = MUTABLE_GV(POPs);
- IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
- IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
- int fd[2];
-
- if (!io1)
- report_evil_fh(gv1);
- if (!io2)
- report_evil_fh(gv2);
+ IO * const io1 = GvIOn(gv1);
- if (io1 && IoIFP(io1))
+ if (IoIFP(io1))
do_close(gv1, FALSE);
- if (io2 && IoIFP(io2))
+ if (IoIFP(io2))
do_close(gv2, FALSE);
- if (!io1 || !io2)
- RETPUSHUNDEF;
-
TAINT_PROPER("socketpair");
if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
RETPUSHUNDEF;
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
- fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
+ /* ensure close-on-exec */
+ if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+ (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+ RETPUSHUNDEF;
#endif
RETPUSHYES;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
STRLEN len;
- const int op_type = PL_op->op_type;
+ int op_type;
+ int fd;
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
+ fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0)
+ goto nuts;
addr = SvPV_const(addrsv, len);
+ op_type = PL_op->op_type;
TAINT_PROPER(PL_op_desc[op_type]);
if ((op_type == OP_BIND
- ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
- : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+ ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+ : PerlSock_connect(fd, (struct sockaddr *)addr, len))
>= 0)
RETPUSHYES;
else
dVAR; dSP;
const int backlog = POPi;
GV * const gv = MUTABLE_GV(POPs);
- IO * const io = gv ? GvIOn(gv) : NULL;
+ IO * const io = GvIOn(gv);
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
{
dVAR; dSP; dTARGET;
IO *nstio;
- IO *gstio;
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
Sock_size_t len = sizeof (struct sockaddr_in);
#else
Sock_size_t len = sizeof namebuf;
GV * const ngv = MUTABLE_GV(POPs);
int fd;
- if (!ngv)
- goto badexit;
- if (!ggv)
- goto nuts;
-
- gstio = GvIO(ggv);
+ IO * const gstio = GvIO(ggv);
if (!gstio || !IoIFP(gstio))
goto nuts;
goto badexit;
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+ if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
+ goto badexit;
#endif
-#ifdef EPOC
- len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
- setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
-#endif
#ifdef __SCO_VERSION__
len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
#endif
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
int fd;
Sock_size_t len;
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0)
+ goto nuts;
switch (optype) {
case OP_GSOCKOPT:
SvGROW(sv, 257);
SV *sv;
int fd;
- if (!io || !IoIFP(io))
+ if (!IoIFP(io))
goto nuts;
sv = sv_2mortal(newSV(257));
SvCUR_set(sv, len);
*SvEND(sv) ='\0';
fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0)
+ goto nuts;
switch (optype) {
case OP_GETSOCKNAME:
if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
}
if (io) {
if (IoIFP(io)) {
- PL_laststatval =
- PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
- havefp = TRUE;
+ int fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ PL_laststatval = -1;
+ SETERRNO(EBADF,RMS_IFI);
+ } else {
+ PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+ havefp = TRUE;
+ }
} else if (IoDIRP(io)) {
PL_laststatval =
PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
}
}
else {
+ const char *file;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
io = MUTABLE_IO(SvRV(sv));
if (PL_op->op_type == OP_LSTAT)
sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
+ file = SvPV_nolen_const(PL_statname);
if (PL_op->op_type == OP_LSTAT)
- PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
+ PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
else
- PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
+ PL_laststatval = PerlLIO_stat(file, &PL_statcache);
if (PL_laststatval < 0) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
+ if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
+ /* PL_warn_nl is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
+ GCC_DIAG_RESTORE;
+ }
max = 0;
}
}
#endif
mPUSHu(PL_statcache.st_mode);
mPUSHu(PL_statcache.st_nlink);
-#if Uid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_uid);
-#else
-# if Uid_t_sign <= 0
- mPUSHi(PL_statcache.st_uid);
-# else
- mPUSHu(PL_statcache.st_uid);
-# endif
-#endif
-#if Gid_t_size > IVSIZE
- mPUSHn(PL_statcache.st_gid);
-#else
-# if Gid_t_sign <= 0
- mPUSHi(PL_statcache.st_gid);
-# else
- mPUSHu(PL_statcache.st_gid);
-# endif
-#endif
+
+ sv_setuid(PUSHmortal, PL_statcache.st_uid);
+ sv_setgid(PUSHmortal, PL_statcache.st_gid);
+
#ifdef USE_STAT_RDEV
mPUSHi(PL_statcache.st_rdev);
#else
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
else if (name && isDIGIT(*name))
- fd = atoi(name);
+ fd = atoi(name);
else
FT_RETURNUNDEF;
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
+ }
if (PerlLIO_isatty(fd))
FT_RETURNYES;
FT_RETURNNO;
{
dVAR;
I32 i;
- I32 len;
+ SSize_t len;
I32 odd = 0;
STDCHAR tbuf[512];
STDCHAR *s;
PL_laststatval = -1;
PL_laststype = OP_STAT;
if (io && IoIFP(io)) {
+ int fd;
if (! PerlIO_has_base(IoIFP(io)))
DIE(aTHX_ "-T and -B not implemented on filehandles");
- PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
+ }
+ PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0)
FT_RETURNUNDEF;
if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
i = PerlIO_getc(IoIFP(io));
if (i != EOF)
(void)PerlIO_ungetc(IoIFP(io),i);
+ else
+ /* null file is anything */
+ FT_RETURNYES;
}
- if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
- FT_RETURNYES;
len = PerlIO_get_bufsiz(IoIFP(io));
s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
/* sfio can have large buffers - limit to 512 */
}
}
else {
+ const char *file;
+ int fd;
+
sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
really_filename:
+ file = SvPVX_const(PL_statname);
PL_statgv = NULL;
- if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
+ if (!(fp = PerlIO_open(file, "r"))) {
if (!gv) {
PL_laststatval = -1;
PL_laststype = OP_STAT;
}
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
- '\n'))
+ if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
+ /* PL_warn_nl is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
+ GCC_DIAG_RESTORE;
+ }
FT_RETURNUNDEF;
}
PL_laststype = OP_STAT;
- PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+ fd = PerlIO_fileno(fp);
+ if (fd < 0) {
+ (void)PerlIO_close(fp);
+ SETERRNO(EBADF,RMS_IFI);
+ FT_RETURNUNDEF;
+ }
+ PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
if (PL_laststatval < 0) {
(void)PerlIO_close(fp);
+ SETERRNO(EBADF,RMS_IFI);
FT_RETURNUNDEF;
}
PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
if (IoDIRP(io)) {
PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
} else if (IoIFP(io)) {
- PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+ int fd = PerlIO_fileno(IoIFP(io));
+ if (fd < 0) {
+ goto nuts;
+ }
+ PUSHi(fchdir(fd) >= 0);
}
else {
- report_evil_fh(gv);
- SETERRNO(EBADF, RMS_IFI);
- PUSHi(0);
+ goto nuts;
}
+ } else {
+ goto nuts;
}
- else {
- report_evil_fh(gv);
- SETERRNO(EBADF,RMS_IFI);
- PUSHi(0);
- }
+
#else
DIE(aTHX_ PL_no_func, "fchdir");
#endif
hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
#endif
RETURN;
+
+ nuts:
+ report_evil_fh(gv);
+ SETERRNO(EBADF,RMS_IFI);
+ PUSHi(0);
+ RETURN;
}
PP(pp_chown)
char buf[MAXPATHLEN];
int len;
-#ifndef INCOMPLETE_TAINTS
TAINT;
-#endif
tmps = POPpconstx;
len = readlink(tmps, buf, sizeof(buf) - 1);
if (len < 0)
; e++)
{
/* you don't see this */
- const char * const errmsg =
-#ifdef HAS_SYS_ERRLIST
- sys_errlist[e]
-#else
- strerror(e)
-#endif
- ;
+ const char * const errmsg = Strerror(e) ;
if (!errmsg)
break;
if (instr(s, errmsg)) {
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
- if (!io)
- goto nope;
-
if ((IoIFP(io) || IoOFP(io)))
Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
"Opening filehandle %"HEKf" also as a directory",
const Direntry_t *dp;
IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
"readdir() attempted on invalid dirhandle %"HEKf,
HEKfARG(GvENAME_HEK(gv)));
#else
sv = newSVpv(dp->d_name, 0);
#endif
-#ifndef INCOMPLETE_TAINTS
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(sv);
-#endif
mXPUSHs(sv);
} while (gimme == G_ARRAY);
if (!dp && gimme != G_ARRAY)
- goto nope;
+ RETPUSHUNDEF;
RETURN;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
"telldir() attempted on invalid dirhandle %"HEKf,
HEKfARG(GvENAME_HEK(gv)));
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
"seekdir() attempted on invalid dirhandle %"HEKf,
HEKfARG(GvENAME_HEK(gv)));
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
"rewinddir() attempted on invalid dirhandle %"HEKf,
HEKfARG(GvENAME_HEK(gv)));
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
- if (!io || !IoDIRP(io)) {
+ if (!IoDIRP(io)) {
Perl_ck_warner(aTHX_ packWARN(WARN_IO),
"closedir() attempted on invalid dirhandle %"HEKf,
HEKfARG(GvENAME_HEK(gv)));
#ifdef HAS_FORK
dVAR; dSP; dTARGET;
Pid_t childpid;
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
sigset_t oldmask, newmask;
#endif
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
sigfillset(&newmask);
sigprocmask(SIG_SETMASK, &newmask, &oldmask);
#endif
for (sig = 1; sig < SIG_SIZE; sig++)
PL_psig_pend[sig] = 0;
}
-#if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
+#ifdef HAS_SIGPROCMASK
{
dSAVE_ERRNO;
sigprocmask(SIG_SETMASK, &oldmask, NULL);
}
#endif
if (childpid < 0)
- RETSETUNDEF;
+ RETPUSHUNDEF;
if (!childpid) {
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
PERL_FLUSHALL_FOR_CHILD;
childpid = PerlProc_fork();
if (childpid == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
PUSHi(childpid);
RETURN;
# else
I32 value;
int result;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
Pid_t childpid;
int pp[2];
I32 did_pipes = 0;
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
sigset_t newset, oldset;
#endif
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
sigemptyset(&newset);
sigaddset(&newset, SIGCHLD);
sigprocmask(SIG_BLOCK, &newset, &oldset);
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
sigprocmask(SIG_SETMASK, &oldset, NULL);
#endif
RETURN;
XPUSHi(STATUS_CURRENT);
RETURN;
}
-#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
+#ifdef HAS_SIGPROCMASK
sigprocmask(SIG_SETMASK, &oldset, NULL);
#endif
if (did_pipes) {
PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+ if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+ RETPUSHUNDEF;
#endif
}
if (PL_op->op_flags & OPf_STACKED) {
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- if (PL_tainting) {
+ if (TAINTING_get) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen_const(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (TAINT_get)
break;
}
MARK = ORIGMARK;
#ifdef HAS_TIMES
dVAR;
dSP;
+ struct tms timesbuf;
+
EXTEND(SP, 4);
-#ifndef VMS
- (void)PerlProc_times(&PL_timesbuf);
-#else
- (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
- /* struct tms, though same data */
- /* is returned. */
-#endif
+ (void)PerlProc_times(×buf);
- mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
+ mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
if (GIMME == G_ARRAY) {
- 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);
+ mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
+ mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
+ mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
}
RETURN;
#else
}
if (err == NULL) {
+ /* diag_listed_as: gmtime(%f) failed */
/* XXX %lld broken for quads */
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
"%s(%.0" NVff ") failed", opname, 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 %.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 {
+ mPUSHs(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,
+ /* XXX newSVpvf()'s %lld type is broken,
+ * so cheat with a double */
+ (double)tmbuf.tm_year + 1900));
+ }
}
else { /* list context */
if ( err == NULL )
#ifdef HAS_GETSERVBYPORT
const char * const proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
-#ifdef HAS_HTONS
port = PerlSock_htons(port);
-#endif
sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
#else
DIE(aTHX_ PL_no_sock_func, "getservbyport");
PUSHs(sv = sv_newmortal());
if (sent) {
if (which == OP_GSBYNAME) {
-#ifdef HAS_NTOHS
sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
-#else
- sv_setiv(sv, (IV)(sent->s_port));
-#endif
}
else
sv_setpv(sv, sent->s_name);
if (sent) {
mPUSHs(newSVpv(sent->s_name, 0));
PUSHs(space_join_names_mortal(sent->s_aliases));
-#ifdef HAS_NTOHS
mPUSHi(PerlSock_ntohs(sent->s_port));
-#else
- mPUSHi(sent->s_port);
-#endif
mPUSHs(newSVpv(sent->s_proto, 0));
}
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
-# if Uid_t_sign <= 0
- sv_setiv(sv, (IV)pwent->pw_uid);
-# else
- sv_setuv(sv, (UV)pwent->pw_uid);
-# endif
+ sv_setuid(sv, pwent->pw_uid);
else
sv_setpv(sv, pwent->pw_name);
}
sv_setpv(sv, pwent->pw_passwd);
# endif
-# ifndef INCOMPLETE_TAINTS
/* passwd is tainted because user himself can diddle with it.
* admittedly not much and in a very limited way, but nevertheless. */
SvTAINTED_on(sv);
-# endif
-# if Uid_t_sign <= 0
- mPUSHi(pwent->pw_uid);
-# else
- mPUSHu(pwent->pw_uid);
-# endif
+ sv_setuid(PUSHmortal, pwent->pw_uid);
+ sv_setgid(PUSHmortal, pwent->pw_gid);
-# if Uid_t_sign <= 0
- mPUSHi(pwent->pw_gid);
-# else
- mPUSHu(pwent->pw_gid);
-# endif
/* pw_change, pw_quota, and pw_age are mutually exclusive--
* because of the poor interface of the Perl getpw*(),
* not because there's some standard/convention saying so.
# else
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# endif
-# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
-# endif
mPUSHs(newSVpv(pwent->pw_dir, 0));
PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
-# ifndef INCOMPLETE_TAINTS
/* pw_shell is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
-# endif
# ifdef PWEXPIRE
mPUSHi(pwent->pw_expire);
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
+ sv_setgid(sv, grent->gr_gid);
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
+ sv_setgid(PUSHmortal, grent->gr_gid);
#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
/* In UNICOS/mk (_CRAYMPP) the multithreading
I32 i = 0;
IV retval = -1;
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++MARK <= SP) {
if (SvTAINTED(*MARK)) {
TAINT;
https://perl5.git.perl.org / perl5.git / blobdiff