/* XXX Configure test needed.
h_errno might not be a simple 'int', especially for multi-threaded
- applications. HOST_NOT_FOUND is typically defined in <netdb.h>.
+ 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>.
*/
#if defined(HOST_NOT_FOUND) && !defined(h_errno)
extern int h_errno;
#define ZBTLEN 10
static char zero_but_true[ZBTLEN + 1] = "0 but true";
-/* Pushy I/O. */
+#if defined(I_SYS_ACCESS) && !defined(R_OK)
+# include <sys/access.h>
+#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
+
+/* 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 */
+# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
+# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
+# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
+/* HP SecureWare */
+# if defined(I_SYS_SECURITY)
+# include <sys/security.h>
+# endif
+# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
+/* AIX */
+# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
+#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
+emulate_eaccess (const char* path, int mode) {
+ Uid_t ruid = getuid();
+ Uid_t euid = geteuid();
+ Gid_t rgid = getgid();
+ Gid_t egid = getegid();
+ int res;
+
+ MUTEX_LOCK(&PL_cred_mutex);
+#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
+ croak("switching effective uid is not implemented");
+#else
+#ifdef HAS_SETREUID
+ if (setreuid(euid, ruid))
+#else
+#ifdef HAS_SETRESUID
+ if (setresuid(euid, ruid, (Uid_t)-1))
+#endif
+#endif
+ croak("entering effective uid failed");
+#endif
+
+#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
+ croak("switching effective gid is not implemented");
+#else
+#ifdef HAS_SETREGID
+ if (setregid(egid, rgid))
+#else
+#ifdef HAS_SETRESGID
+ if (setresgid(egid, rgid, (Gid_t)-1))
+#endif
+#endif
+ croak("entering effective gid failed");
+#endif
+
+ res = access(path, mode);
+
+#ifdef HAS_SETREUID
+ if (setreuid(ruid, euid))
+#else
+#ifdef HAS_SETRESUID
+ if (setresuid(ruid, euid, (Uid_t)-1))
+#endif
+#endif
+ croak("leaving effective uid failed");
+
+#ifdef HAS_SETREGID
+ if (setregid(rgid, egid))
+#else
+#ifdef HAS_SETRESGID
+ if (setresgid(rgid, egid, (Gid_t)-1))
+#endif
+#endif
+ croak("leaving effective gid failed");
+ MUTEX_UNLOCK(&PL_cred_mutex);
+
+ return res;
+}
+# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
+# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
+# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK)
+STATIC int
+emulate_eaccess (const char* path, int mode) {
+ croak("switching effective uid is not implemented");
+ /*NOTREACHED*/
+ return -1;
+}
+#endif
PP(pp_backtick)
{
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
tmps = SvPV(sv, len);
- if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
+ if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
PUSHi( (I32)PL_forkprocess );
else if (PL_forkprocess == 0) /* we are a new child */
PUSHi(0);
sv = POPs;
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- warn("untie attempted while %lu inner references still exist",
- (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ warner(WARN_UNTIE,
+ "untie attempted while %lu inner references still exist",
+ (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
maxlen = j;
}
+/* little endians can use vecs directly */
#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#if defined(__linux__) || defined(OS2)
+# if SELECT_MIN_BITS > 1
+ growsize = SELECT_MIN_BITS / 8;
+# else
growsize = sizeof(fd_set);
-#else
- growsize = maxlen; /* little endians can use vecs directly */
-#endif
-#else
-#ifdef NFDBITS
+# endif
+# else
+# ifdef NFDBITS
-#ifndef NBBY
-#define NBBY 8
-#endif
+# ifndef NBBY
+# define NBBY 8
+# endif
masksize = NFDBITS / NBBY;
-#else
+# else
masksize = sizeof(long); /* documented int, everyone seems to use long */
-#endif
+# endif
growsize = maxlen + (masksize - (maxlen % masksize));
Zero(&fd_sets[0], 4, char*);
#endif
fp = IoOFP(io);
if (!fp) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED,WARN_IO)) {
if (IoIFP(io))
- warn("Filehandle only opened for input");
- else
- warn("Write on closed filehandle");
+ warner(WARN_IO, "Filehandle only opened for input");
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "Write on closed filehandle");
}
PUSHs(&PL_sv_no);
}
else {
if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
- if (PL_dowarn)
- warn("page overflow");
+ if (ckWARN(WARN_IO))
+ warner(WARN_IO, "page overflow");
}
if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
PerlIO_error(fp))
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNOPENED)) {
gv_fullname3(sv, gv, Nullch);
- warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED,WARN_IO)) {
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
- else
- warn("printf on closed filehandle %s", SvPV(sv,PL_na));
+ warner(WARN_IO, "Filehandle %s opened only for input",
+ SvPV(sv,PL_na));
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "printf on closed filehandle %s",
+ SvPV(sv,PL_na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
io = GvIO(gv);
if (!io || !IoIFP(io)) {
length = -1;
- if (PL_dowarn) {
+ if (ckWARN(WARN_CLOSED)) {
if (PL_op->op_type == OP_SYSWRITE)
- warn("Syswrite on closed filehandle");
+ warner(WARN_CLOSED, "Syswrite on closed filehandle");
else
- warn("Send on closed socket");
+ warner(WARN_CLOSED, "Send on closed socket");
}
}
else if (PL_op->op_type == OP_SYSWRITE) {
djSP;
GV *gv;
int whence = POPi;
- long offset = POPl;
+ Off_t offset = POPl;
gv = PL_last_in_gv = (GV*)POPs;
if (PL_op->op_type == OP_SEEK)
PUSHs(boolSV(do_seek(gv, offset, whence)));
else {
- long n = do_sysseek(gv, offset, whence);
+ Off_t n = do_sysseek(gv, offset, whence);
PUSHs((n < 0) ? &PL_sv_undef
: sv_2mortal(n ? newSViv((IV)n)
: newSVpv(zero_but_true, ZBTLEN)));
RETPUSHUNDEF;
nuts:
- if (PL_dowarn)
- warn("bind() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "bind() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETPUSHUNDEF;
nuts:
- if (PL_dowarn)
- warn("connect() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "connect() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETPUSHUNDEF;
nuts:
- if (PL_dowarn)
- warn("listen() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "listen() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETURN;
nuts:
- if (PL_dowarn)
- warn("accept() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "accept() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
RETURN;
nuts:
- if (PL_dowarn)
- warn("shutdown() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "shutdown() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETURN;
nuts:
- if (PL_dowarn)
- warn("[gs]etsockopt() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
RETURN;
nuts:
- if (PL_dowarn)
- warn("get{sock, peer}name() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
#endif
PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
if (PL_laststatval < 0) {
- if (PL_dowarn && strchr(SvPV(PL_statname, PL_na), '\n'))
- warn(warn_nl, "stat");
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, PL_na), '\n'))
+ warner(WARN_NEWLINE, warn_nl, "stat");
max = 0;
}
}
PP(pp_ftrread)
{
- I32 result = my_stat(ARGS);
+ I32 result;
djSP;
+#if defined(HAS_ACCESS) && defined(R_OK)
+ if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
+ result = access(TOPp, R_OK);
+ if (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ } else
+ result = my_stat(ARGS);
+#else
+ result = my_stat(ARGS);
+#endif
if (result < 0)
RETPUSHUNDEF;
if (cando(S_IRUSR, 0, &PL_statcache))
PP(pp_ftrwrite)
{
- I32 result = my_stat(ARGS);
+ I32 result;
djSP;
+#if defined(HAS_ACCESS) && defined(W_OK)
+ if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
+ result = access(TOPp, W_OK);
+ if (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ } else
+ result = my_stat(ARGS);
+#else
+ result = my_stat(ARGS);
+#endif
if (result < 0)
RETPUSHUNDEF;
if (cando(S_IWUSR, 0, &PL_statcache))
PP(pp_ftrexec)
{
- I32 result = my_stat(ARGS);
+ I32 result;
djSP;
+#if defined(HAS_ACCESS) && defined(X_OK)
+ if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
+ result = access(TOPp, X_OK);
+ if (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ } else
+ result = my_stat(ARGS);
+#else
+ result = my_stat(ARGS);
+#endif
if (result < 0)
RETPUSHUNDEF;
if (cando(S_IXUSR, 0, &PL_statcache))
PP(pp_fteread)
{
- I32 result = my_stat(ARGS);
+ I32 result;
djSP;
+#ifdef PERL_EFF_ACCESS_R_OK
+ if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_R_OK(TOPp);
+ if (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ } else
+ result = my_stat(ARGS);
+#else
+ result = my_stat(ARGS);
+#endif
if (result < 0)
RETPUSHUNDEF;
if (cando(S_IRUSR, 1, &PL_statcache))
PP(pp_ftewrite)
{
- I32 result = my_stat(ARGS);
+ I32 result;
djSP;
+#ifdef PERL_EFF_ACCESS_W_OK
+ if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_W_OK(TOPp);
+ if (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ } else
+ result = my_stat(ARGS);
+#else
+ result = my_stat(ARGS);
+#endif
if (result < 0)
RETPUSHUNDEF;
if (cando(S_IWUSR, 1, &PL_statcache))
PP(pp_fteexec)
{
- I32 result = my_stat(ARGS);
+ I32 result;
djSP;
+#ifdef PERL_EFF_ACCESS_X_OK
+ if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_X_OK(TOPp);
+ if (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ } else
+ result = my_stat(ARGS);
+#else
+ result = my_stat(ARGS);
+#endif
if (result < 0)
RETPUSHUNDEF;
if (cando(S_IXUSR, 1, &PL_statcache))
len = 512;
}
else {
- if (PL_dowarn)
- warn("Test on unopened file <%s>",
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED, "Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
i = PerlLIO_open(SvPV(sv, PL_na), 0);
#endif
if (i < 0) {
- if (PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
- warn(warn_nl, "open");
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n'))
+ warner(WARN_NEWLINE, warn_nl, "open");
RETPUSHUNDEF;
}
PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
odd += len;
break;
}
+#ifdef EBCDIC
+ else if (!(isPRINT(*s) || isSPACE(*s)))
+ odd++;
+#else
else if (*s & 128)
odd++;
else if (*s < 32 &&
*s != '\n' && *s != '\r' && *s != '\b' &&
*s != '\t' && *s != '\f' && *s != 27)
odd++;
+#endif
}
if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
if (same_dirent(tmps2, tmps)) /* can always rename to same name */
anum = 1;
else {
- if (euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
+ if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
(void)UNLINK(tmps2);
if (!(anum = link(tmps, tmps2)))
anum = UNLINK(tmps);
projects / p5sagit/p5-mst-13.2.git / blobdiff