# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
+#include "reentr.h"
+
#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
#undef PERL_EFF_ACCESS_W_OK
#undef PERL_EFF_ACCESS_X_OK
;
}
else if (gimme == G_SCALAR) {
+ SV *oldrs = PL_rs;
+ PL_rs = &PL_sv_undef;
sv_setpv(TARG, ""); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
/*SUPPRESS 530*/
;
+ PL_rs = oldrs;
XPUSHs(TARG);
SvTAINTED_on(TARG);
}
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
IoTYPE(wstio) = IoTYPE_WRONLY;
RETPUSHUNDEF;
}
+ PUTBACK;
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
- (discp) ? SvPV_nolen(discp) : Nullch))
+ (discp) ? SvPV_nolen(discp) : Nullch)) {
+ SPAGAIN;
RETPUSHYES;
- else
+ }
+ else {
+ SPAGAIN;
RETPUSHUNDEF;
+ }
}
PP(pp_tie)
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- EXTEND(SP,items);
+ EXTEND(SP,(I32)items);
while (items--)
PUSHs(*MARK++);
PUTBACK;
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- EXTEND(SP,items);
+ EXTEND(SP,(I32)items);
while (items--)
PUSHs(*MARK++);
PUTBACK;
sv_unmagic(varsv, how);
/* Croak if a self-tie on an aggregate is attempted. */
if (varsv == SvRV(sv) &&
- (SvTYPE(sv) == SVt_PVAV ||
- SvTYPE(sv) == SVt_PVHV))
+ (SvTYPE(varsv) == SVt_PVAV ||
+ SvTYPE(varsv) == SVt_PVHV))
Perl_croak(aTHX_
"Self-ties of arrays and hashes are not supported");
- sv_magic(varsv, sv, how, Nullch, 0);
+ sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
}
LEAVE;
SP = PL_stack_base + markoff;
if (bufsize >= 256)
bufsize = 255;
#endif
- buffer = SvGROW(bufsv, length+1);
+ buffer = SvGROW(bufsv, (STRLEN)(length+1));
/* 'offset' means 'flags' here */
count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
(struct sockaddr *)namebuf, &bufsize);
blen = sv_len_utf8(bufsv);
}
if (offset < 0) {
- if (-offset > blen)
+ if (-offset > (int)blen)
DIE(aTHX_ "Offset outside string");
offset += blen;
}
}
more_bytes:
bufsize = SvCUR(bufsv);
- buffer = SvGROW(bufsv, length+offset+1);
+ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
if (offset > bufsize) { /* Zero any newly allocated space */
Zero(buffer+bufsize, offset-bufsize, char);
}
if (MARK < SP) {
offset = SvIVx(*++MARK);
if (offset < 0) {
- if (-offset > blen)
+ if (-offset > (IV)blen)
DIE(aTHX_ "Offset outside string");
offset += blen;
- } else if (offset >= blen && blen > 0)
+ } else if (offset >= (IV)blen && blen > 0)
DIE(aTHX_ "Offset outside string");
} else
offset = 0;
/* XXX Configure probe for the length type of *truncate() needed XXX */
Off_t len;
-#if Size_t_size > IVSIZE
+#if Off_t_size > IVSIZE
len = (Off_t)POPn;
#else
len = (Off_t)POPi;
DIE(aTHX_ "ioctl is not implemented");
#endif
else
-#ifdef HAS_FCNTL
+#ifndef HAS_FCNTL
+ DIE(aTHX_ "fcntl is not implemented");
+#else
#if defined(OS2) && defined(__EMX__)
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
-#else
- DIE(aTHX_ "fcntl is not implemented");
-#endif
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
else {
PUSHp(zero_but_true, ZBTLEN);
}
+#endif
RETURN;
}
I32 value;
STRLEN n_a;
int result;
- int pp[2];
I32 did_pipes = 0;
if (PL_tainting) {
+ int some_arg_tainted = 0;
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (PL_tainted) {
+ some_arg_tainted = 1;
break;
+ }
}
MARK = ORIGMARK;
/* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
if (SP - MARK == 1) {
TAINT_PROPER("system");
}
- else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
+ else if (some_arg_tainted && ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
"Use of tainted arguments in %s is deprecated", "system");
}
PERL_FLUSHALL_FOR_CHILD;
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
{
- Pid_t childpid;
- int status;
- Sigsave_t ihand,qhand; /* place to save signals during system() */
-
- if (PerlProc_pipe(pp) >= 0)
- did_pipes = 1;
- while ((childpid = PerlProc_fork()) == -1) {
- if (errno != EAGAIN) {
- value = -1;
- SP = ORIGMARK;
- PUSHi(value);
- if (did_pipes) {
- PerlLIO_close(pp[0]);
- PerlLIO_close(pp[1]);
- }
- RETURN;
- }
- sleep(5);
- }
- if (childpid > 0) {
- if (did_pipes)
- PerlLIO_close(pp[1]);
+ Pid_t childpid;
+ int pp[2];
+
+ if (PerlProc_pipe(pp) >= 0)
+ did_pipes = 1;
+ while ((childpid = PerlProc_fork()) == -1) {
+ if (errno != EAGAIN) {
+ value = -1;
+ SP = ORIGMARK;
+ PUSHi(value);
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[1]);
+ }
+ RETURN;
+ }
+ sleep(5);
+ }
+ if (childpid > 0) {
+ Sigsave_t ihand,qhand; /* place to save signals during system() */
+ int status;
+
+ if (did_pipes)
+ PerlLIO_close(pp[1]);
#ifndef PERL_MICRO
- rsignal_save(SIGINT, SIG_IGN, &ihand);
- rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+ rsignal_save(SIGINT, SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, SIG_IGN, &qhand);
#endif
- do {
- result = wait4pid(childpid, &status, 0);
- } while (result == -1 && errno == EINTR);
+ do {
+ result = wait4pid(childpid, &status, 0);
+ } while (result == -1 && errno == EINTR);
#ifndef PERL_MICRO
- (void)rsignal_restore(SIGINT, &ihand);
- (void)rsignal_restore(SIGQUIT, &qhand);
-#endif
- STATUS_NATIVE_SET(result == -1 ? -1 : status);
- do_execfree(); /* free any memory child malloced on fork */
- SP = ORIGMARK;
- if (did_pipes) {
- int errkid;
- int n = 0, n1;
-
- while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
- (void*)(((char*)&errkid)+n),
- (sizeof(int)) - n);
- if (n1 <= 0)
- break;
- n += n1;
- }
- PerlLIO_close(pp[0]);
- if (n) { /* Error */
- if (n != sizeof(int))
- DIE(aTHX_ "panic: kid popen errno read");
- errno = errkid; /* Propagate errno from kid */
- STATUS_CURRENT = -1;
- }
- }
- PUSHi(STATUS_CURRENT);
- RETURN;
- }
- if (did_pipes) {
- PerlLIO_close(pp[0]);
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
+#endif
+ STATUS_NATIVE_SET(result == -1 ? -1 : status);
+ do_execfree(); /* free any memory child malloced on fork */
+ SP = ORIGMARK;
+ if (did_pipes) {
+ int errkid;
+ int n = 0, n1;
+
+ while (n < sizeof(int)) {
+ n1 = PerlLIO_read(pp[0],
+ (void*)(((char*)&errkid)+n),
+ (sizeof(int)) - n);
+ if (n1 <= 0)
+ break;
+ n += n1;
+ }
+ PerlLIO_close(pp[0]);
+ if (n) { /* Error */
+ if (n != sizeof(int))
+ DIE(aTHX_ "panic: kid popen errno read");
+ errno = errkid; /* Propagate errno from kid */
+ STATUS_CURRENT = -1;
+ }
+ }
+ PUSHi(STATUS_CURRENT);
+ RETURN;
+ }
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+ fcntl(pp[1], F_SETFD, FD_CLOEXEC);
#endif
- }
- }
- if (PL_op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
- value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
- }
- else if (SP - MARK != 1)
- value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
- else {
- value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
+ }
+ if (PL_op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
+ }
+ else if (SP - MARK != 1)
+ value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
+ else {
+ value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
+ }
+ PerlProc__exit(-1);
}
- PerlProc__exit(-1);
#else /* ! FORK or VMS or OS/2 */
PL_statusvalue = 0;
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
+# ifdef WIN32
+ value = (I32)do_aspawn(really, MARK, SP);
+# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
+# endif
}
- else if (SP - MARK != 1)
+ else if (SP - MARK != 1) {
+# ifdef WIN32
+ value = (I32)do_aspawn(Nullsv, MARK, SP);
+# else
value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
+# endif
+ }
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
}
STRLEN n_a;
if (PL_tainting) {
+ int some_arg_tainted = 0;
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (PL_tainted) {
+ some_arg_tainted = 1;
break;
+ }
}
MARK = ORIGMARK;
/* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
if (SP - MARK == 1) {
TAINT_PROPER("exec");
}
- else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
+ else if (some_arg_tainted && ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
"Use of tainted arguments in %s is deprecated", "exec");
}
else if (which == OP_GSBYPORT) {
#ifdef HAS_GETSERVBYPORT
char *proto = POPpbytex;
- unsigned short port = POPu;
+ unsigned short port = (unsigned short)POPu;
#ifdef HAS_HTONS
port = PerlSock_htons(port);
case OP_GPWENT:
# ifdef HAS_GETPWENT
pwent = getpwent();
+#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
+ if (pwent) pwent = getpwnam(pwent->pw_name);
+#endif
# else
DIE(aTHX_ PL_no_func, "getpwent");
# endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setiv(sv, (IV)grent->gr_gid);
+#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ /* In UNICOS/mk (_CRAYMPP) the multithreading
+ * versions (getgrnam_r, getgrgid_r)
+ * seem to return an illegal pointer
+ * as the group members list, gr_mem.
+ * getgrent() doesn't even have a _r version
+ * but the gr_mem is poisonous anyway.
+ * So yes, you cannot get the list of group
+ * members if building multithreaded in UNICOS/mk. */
for (elem = grent->gr_mem; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
+#endif
}
RETURN;
projects / p5sagit/p5-mst-13.2.git / blobdiff