pp_sys.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* pp_sys.c
*
* Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* But only a short way ahead its floor and the walls on either side were
* cloven by a great fissure, out of which the red glare came, now leaping
* up, now dying down into darkness; and all the while far below there was
* a rumour and a trouble as of great engines throbbing and labouring.
*/
#include "EXTERN.h"
#define PERL_IN_PP_SYS_C
#include "perl.h"
#ifdef I_SHADOW
/* Shadow password support for solaris - pdo@cs.umd.edu
* Not just Solaris: at least HP-UX, IRIX, Linux.
* The API is from SysV.
*
* There are at least two more shadow interfaces,
* see the comments in pp_gpwent().
*
* --jhi */
# ifdef __hpux__
/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
# endif
# include <shadow.h>
#endif
#ifdef HAS_SYSCALL
#ifdef __cplusplus
extern "C" int syscall(unsigned long,...);
#endif
#endif
#ifdef I_SYS_WAIT
#endif
#ifdef I_SYS_RESOURCE
# include <sys/resource.h>
#endif
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# endif
#endif
/* XXX Configure test needed.
h_errno might not be a simple 'int', especially for multi-threaded
applications, see "extern int errno in perl.h". Creating such
a test requires taking into account the differences between
compiling multithreaded and singlethreaded ($ccflags et al).
HOST_NOT_FOUND is typically defined in <netdb.h>.
*/
extern int h_errno;
#endif
#ifdef HAS_PASSWD
# ifdef I_PWD
# include <pwd.h>
# else
# endif
# ifdef HAS_GETPWENT
# endif
#endif
#ifdef HAS_GROUP
# ifdef I_GRP
# include <grp.h>
# else
# endif
# ifdef HAS_GETGRENT
# endif
#endif
#ifdef I_UTIME
# if defined(_MSC_VER) || defined(__MINGW32__)
# else
# include <utime.h>
# endif
#endif
/* Put this after #includes because fork and vfork prototypes may conflict. */
#ifndef HAS_VFORK
#endif
#ifdef HAS_CHSIZE
# endif
# define my_chsize PerlLIO_chsize
#endif
#ifdef HAS_FLOCK
#else /* no flock() */
/* fcntl.h might not have been included, even if it exists, because
the current Configure only sets I_FCNTL if it's needed to pick up
the *_OK constants. Make sure it has been included before testing
the fcntl() locking constants. */
# include <fcntl.h>
# endif
# 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,...) */
# ifdef FLOCK
static int FLOCK (int, int);
/*
* These are the flock() constants. Since this sytems doesn't have
* flock(), the values of the constants are probably not available.
*/
# ifndef LOCK_SH
# define LOCK_SH 1
# endif
# ifndef LOCK_EX
# define LOCK_EX 2
# endif
# ifndef LOCK_NB
# define LOCK_NB 4
# endif
# ifndef LOCK_UN
# define LOCK_UN 8
# endif
# endif /* emulating flock() */
#endif /* no flock() */
#define ZBTLEN 10
#if defined(I_SYS_ACCESS) && !defined(R_OK)
#endif
#endif
/* F_OK unused: if stat() cannot find it... */
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
/* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
#endif
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
# ifdef I_SYS_SECURITY
# include <sys/security.h>
# endif
# ifdef ACC_SELF
/* HP SecureWare */
# else
/* SCO */
# endif
#endif
/* AIX */
#endif
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
&& (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
|| defined(HAS_SETREGID) || defined(HAS_SETRESGID))
/* The Hard Way. */
STATIC int
{
int res;
#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
#else
#ifdef HAS_SETREUID
#else
#ifdef HAS_SETRESUID
#endif
#endif
#endif
#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
#else
#ifdef HAS_SETREGID
#else
#ifdef HAS_SETRESGID
#endif
#endif
#endif
#ifdef HAS_SETREUID
#else
#ifdef HAS_SETRESUID
#endif
#endif
#ifdef HAS_SETREGID
#else
#ifdef HAS_SETRESGID
#endif
#endif
return res;
}
#endif
#if !defined(PERL_EFF_ACCESS_R_OK)
STATIC int
{
/*NOTREACHED*/
return -1;
}
#endif
{
char *mode = "r";
TAINT_PROPER("``");
mode = "rb";
mode = "rt";
if (fp) {
char tmpbuf[256];
/*SUPPRESS 530*/
;
}
/*SUPPRESS 530*/
;
}
else {
for (;;) {
break;
}
}
}
}
TAINT; /* "I believe that this is not gratuitous!" */
}
else {
STATUS_NATIVE_SET(-1);
}
}
{
/* Note that we only ever get here if File::Glob fails to load
* without at the same time croaking, for some reason, or if
* perl was built with PERL_EXTERNAL_GLOB */
#ifndef VMS
if (PL_tainting) {
/*
* The external globbing program may use things we can't control,
* so for security reasons we must assume the worst.
*/
}
#endif /* !VMS */
#ifndef DOSISH
#ifndef CSH
#endif /* !CSH */
#endif /* !DOSISH */
result = do_readline();
return result;
}
#if 0 /* XXX never used! */
{
return do_readline();
}
#endif
{
return do_readline();
}
{
char *tmps;
}
else {
}
}
}
{
char *tmps;
bool multiarg = 0;
multiarg = 1;
}
else {
}
if (!multiarg)
else if (sv_isobject(error)) {
if (gv) {
}
}
}
else {
}
}
}
/* I/O. */
{
char *tmps;
if (MAXARG > 2) {
have_name = 1;
}
if (MAXARG > 1)
if (MAXARG <= 1)
if (have_name)
}
else if (PL_forkprocess == 0) /* we are a new child */
PUSHi(0);
else
}
{
dSP;
if (MAXARG == 0)
gv = PL_defoutgv;
else
}
}
{
dSP;
#ifdef HAS_PIPE
int fd[2];
goto badexit;
if (PerlProc_pipe(fd) < 0)
goto badexit;
else PerlLIO_close(fd[0]);
goto badexit;
}
#endif
#else
#endif
}
{
if (MAXARG < 1)
}
}
{
#ifdef HAS_UMASK
if (MAXARG < 1) {
anum = PerlLIO_umask(0);
(void)PerlLIO_umask(anum);
}
else
TAINT_PROPER("umask");
#else
/* Only DIE if trying to restrict permissions on `user' (self).
* Otherwise it's harmless and more useful to just return undef
* since 'group' and 'other' concepts probably don't exist here. */
#endif
}
{
dSP;
if (MAXARG < 1)
if (MAXARG > 1)
if (discp)
}
else
}
{
dSP;
char *methname;
int how = 'P';
case SVt_PVHV:
methname = "TIEHASH";
break;
case SVt_PVAV:
methname = "TIEARRAY";
break;
case SVt_PVGV:
methname = "TIEHANDLE";
how = 'q';
break;
default:
methname = "TIESCALAR";
how = 'q';
break;
}
if (sv_isobject(*MARK)) {
while (items--)
}
else {
/* Not clear why we don't call call_method here too.
* perhaps to get different error message ?
*/
}
while (items--)
}
if (sv_isobject(sv)) {
}
}
{
dSP;
}
else if (ckWARN(WARN_UNTIE)) {
}
}
}
{
dSP;
}
}
{
dSP;
require_pv("AnyDBM_File.pm");
}
else
if (!sv_isobject(TOPs)) {
SP--;
}
if (sv_isobject(TOPs)) {
}
}
{
return pp_untie();
}
{
#ifdef HAS_SELECT
register I32 i;
register I32 j;
register char *s;
char *fd_sets[4];
I32 k;
# if BYTEORDER & 0xf0000
# else
# endif
#endif
SP -= 4;
for (i = 1; i <= 3; i++) {
continue;
if (maxlen < j)
maxlen = j;
}
/* little endians can use vecs directly */
# if SELECT_MIN_BITS > 1
/* 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
# else
# endif
# else
# ifdef NFDBITS
# ifndef NBBY
# define NBBY 8
# endif
# else
masksize = sizeof(long); /* documented int, everyone seems to use long */
# endif
#endif
if (value < 0.0)
value = 0.0;
}
else
for (i = 1; i <= 3; i++) {
fd_sets[i] = 0;
continue;
}
if (j < growsize) {
}
while (++j <= growsize) {
*s++ = '\0';
}
}
#else
#endif
}
maxlen * 8,
tbuf);
for (i = 1; i <= 3; i++) {
if (fd_sets[i]) {
}
#endif
SvSETMAGIC(sv);
}
}
}
#else
#endif
}
void
{
if (gv)
(void)SvREFCNT_inc(gv);
if (PL_defoutgv)
PL_defoutgv = gv;
}
{
if (!egv)
egv = PL_defoutgv;
if (! hv)
else {
}
else {
}
}
if (newdefout) {
}
}
{
if (MAXARG == 0)
gv = PL_stdingv;
else
}
}
{
return pp_sysread();
}
{
register PERL_CONTEXT *cx;
PUSHFORMAT(cx);
}
{
dSP;
if (MAXARG == 0)
gv = PL_defoutgv;
else {
if (!gv)
gv = PL_defoutgv;
}
if (!io) {
}
else
if (!cv) {
if (fgv) {
}
}
}
{
dSP;
register PERL_CONTEXT *cx;
{
if (!IoTOP_NAME(io)) {
if (!IoFMT_NAME(io))
else
}
goto forget_top;
}
}
char *s = SvPVX(PL_formtarget);
if (lines <= 0) /* Yow, header didn't even fit!!! */
goto forget_top;
while (lines-- > 0) {
s = strchr(s, '\n');
if (!s)
break;
s++;
}
if (s) {
sv_chop(PL_formtarget, s);
}
}
if (!fgv)
{
if (!cv) {
}
/* why no:
else
DIE(aTHX_ "Undefined top format called");
?*/
}
}
if (!fp) {
/* integrate with report_evil_fh()? */
}
"Filehandle %s opened only for input", name);
else
"Filehandle opened only for input");
}
else if (ckWARN(WARN_CLOSED))
}
}
else {
}
else {
FmLINES(PL_formtarget) = 0;
SvCUR_set(PL_formtarget, 0);
(void)PerlIO_flush(fp);
}
}
return pop_return();
}
{
else
gv = PL_defoutgv;
++MARK;
++SP;
}
}
goto just_say_no;
}
/* integrate with report_evil_fh()? */
}
"Filehandle %s opened only for input", name);
else
"Filehandle opened only for input");
}
else if (ckWARN(WARN_CLOSED))
}
goto just_say_no;
}
else {
goto just_say_no;
goto just_say_no;
}
PUSHs(&PL_sv_undef);
}
{
dSP;
char *tmps;
if (MAXARG > 3)
else
perm = 0666;
/* Need TIEHANDLE method ? */
}
else {
PUSHs(&PL_sv_undef);
}
}
{
int offset;
char *buffer;
{
}
if (!gv)
goto say_undef;
if (length < 0)
SETERRNO(0,0);
else
offset = 0;
goto say_undef;
#ifdef HAS_SOCKET
char namebuf[MAXPATHLEN];
bufsize = sizeof (struct sockaddr_in);
#else
#endif
#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
if (bufsize >= 256)
bufsize = 255;
#endif
/* 'offset' means 'flags' here */
if (length < 0)
#ifdef EPOC
/* Bogus return without padding */
bufsize = sizeof (struct sockaddr_in);
#endif
(void)SvPOK_only(bufsv);
/* This should not be marked tainted if the fp is marked clean */
}
#else
#endif
if (offset < 0) {
}
}
#ifdef PERL_SOCK_SYSREAD_IS_RECV
}
else
#endif
{
}
}
else
#ifdef HAS_SOCKET__bad_code_maybe
char namebuf[MAXPATHLEN];
#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
bufsize = sizeof (struct sockaddr_in);
#else
#endif
}
else
#endif
{
/* fread() returns 0 on both error and EOF */
length = -1;
}
if (length < 0) {
{
/* integrate with report_evil_fh()? */
}
"Filehandle %s opened only for output", name);
else
"Filehandle opened only for output");
}
goto say_undef;
}
(void)SvPOK_only(bufsv);
/* This should not be marked tainted if the fp is marked clean */
}
{
dSP;
if (items == 2) {
}
return pp_send();
}
{
char *buffer;
}
if (!gv)
goto say_undef;
#if Size_t_size > IVSIZE
#else
#endif
SETERRNO(0,0);
retval = -1;
if (ckWARN(WARN_CLOSED))
}
if (offset < 0) {
} else
offset = 0;
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
}
else
#endif
{
/* See the note at doio.c:do_print about filesize limits. --jhi */
}
}
#ifdef HAS_SOCKET
char *sockbuf;
}
else
#else
else
#endif
if (retval < 0)
goto say_undef;
#if Size_t_size > IVSIZE
#else
#endif
}
{
return pp_sysread();
}
{
dSP;
if (MAXARG == 0) {
}
}
}
else
}
else
}
}
{
if (MAXARG == 0)
gv = PL_last_in_gv;
else
}
#else
#endif
}
{
return pp_sysseek();
}
{
dSP;
#else
#endif
#else
#endif
}
else {
if (sought < 0)
PUSHs(&PL_sv_undef);
else {
#else
#endif
}
}
}
{
dSP;
/* There seems to be no consensus on the length type of truncate()
* and ftruncate(), both off_t and size_t have supporters. In
* general one would think that when using large files, off_t is
* at least as wide as size_t, so using an off_t should be okay. */
/* XXX Configure probe for the length type of *truncate() needed XXX */
int result = 1;
#if Size_t_size > IVSIZE
#else
#endif
/* Checking for length < 0 is problematic as the type might or
* might not be signed: if it is not, clever compilers will moan. */
/* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
TAINT_PROPER("truncate");
result = 0;
else {
#ifdef HAS_TRUNCATE
#else
#endif
result = 0;
}
}
else {
char *name;
goto do_ftruncate;
}
goto do_ftruncate;
}
TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
result = 0;
#else
{
int tmpfd;
result = 0;
else {
result = 0;
}
}
#endif
}
if (result)
if (!errno)
#else
#endif
}
{
return pp_ioctl();
}
{
char *s;
}
}
}
else {
}
#ifdef HAS_IOCTL
#else
#endif
else
#ifdef HAS_FCNTL
#else
#endif
#else
#endif
PL_op_name[optype]);
}
if (retval == -1)
if (retval != 0) {
}
else {
}
}
{
int argtype;
#ifdef FLOCK
if (MAXARG == 0)
gv = PL_last_in_gv;
else
else {
}
if (fp) {
(void)PerlIO_flush(fp);
}
else {
value = 0;
}
#else
#endif
}
/* Sockets. */
{
dSP;
#ifdef HAS_SOCKET
int fd;
if (!gv) {
}
TAINT_PROPER("socket");
if (fd < 0)
}
#endif
#ifdef EPOC
#endif
#else
#endif
}
{
dSP;
#ifdef HAS_SOCKETPAIR
int fd[2];
TAINT_PROPER("socketpair");
}
#endif
#else
#endif
}
{
dSP;
#ifdef HAS_SOCKET
#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
extern GETPRIVMODE();
extern GETUSERMODE();
#endif
char *addr;
int bind_ok = 0;
#ifdef MPE
int mpeprivmode = 0;
#endif
goto nuts;
TAINT_PROPER("bind");
#ifdef MPE /* Deal with MPE bind() peculiarities */
/* The address *MUST* stupidly be zero. */
/* PRIV mode is required to bind() to ports < 1024. */
GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
mpeprivmode = 1;
}
}
#endif /* MPE */
bind_ok = 1;
#ifdef MPE /* Switch back to USER mode */
if (mpeprivmode)
GETUSERMODE();
#endif /* MPE */
if (bind_ok)
else
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
{
dSP;
#ifdef HAS_SOCKET
char *addr;
goto nuts;
TAINT_PROPER("connect");
else
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
{
dSP;
#ifdef HAS_SOCKET
goto nuts;
else
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
{
#ifdef HAS_SOCKET
int fd;
if (!ngv)
goto badexit;
if (!ggv)
goto nuts;
goto nuts;
if (fd < 0)
goto badexit;
goto badexit;
}
#endif
#ifdef EPOC
#endif
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
{
#ifdef HAS_SOCKET
goto nuts;
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
{
#ifdef HAS_SOCKET
return pp_ssockopt();
#else
#endif
}
{
dSP;
#ifdef HAS_SOCKET
int fd;
unsigned int optname;
unsigned int lvl;
if (optype == OP_GSOCKOPT)
else
goto nuts;
switch (optype) {
case OP_GSOCKOPT:
(void)SvPOK_only(sv);
goto nuts2;
break;
case OP_SSOCKOPT: {
char *buf;
int aint;
STRLEN l;
len = l;
}
else {
len = sizeof(int);
}
goto nuts2;
}
break;
}
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
{
#ifdef HAS_SOCKET
return pp_getpeername();
#else
#endif
}
{
dSP;
#ifdef HAS_SOCKET
int fd;
goto nuts;
(void)SvPOK_only(sv);
len = 256;
switch (optype) {
case OP_GETSOCKNAME:
goto nuts2;
break;
case OP_GETPEERNAME:
goto nuts2;
#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
{
static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
goto nuts2;
}
}
#endif
break;
}
#ifdef BOGUS_GETNAME_RETURN
/* Interactive Unix, getpeername() and getsockname()
does not return valid namelen */
if (len == BOGUS_GETNAME_RETURN)
#endif
nuts:
if (ckWARN(WARN_CLOSED))
#else
#endif
}
/* Stat calls. */
{
return pp_stat();
}
{
dSP;
}
if (PL_laststatval < 0) {
max = 0;
}
}
else {
goto do_fstat;
}
goto do_fstat;
}
#ifdef HAS_LSTAT
else
#endif
if (PL_laststatval < 0) {
max = 0;
}
}
}
if (max) {
#if Uid_t_size > IVSIZE
#else
# if Uid_t_sign <= 0
# else
# endif
#endif
#if Gid_t_size > IVSIZE
#else
# if Gid_t_sign <= 0
# else
# endif
#endif
#ifdef USE_STAT_RDEV
#else
#endif
#if Off_t_size > IVSIZE
#else
#endif
#ifdef BIG_TIME
#else
#endif
#ifdef USE_STAT_BLOCKS
#else
#endif
}
}
{
dSP;
#if defined(HAS_ACCESS) && defined(R_OK)
if (result == 0)
if (result < 0)
}
else
#else
#endif
if (result < 0)
}
{
dSP;
#if defined(HAS_ACCESS) && defined(W_OK)
if (result == 0)
if (result < 0)
}
else
#else
#endif
if (result < 0)
}
{
dSP;
#if defined(HAS_ACCESS) && defined(X_OK)
if (result == 0)
if (result < 0)
}
else
#else
#endif
if (result < 0)
}
{
dSP;
#ifdef PERL_EFF_ACCESS_R_OK
if (result == 0)
if (result < 0)
}
else
#else
#endif
if (result < 0)
}
{
dSP;
#ifdef PERL_EFF_ACCESS_W_OK
if (result == 0)
if (result < 0)
}
else
#else
#endif
if (result < 0)
}
{
dSP;
#ifdef PERL_EFF_ACCESS_X_OK
if (result == 0)
if (result < 0)
}
else
#else
#endif
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
return pp_ftrowned();
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
if (PL_statcache.st_size == 0)
}
{
if (result < 0)
#if Off_t_size > IVSIZE
#else
#endif
}
{
if (result < 0)
}
{
if (result < 0)
}
{
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
if (result < 0)
}
{
dSP;
#ifdef S_ISUID
if (result < 0)
#endif
}
{
dSP;
#ifdef S_ISGID
if (result < 0)
#endif
}
{
dSP;
#ifdef S_ISVTX
if (result < 0)
#endif
}
{
dSP;
int fd;
else
else
if (PerlLIO_isatty(fd))
}
#if defined(atarist) /* this will work with atariST. Configure will
make guesses for other systems. */
#endif
{
dSP;
I32 i;
register STDCHAR *s;
else
if (gv) {
if (PL_statgv)
else {
sv = PL_statname;
goto really_filename;
}
}
else {
PL_laststatval = -1;
}
if (PL_laststatval < 0)
else
if (i != EOF)
}
/* sfio can have large buffers - limit to 512 */
if (len > 512)
len = 512;
}
else {
}
}
}
else {
PL_laststatval = -1;
}
if (PL_laststatval < 0) {
(void)PerlIO_close(fp);
}
(void)PerlIO_close(fp);
if (len <= 0) {
RETPUSHNO; /* special case NFS directories */
RETPUSHYES; /* null file is anything */
}
s = tbuf;
}
/* now scan s to look for textiness */
/* XXX ASCII dependent code */
#if defined(DOSISH) || defined(USEMYBINMODE)
/* ignore trailing ^Z on short files */
--len;
#endif
for (i = 0; i < len; i++, s++) {
if (!*s) { /* null never allowed in text */
break;
}
#ifdef EBCDIC
odd++;
#else
else if (*s & 128) {
#ifdef USE_LOCALE
if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
continue;
#endif
/* utf8 characters don't count as odd */
if (UTF8_IS_START(*s)) {
int j;
for (j = 1; j < ulen; j++) {
if (!UTF8_IS_CONTINUATION(s[j]))
goto not_utf8;
}
--ulen; /* loop does extra increment */
s += ulen;
i += ulen;
continue;
}
}
odd++;
}
else if (*s < 32 &&
*s != '\n' && *s != '\r' && *s != '\b' &&
*s != '\t' && *s != '\f' && *s != 27)
odd++;
#endif
}
else
}
{
return pp_fttext();
}
/* File calls. */
{
char *tmps;
if (MAXARG < 1)
else
if (svp)
}
if (svp)
}
#ifdef VMS
if (svp)
}
#endif
TAINT_PROPER("chdir");
#ifdef VMS
/* Clear the DEFAULT element of ENV so we'll get the new value
* in the future. */
#endif
}
{
#ifdef HAS_CHOWN
#else
#endif
}
{
char *tmps;
#ifdef HAS_CHROOT
TAINT_PROPER("chroot");
#else
#endif
}
{
}
{
}
{
}
{
int anum;
TAINT_PROPER("rename");
#ifdef HAS_RENAME
#else
anum = 1;
else {
}
}
#endif
}
{
#ifdef HAS_LINK
TAINT_PROPER("link");
#else
#endif
}
{
#ifdef HAS_SYMLINK
TAINT_PROPER("symlink");
#else
#endif
}
{
#ifdef HAS_SYMLINK
char *tmps;
char buf[MAXPATHLEN];
int len;
#ifndef INCOMPLETE_TAINTS
#endif
if (len < 0)
#else
RETSETUNDEF; /* just pretend it's a normal file */
#endif
}
STATIC int
{
char *save_filename = filename;
char *cmdline;
char *s;
int anum = 1;
*s++ = '\\';
*s++ = *filename++;
}
strcpy(s, " 2>&1");
if (myfp) {
(void)PerlProc_pclose(myfp);
if (s != Nullch) {
int e;
for (e = 1;
#ifdef HAS_SYS_ERRLIST
e <= sys_nerr
#endif
; e++)
{
/* you don't see this */
char *errmsg =
#ifdef HAS_SYS_ERRLIST
sys_errlist[e]
#else
strerror(e)
#endif
;
if (!errmsg)
break;
SETERRNO(e,0);
return 0;
}
}
SETERRNO(0,0);
#ifndef EACCES
#endif
if (instr(s, "cannot make"))
else if (instr(s, "existing file"))
else if (instr(s, "ile exists"))
else if (instr(s, "non-exist"))
else if (instr(s, "does not exist"))
else if (instr(s, "not empty"))
else if (instr(s, "cannot access"))
else
return 0;
}
else { /* some mkdirs return no failure indication */
if (anum)
SETERRNO(0,0);
else
}
return anum;
}
else
return 0;
}
#endif
{
int mode;
#ifndef HAS_MKDIR
int oldumask;
#endif
char *tmps;
if (MAXARG > 1)
else
mode = 0777;
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
#else
oldumask = PerlLIO_umask(0);
#endif
}
{
char *tmps;
TAINT_PROPER("rmdir");
#ifdef HAS_RMDIR
#else
#endif
}
/* Directory calls. */
{
dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
if (!io)
goto nope;
goto nope;
nope:
if (!errno)
#else
#endif
}
{
dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
#ifndef I_DIRENT
#endif
register Direntry_t *dp;
goto nope;
/*SUPPRESS 560*/
#ifdef DIRNAMLEN
#else
#endif
#ifndef INCOMPLETE_TAINTS
#endif
}
}
else {
goto nope;
#ifdef DIRNAMLEN
#else
#endif
#ifndef INCOMPLETE_TAINTS
#endif
}
nope:
if (!errno)
else
#else
#endif
}
{
#if defined(HAS_TELLDIR) || defined(telldir)
/* XXX does _anyone_ need this? --AD 2/20/1998 */
/* XXX netbsd still seemed to.
XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
--JHI 1999-Feb-02 */
# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
# endif
goto nope;
nope:
if (!errno)
#else
#endif
}
{
dSP;
#if defined(HAS_SEEKDIR) || defined(seekdir)
goto nope;
nope:
if (!errno)
#else
#endif
}
{
dSP;
#if defined(HAS_REWINDDIR) || defined(rewinddir)
goto nope;
nope:
if (!errno)
#else
#endif
}
{
dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
goto nope;
#ifdef VOID_CLOSEDIR
#else
goto nope;
}
#endif
nope:
if (!errno)
#else
#endif
}
/* Process control. */
{
#ifdef HAS_FORK
if (childpid < 0)
if (!childpid) {
/*SUPPRESS 560*/
}
#else
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
childpid = PerlProc_fork();
if (childpid == -1)
# else
# endif
#endif
}
{
int argflags;
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
# else
# endif
#else
#endif
}
{
int optype;
int argflags;
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
# else
# endif
#else
#endif
}
{
int result;
int status;
int pp[2];
if (PL_tainting) {
TAINT_ENV();
TAINT_PROPER("system");
}
}
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__)
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
value = -1;
if (did_pipes) {
PerlLIO_close(pp[0]);
}
}
sleep(5);
}
if (childpid > 0) {
if (did_pipes)
do {
do_execfree(); /* free any memory child malloced on vfork */
if (did_pipes) {
int errkid;
int n = 0, n1;
while (n < sizeof(int)) {
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
break;
n += n1;
}
PerlLIO_close(pp[0]);
if (n) { /* Error */
if (n != sizeof(int))
STATUS_CURRENT = -1;
}
}
}
if (did_pipes) {
PerlLIO_close(pp[0]);
#endif
}
}
else {
}
PerlProc__exit(-1);
#else /* ! FORK or VMS or OS/2 */
PL_statusvalue = 0;
result = 0;
}
else {
}
result = 1;
do_execfree();
#endif /* !FORK or VMS */
}
{
}
#ifdef VMS
#else
# ifdef __OPEN_VM
{
value = 0;
}
# else
# endif
#endif
else {
if (PL_tainting) {
TAINT_ENV();
TAINT_PROPER("exec");
}
#ifdef VMS
#else
# ifdef __OPEN_VM
value = 0;
# else
# endif
#endif
}
if (value >= 0)
#endif
}
{
#ifdef HAS_KILL
#else
#endif
}
{
#ifdef HAS_GETPPID
#else
#endif
}
{
#ifdef HAS_GETPGRP
if (MAXARG < 1)
pid = 0;
else
#ifdef BSD_GETPGRP
#else
#endif
#else
#endif
}
{
#ifdef HAS_SETPGRP
if (MAXARG < 2) {
pgrp = 0;
pid = 0;
}
else {
}
TAINT_PROPER("setpgrp");
#ifdef BSD_SETPGRP
#else
{
}
#endif /* USE_BSDPGRP */
#else
#endif
}
{
int which;
int who;
#ifdef HAS_GETPRIORITY
#else
#endif
}
{
int which;
int who;
int niceval;
#ifdef HAS_SETPRIORITY
TAINT_PROPER("setpriority");
#else
#endif
}
/* Time calls. */
{
#ifdef BIG_TIME
#else
#endif
}
/* XXX The POSIX name is CLK_TCK; it is to be preferred
to HZ. Probably. For now, assume that if the system
defines HZ, it does so correctly. (Will this break
on VMS?)
Probably we ought to use _sysconf(_SC_CLK_TCK), if
it's supported. --AD 9/96.
*/
#ifndef HZ
# ifdef CLK_TCK
# else
# define HZ 60
# endif
#endif
{
dSP;
#ifndef HAS_TIMES
#else
#ifndef VMS
(void)PerlProc_times(&PL_timesbuf);
#else
/* struct tms, though same data */
/* is returned. */
#endif
}
#endif /* HAS_TIMES */
}
{
return pp_gmtime();
}
{
dSP;
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
if (MAXARG < 1)
else
#ifdef BIG_TIME
#else
#endif
else
EXTEND_MORTAL(9);
if (!tmbuf)
}
else if (tmbuf) {
}
}
{
int anum;
#ifdef HAS_ALARM
if (anum < 0)
#else
#endif
}
{
if (MAXARG < 1)
else {
PerlProc_sleep((unsigned int)duration);
}
}
/* Shared memory. */
{
return pp_semget();
}
{
return pp_semctl();
}
{
return pp_shmwrite();
}
{
#else
return pp_semget();
#endif
}
/* Message passing. */
{
return pp_semget();
}
{
return pp_semctl();
}
{
#else
return pp_semget();
#endif
}
{
#else
return pp_semget();
#endif
}
/* Semaphores. */
{
if (anum == -1)
#else
#endif
}
{
if (anum == -1)
if (anum != 0) {
}
else {
}
#else
return pp_semget();
#endif
}
{
#else
return pp_semget();
#endif
}
/* Get system info. */
{
#ifdef HAS_GETHOSTBYNAME
return pp_ghostent();
#else
#endif
}
{
#ifdef HAS_GETHOSTBYADDR
return pp_ghostent();
#else
#endif
}
{
dSP;
register char **elem;
#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
struct hostent *PerlSock_gethostent(void);
#endif
unsigned long len;
if (which == OP_GHBYNAME)
#ifdef HAS_GETHOSTBYNAME
#else
#endif
else if (which == OP_GHBYADDR) {
#ifdef HAS_GETHOSTBYADDR
#else
#endif
}
else
#ifdef HAS_GETHOSTENT
hent = PerlSock_gethostent();
#else
#endif
#ifdef HOST_NOT_FOUND
if (!hent)
#endif
if (hent) {
if (which == OP_GHBYNAME) {
}
else
}
}
if (hent) {
if (elem[1])
}
#ifdef h_addr
}
#else
#endif /* h_addr */
}
#else
#endif
}
{
#ifdef HAS_GETNETBYNAME
return pp_gnetent();
#else
#endif
}
{
#ifdef HAS_GETNETBYADDR
return pp_gnetent();
#else
#endif
}
{
dSP;
register char **elem;
#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
struct netent *PerlSock_getnetent(void);
#endif
if (which == OP_GNBYNAME)
#ifdef HAS_GETNETBYNAME
#else
#endif
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
#else
#endif
}
else
#ifdef HAS_GETNETENT
nent = PerlSock_getnetent();
#else
#endif
if (nent) {
if (which == OP_GNBYNAME)
else
}
}
if (nent) {
if (elem[1])
}
}
#else
#endif
}
{
#ifdef HAS_GETPROTOBYNAME
return pp_gprotoent();
#else
#endif
}
{
#ifdef HAS_GETPROTOBYNUMBER
return pp_gprotoent();
#else
#endif
}
{
dSP;
register char **elem;
#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
struct protoent *PerlSock_getprotobynumber(int);
struct protoent *PerlSock_getprotoent(void);
#endif
if (which == OP_GPBYNAME)
#ifdef HAS_GETPROTOBYNAME
#else
#endif
else if (which == OP_GPBYNUMBER)
#ifdef HAS_GETPROTOBYNUMBER
#else
#endif
else
#ifdef HAS_GETPROTOENT
pent = PerlSock_getprotoent();
#else
#endif
if (pent) {
if (which == OP_GPBYNAME)
else
}
}
if (pent) {
if (elem[1])
}
}
#else
#endif
}
{
#ifdef HAS_GETSERVBYNAME
return pp_gservent();
#else
#endif
}
{
#ifdef HAS_GETSERVBYPORT
return pp_gservent();
#else
#endif
}
{
dSP;
register char **elem;
#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
struct servent *PerlSock_getservent(void);
#endif
if (which == OP_GSBYNAME) {
#ifdef HAS_GETSERVBYNAME
#else
#endif
}
else if (which == OP_GSBYPORT) {
#ifdef HAS_GETSERVBYPORT
#ifdef HAS_HTONS
#endif
#else
#endif
}
else
#ifdef HAS_GETSERVENT
sent = PerlSock_getservent();
#else
#endif
if (sent) {
if (which == OP_GSBYNAME) {
#ifdef HAS_NTOHS
#else
#endif
}
else
}
}
if (sent) {
if (elem[1])
}
#ifdef HAS_NTOHS
#else
#endif
}
#else
#endif
}
{
dSP;
#ifdef HAS_SETHOSTENT
#else
#endif
}
{
dSP;
#ifdef HAS_SETNETENT
#else
#endif
}
{
dSP;
#ifdef HAS_SETPROTOENT
#else
#endif
}
{
dSP;
#ifdef HAS_SETSERVENT
#else
#endif
}
{
dSP;
#ifdef HAS_ENDHOSTENT
#else
#endif
}
{
dSP;
#ifdef HAS_ENDNETENT
#else
#endif
}
{
dSP;
#ifdef HAS_ENDPROTOENT
#else
#endif
}
{
dSP;
#ifdef HAS_ENDSERVENT
#else
#endif
}
{
#ifdef HAS_PASSWD
return pp_gpwent();
#else
#endif
}
{
#ifdef HAS_PASSWD
return pp_gpwent();
#else
#endif
}
{
dSP;
#ifdef HAS_PASSWD
/*
* We currently support only the SysV getsp* shadow password interface.
* The interface is declared in <shadow.h> and often one needs to link
* with -lsecurity or some such.
* This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
* (and SCO?)
*
* 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
* 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
* are much more complicated, but also very similar to each other.
*
* <sys/security.h>
* <prot.h>
* struct pr_passwd *getprpw*();
* The password is in
* char getprpw*(...).ufld.fd_encrypt[]
* Mention HAS_GETPRPWNAM here so that Configure probes for it.
*
* <sys/security.h>
* <prot.h>
* struct es_passwd *getespw*();
* The password is in
* char *(getespw*(...).ufld.fd_encrypt)
* Mention HAS_GETESPWNAM here so that Configure probes for it.
*
* Mention I_PROT here so that Configure probes for it.
*
* In HP-UX for getprpw*() the manual page claims that one should include
* <hpsecurity.h> instead of <sys/security.h>, but that is not needed
* if one includes <shadow.h> as that includes <hpsecurity.h>,
*
* Note that <sys/security.h> is already probed for, but currently
* it is only included in special cases.
*
* be preferred interface, even though also the getprpw*() interface
* is available) one needs to link with -lsecurity -ldb -laud -lm.
* One also needs to call set_auth_parameters() in main() before
* doing anything else, whether one is using getespw*() or getprpw*().
*
* Note that accessing the shadow databases can be magnitudes
* slower than accessing the standard databases.
*
* --jhi
*/
switch (which) {
case OP_GPWNAM:
break;
case OP_GPWUID:
break;
case OP_GPWENT:
# ifdef HAS_GETPWENT
# else
# endif
break;
}
if (pwent) {
# if Uid_t_sign <= 0
# else
# endif
else
}
}
if (pwent) {
/* If we have getspnam(), we try to dig up the shadow
* password. If we are underprivileged, the shadow
* interface will set the errno to EACCES or similar,
* and return a null pointer. If this happens, we will
* use the dummy password (usually "*" or "x") from the
* standard password database.
*
* In theory we could skip the shadow call completely
* if euid != 0 but in practice we cannot know which
* security measures are guarding the shadow databases
* on a random platform.
*
* Resist the urge to use additional shadow interfaces.
* Divert the urge to writing an extension instead.
*
* --jhi */
# ifdef HAS_GETSPNAM
{
int saverrno; /* Save and restore errno so that
* underprivileged attempts seem
* to have never made the unsccessful
* attempt to retrieve the shadow password. */
}
# endif
# ifdef PWPASSWD
# 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. */
# endif
# if Uid_t_sign <= 0
# else
# endif
# if Uid_t_sign <= 0
# else
# 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.
* A better interface would have been to return a hash,
* but we are accursed by our history, alas. --jhi. */
# ifdef PWCHANGE
# else
# ifdef PWQUOTA
# else
# ifdef PWAGE
# 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
# else
# ifdef PWCOMMENT
# endif
# endif
# ifdef PWGECOS
# endif
# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
# endif
# ifndef INCOMPLETE_TAINTS
/* pw_shell is tainted because user himself can diddle with it. */
# endif
# ifdef PWEXPIRE
# endif
}
#else
#endif
}
{
dSP;
#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
setpwent();
#else
#endif
}
{
dSP;
#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
endpwent();
#else
#endif
}
{
#ifdef HAS_GROUP
return pp_ggrent();
#else
#endif
}
{
#ifdef HAS_GROUP
return pp_ggrent();
#else
#endif
}
{
dSP;
#ifdef HAS_GROUP
register char **elem;
else
#ifdef HAS_GETGRENT
#else
#endif
if (grent) {
else
}
}
if (grent) {
#ifdef GRPASSWD
#endif
if (elem[1])
}
}
#else
#endif
}
{
dSP;
#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
setgrent();
#else
#endif
}
{
dSP;
#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
endgrent();
#else
#endif
}
{
#ifdef HAS_GETLOGIN
char *tmps;
if (!(tmps = PerlProc_getlogin()))
#else
#endif
}
/* Miscellaneous. */
{
#ifdef HAS_SYSCALL
unsigned long a[20];
register I32 i = 0;
if (PL_tainting) {
break;
}
}
TAINT_PROPER("syscall");
}
/* This probably won't work on machines where sizeof(long) != sizeof(int)
* or where sizeof(long) != sizeof(char*). But such machines will
* not likely have syscall implemented either, so who cares?
*/
else if (*MARK == &PL_sv_undef)
a[i++] = 0;
else
if (i > 15)
break;
}
switch (items) {
default:
case 0:
case 1:
break;
case 2:
break;
case 3:
break;
case 4:
break;
case 5:
break;
case 6:
break;
case 7:
break;
case 8:
break;
#ifdef atarist
case 9:
break;
case 10:
break;
case 11:
a[10]);
break;
case 12:
a[10],a[11]);
break;
case 13:
a[10],a[11],a[12]);
break;
case 14:
a[10],a[11],a[12],a[13]);
break;
#endif /* atarist */
}
#else
#endif
}
#ifdef FCNTL_EMULATE_FLOCK
/* XXX Emulate flock() with fcntl().
What's really needed is a good file locking module.
*/
static int
{
case LOCK_SH:
break;
case LOCK_EX:
break;
case LOCK_UN:
break;
default:
return -1;
}
}
#endif /* FCNTL_EMULATE_FLOCK */
#ifdef LOCKF_EMULATE_FLOCK
/* XXX Emulate flock() with lockf(). This is just to increase
portability of scripts. The calls are not completely
interchangeable. What's really needed is a good file
locking module.
*/
/* The lockf() constants might have been defined in <unistd.h>.
Unfortunately, <unistd.h> causes troubles on some mixed
Further, the lockf() constants aren't POSIX, so they might not be
visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
just stick in the SVID values and be done with it. Sigh.
*/
# ifndef F_ULOCK
# define F_ULOCK 0 /* Unlock a previously locked region */
# endif
# ifndef F_LOCK
# endif
# ifndef F_TLOCK
# endif
# ifndef F_TEST
# endif
static int
{
int i;
int save_errno;
/* flock locks entire file so for lockf we need to do the same */
save_errno = errno;
if (pos > 0) /* is seekable and needs to be repositioned */
errno = save_errno;
switch (operation) {
/* LOCK_SH - get a shared lock */
case LOCK_SH:
/* LOCK_EX - get an exclusive lock */
case LOCK_EX:
break;
/* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
/* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
if (i == -1)
errno = EWOULDBLOCK;
break;
/* LOCK_UN - unlock (non-blocking is a no-op) */
case LOCK_UN:
break;
/* Default - can't decipher operation */
default:
i = -1;
break;
}
if (pos > 0) /* need to restore position of the handle */
return (i);
}
#endif /* LOCKF_EMULATE_FLOCK */