/* pp_sys.c
*
* Copyright (C) 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "reentr.h"
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+void sethostent(int);
+void endhostent(void);
+void setnetent(int);
+void endnetent(void);
+void setprotoent(int);
+void endprotoent(void);
+void setservent(int);
+void endservent(void);
+#endif
+
#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
#undef PERL_EFF_ACCESS_W_OK
#undef PERL_EFF_ACCESS_X_OK
if (PerlProc_pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
- IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_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;
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
- SV *obj = SvRV(mg->mg_obj);
+ SV *obj = SvRV(SvTIED_obj(sv, mg));
GV *gv;
CV *cv = NULL;
if (obj) {
Zero(&fd_sets[0], 4, char*);
#endif
-# if SELECT_MIN_BITS > 1
+# if SELECT_MIN_BITS == 1
+ growsize = sizeof(fd_set);
+# else
+# if defined(__GLIBC__) && defined(__FD_SETSIZE)
+# undef SELECT_MIN_BITS
+# define SELECT_MIN_BITS __FD_SETSIZE
+# endif
/* If SELECT_MIN_BITS is greater than one we most probably will want
* to align the sizes with SELECT_MIN_BITS/8 because for example
* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
* UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
* on (sets/tests/clears bits) is 32 bits. */
growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
-# else
- growsize = sizeof(fd_set);
# endif
sv = SP[4];
if (!IoTOP_NAME(io)) {
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
+ topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
!gv_fetchpv("top",FALSE,SVt_PVFM))
}
if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
buffer = SvPVutf8_force(bufsv, blen);
- /* UTF8 may not have been set if they are all low bytes */
+ /* UTF-8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
}
else {
}
if (PerlIO_isutf8(IoIFP(io))) {
- buffer = SvPVutf8(bufsv, blen);
+ if (!SvUTF8(bufsv)) {
+ bufsv = sv_2mortal(newSVsv(bufsv));
+ buffer = sv_2pvutf8(bufsv, &blen);
+ } else
+ buffer = SvPV(bufsv, blen);
}
else {
- if (DO_UTF8(bufsv))
- sv_utf8_downgrade(bufsv, FALSE);
- buffer = SvPV(bufsv, blen);
+ if (DO_UTF8(bufsv)) {
+ /* Not modifying source SV, so making a temporary copy. */
+ bufsv = sv_2mortal(newSVsv(bufsv));
+ sv_utf8_downgrade(bufsv, FALSE);
+ }
+ buffer = SvPV(bufsv, blen);
}
if (PL_op->op_type == OP_SYSWRITE) {
fd = PerlSock_socket(domain, type, protocol);
if (fd < 0)
RETPUSHUNDEF;
- IoIFP(io) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE); /* stdio gets confused about sockets */
- IoOFP(io) = PerlIO_fdopen(fd, "w"PIPESOCK_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"PIPESOCK_MODE);
- IoOFP(io1) = PerlIO_fdopen(fd[0], "w"PIPESOCK_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"PIPESOCK_MODE);
- IoOFP(io2) = PerlIO_fdopen(fd[1], "w"PIPESOCK_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"PIPESOCK_MODE);
- IoOFP(nstio) = PerlIO_fdopen(fd, "w"PIPESOCK_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));
RETURN;
}
+/* This macro is used by the stacked filetest operators :
+ * if the previous filetest failed, short-circuit and pass its value.
+ * Else, discard it from the stack and continue. --rgs
+ */
+#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
+ if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
+ else { (void)POPs; PUTBACK; } \
+ }
+
PP(pp_ftrread)
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#if defined(HAS_ACCESS) && defined(R_OK)
- STRLEN n_a;
if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
result = access(POPpx, R_OK);
if (result == 0)
RETPUSHYES;
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#if defined(HAS_ACCESS) && defined(W_OK)
- STRLEN n_a;
if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
result = access(POPpx, W_OK);
if (result == 0)
RETPUSHYES;
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#if defined(HAS_ACCESS) && defined(X_OK)
- STRLEN n_a;
if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
result = access(POPpx, X_OK);
if (result == 0)
RETPUSHYES;
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#ifdef PERL_EFF_ACCESS_R_OK
- STRLEN n_a;
if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
result = PERL_EFF_ACCESS_R_OK(POPpx);
if (result == 0)
RETPUSHYES;
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#ifdef PERL_EFF_ACCESS_W_OK
- STRLEN n_a;
if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
result = PERL_EFF_ACCESS_W_OK(POPpx);
if (result == 0)
RETPUSHYES;
{
I32 result;
dSP;
+ STACKED_FTEST_CHECK;
#ifdef PERL_EFF_ACCESS_X_OK
- STRLEN n_a;
if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ STRLEN n_a;
result = PERL_EFF_ACCESS_X_OK(POPpx);
if (result == 0)
RETPUSHYES;
PP(pp_ftis)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
RETPUSHYES;
PP(pp_ftrowned)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
PP(pp_ftzero)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (PL_statcache.st_size == 0)
PP(pp_ftsize)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
#if Off_t_size > IVSIZE
PP(pp_ftmtime)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
RETURN;
}
PP(pp_ftatime)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
RETURN;
}
PP(pp_ftctime)
{
- I32 result = my_stat();
+ I32 result;
dSP; dTARGET;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
RETURN;
}
PP(pp_ftsock)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISSOCK(PL_statcache.st_mode))
PP(pp_ftchr)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISCHR(PL_statcache.st_mode))
PP(pp_ftblk)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISBLK(PL_statcache.st_mode))
PP(pp_ftfile)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISREG(PL_statcache.st_mode))
PP(pp_ftdir)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISDIR(PL_statcache.st_mode))
PP(pp_ftpipe)
{
- I32 result = my_stat();
+ I32 result;
dSP;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
if (S_ISFIFO(PL_statcache.st_mode))
{
dSP;
#ifdef S_ISUID
- I32 result = my_stat();
+ I32 result;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
dSP;
#ifdef S_ISGID
- I32 result = my_stat();
+ I32 result;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
dSP;
#ifdef S_ISVTX
- I32 result = my_stat();
+ I32 result;
+ STACKED_FTEST_CHECK;
+ result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
char *tmps = Nullch;
STRLEN n_a;
+ STACKED_FTEST_CHECK;
+
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
else if (isGV(TOPs))
STRLEN n_a;
PerlIO *fp;
+ STACKED_FTEST_CHECK;
+
if (PL_op->op_flags & OPf_REF)
gv = cGVOP_gv;
else if (isGV(TOPs))
PP(pp_readdir)
{
-#if defined(Direntry_t) && defined(HAS_READDIR)
- dSP;
+#if !defined(Direntry_t) || !defined(HAS_READDIR)
+ DIE(aTHX_ PL_no_dir_func, "readdir");
+#else
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
+ dSP;
+
+ SV *sv;
+ I32 gimme = GIMME;
+ GV *gv = (GV *)POPs;
register Direntry_t *dp;
- GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
- SV *sv;
if (!io || !IoDIRP(io))
goto nope;
- if (GIMME == G_ARRAY) {
- /*SUPPRESS 560*/
- while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
-#ifdef DIRNAMLEN
- sv = newSVpvn(dp->d_name, dp->d_namlen);
-#else
- sv = newSVpv(dp->d_name, 0);
-#endif
-#ifndef INCOMPLETE_TAINTS
- if (!(IoFLAGS(io) & IOf_UNTAINT))
- SvTAINTED_on(sv);
-#endif
- XPUSHs(sv_2mortal(sv));
- }
- }
- else {
- if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
- goto nope;
+ do {
+ dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
+ if (!dp)
+ break;
#ifdef DIRNAMLEN
- sv = newSVpvn(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
- sv = newSVpv(dp->d_name, 0);
+ sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
- if (!(IoFLAGS(io) & IOf_UNTAINT))
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
- XPUSHs(sv_2mortal(sv));
+ XPUSHs(sv_2mortal(sv));
}
+ while (gimme == G_ARRAY);
+
+ if (!dp && gimme != G_ARRAY)
+ goto nope;
+
RETURN;
nope:
RETURN;
else
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_dir_func, "readdir");
#endif
}
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
dSP; dTARGET;
- Pid_t childpid;
+ Pid_t pid;
+ Pid_t result;
int optype;
int argflags;
optype = POPi;
- childpid = TOPi;
+ pid = TOPi;
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
- childpid = wait4pid(childpid, &argflags, optype);
+ result = wait4pid(pid, &argflags, optype);
else {
- while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 &&
+ while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
errno == EINTR) {
PERL_ASYNC_CHECK();
}
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
- STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
+ STATUS_NATIVE_SET((result && result != -1) ? argflags : -1);
# else
- STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ STATUS_NATIVE_SET((result > 0) ? argflags : -1);
# endif
- SETi(childpid);
+ SETi(result);
RETURN;
#else
DIE(aTHX_ PL_no_func, "waitpid");
}
RETURN;
#else
+# ifdef PERL_MICRO
+ dSP;
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ EXTEND(SP, 4);
+ if (GIMME == G_ARRAY) {
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ }
+ RETURN;
+# else
DIE(aTHX_ "times not implemented");
+# endif
#endif /* HAS_TIMES */
}
* AIX getpwnam() is clever enough to return the encrypted password
* only if the caller (euid?) is root.
*
- * There are at least two other shadow password APIs. Many platforms
+ * There are at least three other shadow password APIs. Many platforms
* seem to contain more than one interface for accessing the shadow
* password databases, possibly for compatibility reasons.
* The getsp*() is by far he simplest one, the other two interfaces
* char *(getespw*(...).ufld.fd_encrypt)
* Mention HAS_GETESPWNAM here so that Configure probes for it.
*
+ * <userpw.h> (AIX)
+ * struct userpw *getuserpw();
+ * The password is in
+ * char *(getuserpw(...)).spw_upw_passwd
+ * (but the de facto standard getpwnam() should work okay)
+ *
* Mention I_PROT here so that Configure probes for it.
*
* In HP-UX for getprpw*() the manual page claims that one should include
* --jhi
*/
+# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
+ /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
+ * the pw_comment is left uninitialized. */
+ PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
+# endif
+
switch (which) {
case OP_GPWNAM:
{
* Divert the urge to writing an extension instead.
*
* --jhi */
-# ifdef HAS_GETSPNAM
+ /* Some AIX setups falsely(?) detect some getspnam(), which
+ * has a different API than the Solaris/IRIX one. */
+# if defined(HAS_GETSPNAM) && !defined(_AIX)
{
struct spwd *spwent;
int saverrno; /* Save and restore errno so that
https://perl5.git.perl.org / perl5.git / blobdiff