X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=8fa38f2860d8451c6765db9b13790b173dde3390;hb=91500cfd5c426b5ce4db817d5b64c763d5b8822b;hp=d16cd7e5f18dad681c7446f671e9fdeb8cb99ad2;hpb=5c08494a9097815fa21f0f73751af672efd9ed24;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index d16cd7e..8fa38f2 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -56,7 +56,10 @@ extern "C" int syscall(unsigned long,...); /* XXX Configure test needed. h_errno might not be a simple 'int', especially for multi-threaded - applications. HOST_NOT_FOUND is typically defined in . + 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 . */ #if defined(HOST_NOT_FOUND) && !defined(h_errno) extern int h_errno; @@ -181,7 +184,115 @@ static int dooneliner _((char *cmd, char *filename)); #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 +#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 +# 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) { @@ -239,6 +350,8 @@ PP(pp_backtick) PP(pp_glob) { OP *result; + tryAMAGICunTARGET(iter, -1); + ENTER; #ifndef VMS @@ -248,7 +361,7 @@ PP(pp_glob) * so for security reasons we must assume the worst. */ TAINT; - taint_proper(no_security, "glob"); + taint_proper(PL_no_security, "glob"); } #endif /* !VMS */ @@ -373,16 +486,16 @@ PP(pp_open) if (MAXARG > 1) sv = POPs; if (!isGV(TOPs)) - DIE(no_usym, "filehandle"); + DIE(PL_no_usym, "filehandle"); if (MAXARG <= 1) sv = GvSV(TOPs); gv = (GV*)POPs; if (!isGV(gv)) - DIE(no_usym, "filehandle"); + DIE(PL_no_usym, "filehandle"); 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); @@ -402,9 +515,9 @@ PP(pp_close) else gv = (GV*)POPs; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)gv, mg)); PUTBACK; ENTER; perl_call_method("CLOSE", G_SCALAR); @@ -434,7 +547,7 @@ PP(pp_pipe_op) goto badexit; if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV) - DIE(no_usym, "filehandle"); + DIE(PL_no_usym, "filehandle"); rstio = GvIOn(rgv); wstio = GvIOn(wgv); @@ -459,13 +572,16 @@ PP(pp_pipe_op) else PerlLIO_close(fd[1]); goto badexit; } - +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ + fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ +#endif RETPUSHYES; badexit: RETPUSHUNDEF; #else - DIE(no_func, "pipe"); + DIE(PL_no_func, "pipe"); #endif } @@ -596,8 +712,8 @@ PP(pp_tie) sv = TOPs; POPSTACK; if (sv_isobject(sv)) { - sv_unmagic(varsv, how); - sv_magic(varsv, sv, how, Nullch, 0); + sv_unmagic(varsv, how); + sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0); } LEAVE; SP = PL_stack_base + markoff; @@ -608,48 +724,36 @@ PP(pp_tie) PP(pp_untie) { djSP; - SV * sv ; - - sv = POPs; + SV *sv = POPs; + char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; - 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, 'P') ; - else - mg = mg_find(sv, 'q') ; - + if (mg = SvTIED_mg(sv, how)) { 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 ) ; } } - if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - sv_unmagic(sv, 'P'); - else - sv_unmagic(sv, 'q'); + sv_unmagic(sv, how); RETPUSHYES; } PP(pp_tied) { djSP; - SV * sv ; - MAGIC * mg ; + SV *sv = POPs; + char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; + MAGIC *mg; - sv = POPs; - if (SvMAGICAL(sv)) { - if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - mg = mg_find(sv, 'P') ; - else - mg = mg_find(sv, 'q') ; - - if (mg) { - PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ; - RETURN ; - } + if (mg = SvTIED_mg(sv, how)) { + SV *osv = SvTIED_obj(sv, mg); + if (osv == mg->mg_obj) + osv = sv_mortalcopy(osv); + PUSHs(osv); + RETURN; } RETPUSHUNDEF; } @@ -753,24 +857,29 @@ PP(pp_sselect) maxlen = j; } +/* little endians can use vecs directly */ #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 -/* XXX Configure test needed. */ -#if defined(__linux__) || defined(OS2) || defined(NeXT) || defined(__osf__) +# 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) the smallest quantum select() operates on + * (sets bit) is 32 bits. */ + growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (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 @@ -909,10 +1018,10 @@ PP(pp_getc) if (!gv) gv = PL_argvgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { I32 gimme = GIMME_V; PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)gv, mg)); PUTBACK; ENTER; perl_call_method("GETC", gimme); @@ -1083,18 +1192,18 @@ PP(pp_leavewrite) 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)) @@ -1127,7 +1236,7 @@ PP(pp_prtf) else gv = PL_defoutgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (mg = SvTIED_mg((SV*)gv, 'q')) { if (MARK == ORIGMARK) { MEXTEND(SP, 1); ++MARK; @@ -1135,7 +1244,7 @@ PP(pp_prtf) ++SP; } PUSHMARK(MARK - 1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); PUTBACK; ENTER; perl_call_method("PRINTF", G_SCALAR); @@ -1149,20 +1258,22 @@ PP(pp_prtf) 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; @@ -1237,12 +1348,12 @@ PP(pp_sysread) gv = (GV*)*++MARK; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && - SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) + (mg = SvTIED_mg((SV*)gv, 'q'))) { SV *sv; PUSHMARK(MARK-1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); ENTER; perl_call_method("READ", G_SCALAR); LEAVE; @@ -1298,7 +1409,7 @@ PP(pp_sysread) } #else if (PL_op->op_type == OP_RECV) - DIE(no_sock_func, "recv"); + DIE(PL_no_sock_func, "recv"); #endif if (offset < 0) { if (-offset > blen) @@ -1353,6 +1464,15 @@ PP(pp_sysread) PP(pp_syswrite) { + djSP; + int items = (SP - PL_stack_base) - TOPMARK; + if (items == 2) { + SV *sv; + EXTEND(SP, 1); + sv = sv_2mortal(newSViv(sv_len(*SP))); + PUSHs(sv); + PUTBACK; + } return pp_send(ARGS); } @@ -1369,13 +1489,11 @@ PP(pp_send) MAGIC *mg; gv = (GV*)*++MARK; - if (PL_op->op_type == OP_SYSWRITE && - SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) - { + if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) { SV *sv; PUSHMARK(MARK-1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); ENTER; perl_call_method("WRITE", G_SCALAR); LEAVE; @@ -1396,11 +1514,11 @@ PP(pp_send) 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) { @@ -1431,7 +1549,7 @@ PP(pp_send) #else else - DIE(no_sock_func, "send"); + DIE(PL_no_sock_func, "send"); #endif if (length < 0) goto say_undef; @@ -1485,13 +1603,13 @@ PP(pp_sysseek) 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))); @@ -1622,7 +1740,7 @@ PP(pp_ioctl) if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) DIE("Possible memory corruption: %s overflowed 3rd argument", - op_name[optype]); + PL_op_name[optype]); s[SvCUR(argsv)] = 0; /* put our null back */ SvSETMAGIC(argsv); /* Assume it has changed */ } @@ -1665,7 +1783,7 @@ PP(pp_flock) PUSHi(value); RETURN; #else - DIE(no_func, "flock()"); + DIE(PL_no_func, "flock()"); #endif } @@ -1709,7 +1827,7 @@ PP(pp_socket) RETPUSHYES; #else - DIE(no_sock_func, "socket"); + DIE(PL_no_sock_func, "socket"); #endif } @@ -1759,7 +1877,7 @@ PP(pp_sockpair) RETPUSHYES; #else - DIE(no_sock_func, "socketpair"); + DIE(PL_no_sock_func, "socketpair"); #endif } @@ -1813,12 +1931,12 @@ PP(pp_bind) 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 - DIE(no_sock_func, "bind"); + DIE(PL_no_sock_func, "bind"); #endif } @@ -1843,12 +1961,12 @@ PP(pp_connect) 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 - DIE(no_sock_func, "connect"); + DIE(PL_no_sock_func, "connect"); #endif } @@ -1869,12 +1987,12 @@ PP(pp_listen) 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 - DIE(no_sock_func, "listen"); + DIE(PL_no_sock_func, "listen"); #endif } @@ -1923,15 +2041,15 @@ PP(pp_accept) 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: RETPUSHUNDEF; #else - DIE(no_sock_func, "accept"); + DIE(PL_no_sock_func, "accept"); #endif } @@ -1950,12 +2068,12 @@ PP(pp_shutdown) 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 - DIE(no_sock_func, "shutdown"); + DIE(PL_no_sock_func, "shutdown"); #endif } @@ -1964,7 +2082,7 @@ PP(pp_gsockopt) #ifdef HAS_SOCKET return pp_ssockopt(ARGS); #else - DIE(no_sock_func, "getsockopt"); + DIE(PL_no_sock_func, "getsockopt"); #endif } @@ -2028,14 +2146,14 @@ PP(pp_ssockopt) 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; #else - DIE(no_sock_func, "setsockopt"); + DIE(PL_no_sock_func, "setsockopt"); #endif } @@ -2044,7 +2162,7 @@ PP(pp_getsockname) #ifdef HAS_SOCKET return pp_getpeername(ARGS); #else - DIE(no_sock_func, "getsockname"); + DIE(PL_no_sock_func, "getsockname"); #endif } @@ -2101,14 +2219,14 @@ PP(pp_getpeername) 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; #else - DIE(no_sock_func, "getpeername"); + DIE(PL_no_sock_func, "getpeername"); #endif } @@ -2159,8 +2277,8 @@ PP(pp_stat) #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, PL_warn_nl, "stat"); max = 0; } } @@ -2208,8 +2326,23 @@ PP(pp_stat) 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 + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(S_IRUSR, 0, &PL_statcache)) @@ -2219,8 +2352,23 @@ PP(pp_ftrread) 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 + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(S_IWUSR, 0, &PL_statcache)) @@ -2230,8 +2378,23 @@ PP(pp_ftrwrite) 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 + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(S_IXUSR, 0, &PL_statcache)) @@ -2241,8 +2404,23 @@ PP(pp_ftrexec) 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 + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(S_IRUSR, 1, &PL_statcache)) @@ -2252,8 +2430,23 @@ PP(pp_fteread) 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 + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(S_IWUSR, 1, &PL_statcache)) @@ -2263,8 +2456,23 @@ PP(pp_ftewrite) 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 + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (cando(S_IXUSR, 1, &PL_statcache)) @@ -2564,8 +2772,8 @@ PP(pp_fttext) 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; @@ -2583,8 +2791,8 @@ PP(pp_fttext) 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, PL_warn_nl, "open"); RETPUSHUNDEF; } PL_laststatval = PerlLIO_fstat(i, &PL_statcache); @@ -2608,12 +2816,17 @@ PP(pp_fttext) 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 */ @@ -2676,7 +2889,7 @@ PP(pp_chown) PUSHi(value); RETURN; #else - DIE(no_func, "Unsupported function chown"); + DIE(PL_no_func, "Unsupported function chown"); #endif } @@ -2690,7 +2903,7 @@ PP(pp_chroot) PUSHi( chroot(tmps) >= 0 ); RETURN; #else - DIE(no_func, "chroot"); + DIE(PL_no_func, "chroot"); #endif } @@ -2739,7 +2952,7 @@ PP(pp_rename) 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); @@ -2759,7 +2972,7 @@ PP(pp_link) TAINT_PROPER("link"); SETi( link(tmps, tmps2) >= 0 ); #else - DIE(no_func, "Unsupported function link"); + DIE(PL_no_func, "Unsupported function link"); #endif RETURN; } @@ -2774,7 +2987,7 @@ PP(pp_symlink) SETi( symlink(tmps, tmps2) >= 0 ); RETURN; #else - DIE(no_func, "symlink"); + DIE(PL_no_func, "symlink"); #endif } @@ -2951,7 +3164,7 @@ nope: SETERRNO(EBADF,RMS$_DIR); RETPUSHUNDEF; #else - DIE(no_dir_func, "opendir"); + DIE(PL_no_dir_func, "opendir"); #endif } @@ -3007,7 +3220,7 @@ nope: else RETPUSHUNDEF; #else - DIE(no_dir_func, "readdir"); + DIE(PL_no_dir_func, "readdir"); #endif } @@ -3031,7 +3244,7 @@ nope: SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else - DIE(no_dir_func, "telldir"); + DIE(PL_no_dir_func, "telldir"); #endif } @@ -3054,7 +3267,7 @@ nope: SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else - DIE(no_dir_func, "seekdir"); + DIE(PL_no_dir_func, "seekdir"); #endif } @@ -3075,7 +3288,7 @@ nope: SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else - DIE(no_dir_func, "rewinddir"); + DIE(PL_no_dir_func, "rewinddir"); #endif } @@ -3105,7 +3318,7 @@ nope: SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; #else - DIE(no_dir_func, "closedir"); + DIE(PL_no_dir_func, "closedir"); #endif } @@ -3131,7 +3344,7 @@ PP(pp_fork) PUSHi(childpid); RETURN; #else - DIE(no_func, "Unsupported function fork"); + DIE(PL_no_func, "Unsupported function fork"); #endif } @@ -3147,7 +3360,7 @@ PP(pp_wait) XPUSHi(childpid); RETURN; #else - DIE(no_func, "Unsupported function wait"); + DIE(PL_no_func, "Unsupported function wait"); #endif } @@ -3166,7 +3379,7 @@ PP(pp_waitpid) SETi(childpid); RETURN; #else - DIE(no_func, "Unsupported function waitpid"); + DIE(PL_no_func, "Unsupported function waitpid"); #endif } @@ -3251,7 +3464,14 @@ PP(pp_exec) #ifdef VMS value = (I32)vms_do_aexec(Nullsv, MARK, SP); #else +# ifdef __OPEN_VM + { + (void ) do_aspawn(Nullsv, MARK, SP); + value = 0; + } +# else value = (I32)do_aexec(Nullsv, MARK, SP); +# endif #endif else { if (PL_tainting) { @@ -3262,7 +3482,12 @@ PP(pp_exec) #ifdef VMS value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); #else +# ifdef __OPEN_VM + (void) do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na)); + value = 0; +# else value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na)); +# endif #endif } SP = ORIGMARK; @@ -3280,7 +3505,7 @@ PP(pp_kill) PUSHi(value); RETURN; #else - DIE(no_func, "Unsupported function kill"); + DIE(PL_no_func, "Unsupported function kill"); #endif } @@ -3291,7 +3516,7 @@ PP(pp_getppid) XPUSHi( getppid() ); RETURN; #else - DIE(no_func, "getppid"); + DIE(PL_no_func, "getppid"); #endif } @@ -3316,7 +3541,7 @@ PP(pp_getpgrp) XPUSHi(value); RETURN; #else - DIE(no_func, "getpgrp()"); + DIE(PL_no_func, "getpgrp()"); #endif } @@ -3345,7 +3570,7 @@ PP(pp_setpgrp) #endif /* USE_BSDPGRP */ RETURN; #else - DIE(no_func, "setpgrp()"); + DIE(PL_no_func, "setpgrp()"); #endif } @@ -3360,7 +3585,7 @@ PP(pp_getpriority) SETi( getpriority(which, who) ); RETURN; #else - DIE(no_func, "getpriority()"); + DIE(PL_no_func, "getpriority()"); #endif } @@ -3378,7 +3603,7 @@ PP(pp_setpriority) SETi( setpriority(which, who, niceval) >= 0 ); RETURN; #else - DIE(no_func, "setpriority()"); + DIE(PL_no_func, "setpriority()"); #endif } @@ -3510,7 +3735,7 @@ PP(pp_alarm) PUSHi((I32)anum); RETURN; #else - DIE(no_func, "Unsupported function alarm"); + DIE(PL_no_func, "Unsupported function alarm"); #endif } @@ -3658,7 +3883,7 @@ PP(pp_ghbyname) #ifdef HAS_GETHOSTBYNAME return pp_ghostent(ARGS); #else - DIE(no_sock_func, "gethostbyname"); + DIE(PL_no_sock_func, "gethostbyname"); #endif } @@ -3667,7 +3892,7 @@ PP(pp_ghbyaddr) #ifdef HAS_GETHOSTBYADDR return pp_ghostent(ARGS); #else - DIE(no_sock_func, "gethostbyaddr"); + DIE(PL_no_sock_func, "gethostbyaddr"); #endif } @@ -3691,7 +3916,7 @@ PP(pp_ghostent) #ifdef HAS_GETHOSTBYNAME hent = PerlSock_gethostbyname(POPp); #else - DIE(no_sock_func, "gethostbyname"); + DIE(PL_no_sock_func, "gethostbyname"); #endif else if (which == OP_GHBYADDR) { #ifdef HAS_GETHOSTBYADDR @@ -3702,14 +3927,14 @@ PP(pp_ghostent) hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); #else - DIE(no_sock_func, "gethostbyaddr"); + DIE(PL_no_sock_func, "gethostbyaddr"); #endif } else #ifdef HAS_GETHOSTENT hent = PerlSock_gethostent(); #else - DIE(no_sock_func, "gethostent"); + DIE(PL_no_sock_func, "gethostent"); #endif #ifdef HOST_NOT_FOUND @@ -3757,7 +3982,7 @@ PP(pp_ghostent) } RETURN; #else - DIE(no_sock_func, "gethostent"); + DIE(PL_no_sock_func, "gethostent"); #endif } @@ -3766,7 +3991,7 @@ PP(pp_gnbyname) #ifdef HAS_GETNETBYNAME return pp_gnetent(ARGS); #else - DIE(no_sock_func, "getnetbyname"); + DIE(PL_no_sock_func, "getnetbyname"); #endif } @@ -3775,7 +4000,7 @@ PP(pp_gnbyaddr) #ifdef HAS_GETNETBYADDR return pp_gnetent(ARGS); #else - DIE(no_sock_func, "getnetbyaddr"); + DIE(PL_no_sock_func, "getnetbyaddr"); #endif } @@ -3797,7 +4022,7 @@ PP(pp_gnetent) #ifdef HAS_GETNETBYNAME nent = PerlSock_getnetbyname(POPp); #else - DIE(no_sock_func, "getnetbyname"); + DIE(PL_no_sock_func, "getnetbyname"); #endif else if (which == OP_GNBYADDR) { #ifdef HAS_GETNETBYADDR @@ -3805,14 +4030,14 @@ PP(pp_gnetent) Netdb_net_t addr = (Netdb_net_t) U_L(POPn); nent = PerlSock_getnetbyaddr(addr, addrtype); #else - DIE(no_sock_func, "getnetbyaddr"); + DIE(PL_no_sock_func, "getnetbyaddr"); #endif } else #ifdef HAS_GETNETENT nent = PerlSock_getnetent(); #else - DIE(no_sock_func, "getnetent"); + DIE(PL_no_sock_func, "getnetent"); #endif EXTEND(SP, 4); @@ -3844,7 +4069,7 @@ PP(pp_gnetent) RETURN; #else - DIE(no_sock_func, "getnetent"); + DIE(PL_no_sock_func, "getnetent"); #endif } @@ -3853,7 +4078,7 @@ PP(pp_gpbyname) #ifdef HAS_GETPROTOBYNAME return pp_gprotoent(ARGS); #else - DIE(no_sock_func, "getprotobyname"); + DIE(PL_no_sock_func, "getprotobyname"); #endif } @@ -3862,7 +4087,7 @@ PP(pp_gpbynumber) #ifdef HAS_GETPROTOBYNUMBER return pp_gprotoent(ARGS); #else - DIE(no_sock_func, "getprotobynumber"); + DIE(PL_no_sock_func, "getprotobynumber"); #endif } @@ -3884,19 +4109,19 @@ PP(pp_gprotoent) #ifdef HAS_GETPROTOBYNAME pent = PerlSock_getprotobyname(POPp); #else - DIE(no_sock_func, "getprotobyname"); + DIE(PL_no_sock_func, "getprotobyname"); #endif else if (which == OP_GPBYNUMBER) #ifdef HAS_GETPROTOBYNUMBER pent = PerlSock_getprotobynumber(POPi); #else - DIE(no_sock_func, "getprotobynumber"); + DIE(PL_no_sock_func, "getprotobynumber"); #endif else #ifdef HAS_GETPROTOENT pent = PerlSock_getprotoent(); #else - DIE(no_sock_func, "getprotoent"); + DIE(PL_no_sock_func, "getprotoent"); #endif EXTEND(SP, 3); @@ -3926,7 +4151,7 @@ PP(pp_gprotoent) RETURN; #else - DIE(no_sock_func, "getprotoent"); + DIE(PL_no_sock_func, "getprotoent"); #endif } @@ -3935,7 +4160,7 @@ PP(pp_gsbyname) #ifdef HAS_GETSERVBYNAME return pp_gservent(ARGS); #else - DIE(no_sock_func, "getservbyname"); + DIE(PL_no_sock_func, "getservbyname"); #endif } @@ -3944,7 +4169,7 @@ PP(pp_gsbyport) #ifdef HAS_GETSERVBYPORT return pp_gservent(ARGS); #else - DIE(no_sock_func, "getservbyport"); + DIE(PL_no_sock_func, "getservbyport"); #endif } @@ -3972,7 +4197,7 @@ PP(pp_gservent) sent = PerlSock_getservbyname(name, proto); #else - DIE(no_sock_func, "getservbyname"); + DIE(PL_no_sock_func, "getservbyname"); #endif } else if (which == OP_GSBYPORT) { @@ -3985,14 +4210,14 @@ PP(pp_gservent) #endif sent = PerlSock_getservbyport(port, proto); #else - DIE(no_sock_func, "getservbyport"); + DIE(PL_no_sock_func, "getservbyport"); #endif } else #ifdef HAS_GETSERVENT sent = PerlSock_getservent(); #else - DIE(no_sock_func, "getservent"); + DIE(PL_no_sock_func, "getservent"); #endif EXTEND(SP, 4); @@ -4033,7 +4258,7 @@ PP(pp_gservent) RETURN; #else - DIE(no_sock_func, "getservent"); + DIE(PL_no_sock_func, "getservent"); #endif } @@ -4044,7 +4269,7 @@ PP(pp_shostent) PerlSock_sethostent(TOPi); RETSETYES; #else - DIE(no_sock_func, "sethostent"); + DIE(PL_no_sock_func, "sethostent"); #endif } @@ -4055,7 +4280,7 @@ PP(pp_snetent) PerlSock_setnetent(TOPi); RETSETYES; #else - DIE(no_sock_func, "setnetent"); + DIE(PL_no_sock_func, "setnetent"); #endif } @@ -4066,7 +4291,7 @@ PP(pp_sprotoent) PerlSock_setprotoent(TOPi); RETSETYES; #else - DIE(no_sock_func, "setprotoent"); + DIE(PL_no_sock_func, "setprotoent"); #endif } @@ -4077,7 +4302,7 @@ PP(pp_sservent) PerlSock_setservent(TOPi); RETSETYES; #else - DIE(no_sock_func, "setservent"); + DIE(PL_no_sock_func, "setservent"); #endif } @@ -4089,7 +4314,7 @@ PP(pp_ehostent) EXTEND(SP,1); RETPUSHYES; #else - DIE(no_sock_func, "endhostent"); + DIE(PL_no_sock_func, "endhostent"); #endif } @@ -4101,7 +4326,7 @@ PP(pp_enetent) EXTEND(SP,1); RETPUSHYES; #else - DIE(no_sock_func, "endnetent"); + DIE(PL_no_sock_func, "endnetent"); #endif } @@ -4113,7 +4338,7 @@ PP(pp_eprotoent) EXTEND(SP,1); RETPUSHYES; #else - DIE(no_sock_func, "endprotoent"); + DIE(PL_no_sock_func, "endprotoent"); #endif } @@ -4125,7 +4350,7 @@ PP(pp_eservent) EXTEND(SP,1); RETPUSHYES; #else - DIE(no_sock_func, "endservent"); + DIE(PL_no_sock_func, "endservent"); #endif } @@ -4134,7 +4359,7 @@ PP(pp_gpwnam) #ifdef HAS_PASSWD return pp_gpwent(ARGS); #else - DIE(no_func, "getpwnam"); + DIE(PL_no_func, "getpwnam"); #endif } @@ -4143,7 +4368,7 @@ PP(pp_gpwuid) #ifdef HAS_PASSWD return pp_gpwent(ARGS); #else - DIE(no_func, "getpwuid"); + DIE(PL_no_func, "getpwuid"); #endif } @@ -4235,7 +4460,7 @@ PP(pp_gpwent) } RETURN; #else - DIE(no_func, "getpwent"); + DIE(PL_no_func, "getpwent"); #endif } @@ -4246,7 +4471,7 @@ PP(pp_spwent) setpwent(); RETPUSHYES; #else - DIE(no_func, "setpwent"); + DIE(PL_no_func, "setpwent"); #endif } @@ -4257,7 +4482,7 @@ PP(pp_epwent) endpwent(); RETPUSHYES; #else - DIE(no_func, "endpwent"); + DIE(PL_no_func, "endpwent"); #endif } @@ -4266,7 +4491,7 @@ PP(pp_ggrnam) #ifdef HAS_GROUP return pp_ggrent(ARGS); #else - DIE(no_func, "getgrnam"); + DIE(PL_no_func, "getgrnam"); #endif } @@ -4275,7 +4500,7 @@ PP(pp_ggrgid) #ifdef HAS_GROUP return pp_ggrent(ARGS); #else - DIE(no_func, "getgrgid"); + DIE(PL_no_func, "getgrgid"); #endif } @@ -4329,7 +4554,7 @@ PP(pp_ggrent) RETURN; #else - DIE(no_func, "getgrent"); + DIE(PL_no_func, "getgrent"); #endif } @@ -4340,7 +4565,7 @@ PP(pp_sgrent) setgrent(); RETPUSHYES; #else - DIE(no_func, "setgrent"); + DIE(PL_no_func, "setgrent"); #endif } @@ -4351,7 +4576,7 @@ PP(pp_egrent) endgrent(); RETPUSHYES; #else - DIE(no_func, "endgrent"); + DIE(PL_no_func, "endgrent"); #endif } @@ -4366,7 +4591,7 @@ PP(pp_getlogin) PUSHp(tmps, strlen(tmps)); RETURN; #else - DIE(no_func, "getlogin"); + DIE(PL_no_func, "getlogin"); #endif } @@ -4465,7 +4690,7 @@ PP(pp_syscall) PUSHi(retval); RETURN; #else - DIE(no_func, "syscall"); + DIE(PL_no_func, "syscall"); #endif }