# endif
# endif
# ifdef HAS_GETPWENT
+#ifndef getpwent
struct passwd *getpwent (void);
+#elif defined (VMS) && defined (my_getpwent)
+ struct passwd *Perl_my_getpwent (void);
+#endif
# endif
#endif
struct group *getgrgid (Gid_t);
# endif
# ifdef HAS_GETGRENT
+#ifndef getgrent
struct group *getgrent (void);
+#endif
# endif
#endif
;
}
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);
}
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;
if (sv_isobject(sv)) {
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))
+ if (varsv == SvRV(sv) && how == PERL_MAGIC_tied)
Perl_croak(aTHX_
"Self-ties of arrays and hashes are not supported");
sv_magic(varsv, sv, how, Nullch, 0);
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
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;
I32 value;
STRLEN n_a;
int result;
- int pp[2];
I32 did_pipes = 0;
if (PL_tainting) {
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (PL_tainted)
break;
}
MARK = ORIGMARK;
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;
TAINT_ENV();
while (++MARK <= SP) {
(void)SvPV_nolen(*MARK); /* stringify for taint check */
- if (PL_tainted)
+ if (PL_tainted)
break;
}
MARK = ORIGMARK;
STRLEN n_a;
EXTEND(SP, 10);
- if (which == OP_GHBYNAME)
+ if (which == OP_GHBYNAME) {
#ifdef HAS_GETHOSTBYNAME
- hent = PerlSock_gethostbyname(POPpbytex);
+ char* name = POPpbytex;
+ hent = PerlSock_gethostbyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "gethostbyname");
#endif
+ }
else if (which == OP_GHBYADDR) {
#ifdef HAS_GETHOSTBYADDR
int addrtype = POPi;
#endif
#ifdef HOST_NOT_FOUND
- if (!hent)
- STATUS_NATIVE_SET(h_errno);
+ if (!hent) {
+#ifdef USE_REENTRANT_API
+# ifdef USE_GETHOSTENT_ERRNO
+ h_errno = PL_reentrant_buffer->_gethostent_errno;
+# endif
+#endif
+ STATUS_NATIVE_SET(h_errno);
+ }
#endif
if (GIMME != G_ARRAY) {
struct netent *nent;
STRLEN n_a;
- if (which == OP_GNBYNAME)
+ if (which == OP_GNBYNAME){
#ifdef HAS_GETNETBYNAME
- nent = PerlSock_getnetbyname(POPpbytex);
+ char *name = POPpbytex;
+ nent = PerlSock_getnetbyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getnetbyname");
#endif
+ }
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
int addrtype = POPi;
DIE(aTHX_ PL_no_sock_func, "getnetent");
#endif
+#ifdef HOST_NOT_FOUND
+ if (!nent) {
+#ifdef USE_REENTRANT_API
+# ifdef USE_GETNETENT_ERRNO
+ h_errno = PL_reentrant_buffer->_getnetent_errno;
+# endif
+#endif
+ STATUS_NATIVE_SET(h_errno);
+ }
+#endif
+
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
PUSHs(sv = sv_newmortal());
struct protoent *pent;
STRLEN n_a;
- if (which == OP_GPBYNAME)
+ if (which == OP_GPBYNAME) {
#ifdef HAS_GETPROTOBYNAME
- pent = PerlSock_getprotobyname(POPpbytex);
+ char* name = POPpbytex;
+ pent = PerlSock_getprotobyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getprotobyname");
#endif
- else if (which == OP_GPBYNUMBER)
+ }
+ else if (which == OP_GPBYNUMBER) {
#ifdef HAS_GETPROTOBYNUMBER
- pent = PerlSock_getprotobynumber(POPi);
+ int number = POPi;
+ pent = PerlSock_getprotobynumber(number);
#else
- DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
+ DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
#endif
+ }
else
#ifdef HAS_GETPROTOENT
pent = PerlSock_getprotoent();
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);
switch (which) {
case OP_GPWNAM:
- pwent = getpwnam(POPpbytex);
- break;
+ {
+ char* name = POPpbytex;
+ pwent = getpwnam(name);
+ }
+ break;
case OP_GPWUID:
- pwent = getpwuid((Uid_t)POPi);
+ {
+ Uid_t uid = POPi;
+ pwent = getpwuid(uid);
+ }
break;
case OP_GPWENT:
# ifdef HAS_GETPWENT
struct group *grent;
STRLEN n_a;
- if (which == OP_GGRNAM)
- grent = (struct group *)getgrnam(POPpbytex);
- else if (which == OP_GGRGID)
- grent = (struct group *)getgrgid(POPi);
+ if (which == OP_GGRNAM) {
+ char* name = POPpbytex;
+ grent = (struct group *)getgrnam(name);
+ }
+ else if (which == OP_GGRGID) {
+ Gid_t gid = POPi;
+ grent = (struct group *)getgrgid(gid);
+ }
else
#ifdef HAS_GETGRENT
grent = (struct group *)getgrent();
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;
https://perl5.git.perl.org / perl5.git / blobdiff