X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=77a547edbd17b2c81fb6e04bb7d1dc1e5587fa3a;hb=a97fb7de1c49a8414fac8dd85b621cd0459704e2;hp=b14dd7719ea4f2e2a6efaddedc6a795b3e03ef3d;hpb=090bf15bb9dfb4e3cb204e6874ee60c0c987535e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index b14dd77..77a547e 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1,6 +1,7 @@
 /*    pp_sys.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (C) 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 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.
@@ -422,7 +423,7 @@ PP(pp_warn)
 	tmpsv = TOPs;
     }
     tmps = SvPV(tmpsv, len);
-    if (!tmps || !len) {
+    if ((!tmps || !len) && PL_errgv) {
   	SV *error = ERRSV;
 	(void)SvUPGRADE(error, SVt_PV);
 	if (SvPOK(error) && SvCUR(error))
@@ -874,8 +875,8 @@ PP(pp_untie)
 		       (UV)SvREFCNT(obj) - 1 ) ;
            }
         }
-	sv_unmagic(sv, how) ;
     }
+    sv_unmagic(sv, how) ;
     RETPUSHYES;
 }
 
@@ -1068,12 +1069,23 @@ PP(pp_sselect)
 #endif
     }
 
+#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
+    /* Can't make just the (void*) conditional because that would be
+     * cpp #if within cpp macro, and not all compilers like that. */
+    nfound = PerlSock_select(
+	maxlen * 8,
+	(Select_fd_set_t) fd_sets[1],
+	(Select_fd_set_t) fd_sets[2],
+	(Select_fd_set_t) fd_sets[3],
+	(void*) tbuf); /* Workaround for compiler bug. */
+#else
     nfound = PerlSock_select(
 	maxlen * 8,
 	(Select_fd_set_t) fd_sets[1],
 	(Select_fd_set_t) fd_sets[2],
 	(Select_fd_set_t) fd_sets[3],
 	tbuf);
+#endif
     for (i = 1; i <= 3; i++) {
 	if (fd_sets[i]) {
 	    sv = SP[i];
@@ -2163,7 +2175,9 @@ PP(pp_ioctl)
 #else
 	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
 #endif
+#endif
 
+#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
     if (SvPOK(argsv)) {
 	if (s[SvCUR(argsv)] != 17)
 	    DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
@@ -2504,6 +2518,9 @@ PP(pp_accept)
     len = sizeof saddr;          /* EPOC somehow truncates info */
     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
 #endif
+#ifdef __SCO_VERSION__
+    len = sizeof saddr;          /* OpenUNIX 8 somehow truncates info */
+#endif
 
     PUSHp((char *)&saddr, len);
     RETURN;
@@ -2835,8 +2852,8 @@ PP(pp_ftrread)
     dSP;
 #if defined(HAS_ACCESS) && defined(R_OK)
     STRLEN n_a;
-    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
-	result = access(TOPpx, R_OK);
+    if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+	result = access(POPpx, R_OK);
 	if (result == 0)
 	    RETPUSHYES;
 	if (result < 0)
@@ -2862,8 +2879,8 @@ PP(pp_ftrwrite)
     dSP;
 #if defined(HAS_ACCESS) && defined(W_OK)
     STRLEN n_a;
-    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
-	result = access(TOPpx, W_OK);
+    if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+	result = access(POPpx, W_OK);
 	if (result == 0)
 	    RETPUSHYES;
 	if (result < 0)
@@ -2889,8 +2906,8 @@ PP(pp_ftrexec)
     dSP;
 #if defined(HAS_ACCESS) && defined(X_OK)
     STRLEN n_a;
-    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
-	result = access(TOPpx, X_OK);
+    if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+	result = access(POPpx, X_OK);
 	if (result == 0)
 	    RETPUSHYES;
 	if (result < 0)
@@ -2916,8 +2933,8 @@ PP(pp_fteread)
     dSP;
 #ifdef PERL_EFF_ACCESS_R_OK
     STRLEN n_a;
-    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
-	result = PERL_EFF_ACCESS_R_OK(TOPpx);
+    if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+	result = PERL_EFF_ACCESS_R_OK(POPpx);
 	if (result == 0)
 	    RETPUSHYES;
 	if (result < 0)
@@ -2943,8 +2960,8 @@ PP(pp_ftewrite)
     dSP;
 #ifdef PERL_EFF_ACCESS_W_OK
     STRLEN n_a;
-    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
-	result = PERL_EFF_ACCESS_W_OK(TOPpx);
+    if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+	result = PERL_EFF_ACCESS_W_OK(POPpx);
 	if (result == 0)
 	    RETPUSHYES;
 	if (result < 0)
@@ -2970,8 +2987,8 @@ PP(pp_fteexec)
     dSP;
 #ifdef PERL_EFF_ACCESS_X_OK
     STRLEN n_a;
-    if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
-	result = PERL_EFF_ACCESS_X_OK(TOPpx);
+    if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+	result = PERL_EFF_ACCESS_X_OK(POPpx);
 	if (result == 0)
 	    RETPUSHYES;
 	if (result < 0)
@@ -3308,7 +3325,7 @@ PP(pp_fttext)
 	PL_laststype = OP_STAT;
 	sv_setpv(PL_statname, SvPV(sv, n_a));
 	if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
-	    if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
+	    if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
 		Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
 	    RETPUSHUNDEF;
 	}
@@ -3658,6 +3675,26 @@ S_dooneliner(pTHX_ char *cmd, char *filename)
 }
 #endif
 
+/* This macro removes trailing slashes from a directory name.
+ * Different operating and file systems take differently to
+ * trailing slashes.  According to POSIX 1003.1 1996 Edition
+ * any number of trailing slashes should be allowed.
+ * Thusly we snip them away so that even non-conforming
+ * systems are happy.
+ * We should probably do this "filtering" for all
+ * the functions that expect (potentially) directory names:
+ * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
+ * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
+
+#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \
+    if ((len) > 1 && (tmps)[(len)-1] == '/') { \
+	do { \
+	    (len)--; \
+	} while ((len) > 1 && (tmps)[(len)-1] == '/'); \
+	(tmps) = savepvn((tmps), (len)); \
+	(copy) = TRUE; \
+    }
+
 PP(pp_mkdir)
 {
     dSP; dTARGET;
@@ -3674,22 +3711,7 @@ PP(pp_mkdir)
     else
 	mode = 0777;
 
-    tmps = SvPV(TOPs, len);
-    /* Different operating and file systems take differently to
-     * trailing slashes.  According to POSIX 1003.1 1996 Edition
-     * any number of trailing slashes should be allowed.
-     * Thusly we snip them away so that even non-conforming
-     * systems are happy. */
-    /* We should probably do this "filtering" for all
-     * the functions that expect (potentially) directory names:
-     * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
-     * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
-    if (len > 1 && tmps[len-1] == '/') {
-	while (tmps[len-1] == '/' && len > 1)
-	    len--;
-	tmps = savepvn(tmps, len);
-	copy = TRUE;
-    }
+    TRIMSLASHES(tmps,len,copy);
 
     TAINT_PROPER("mkdir");
 #ifdef HAS_MKDIR
@@ -3708,16 +3730,19 @@ PP(pp_mkdir)
 PP(pp_rmdir)
 {
     dSP; dTARGET;
+    STRLEN len;
     char *tmps;
-    STRLEN n_a;
+    bool copy = FALSE;
 
-    tmps = POPpx;
+    TRIMSLASHES(tmps,len,copy);
     TAINT_PROPER("rmdir");
 #ifdef HAS_RMDIR
-    XPUSHi( PerlDir_rmdir(tmps) >= 0 );
+    SETi( PerlDir_rmdir(tmps) >= 0 );
 #else
-    XPUSHi( dooneliner("rmdir", tmps) );
+    SETi( dooneliner("rmdir", tmps) );
 #endif
+    if (copy)
+	Safefree(tmps);
     RETURN;
 }
 
@@ -3963,13 +3988,14 @@ PP(pp_wait)
     Pid_t childpid;
     int argflags;
 
-#ifdef PERL_OLD_SIGNALS
-    childpid = wait4pid(-1, &argflags, 0);
-#else
-    while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
-	PERL_ASYNC_CHECK();
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        childpid = wait4pid(-1, &argflags, 0);
+    else {
+        while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
+	       errno == EINTR) {
+	  PERL_ASYNC_CHECK();
+	}
     }
-#endif
 #  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);
@@ -3993,13 +4019,14 @@ PP(pp_waitpid)
 
     optype = POPi;
     childpid = TOPi;
-#ifdef PERL_OLD_SIGNALS
-    childpid = wait4pid(childpid, &argflags, optype);
-#else
-    while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
-	PERL_ASYNC_CHECK();
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        childpid = wait4pid(childpid, &argflags, optype);
+    else {
+        while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 &&
+	       errno == EINTR) {
+	  PERL_ASYNC_CHECK();
+	}
     }
-#endif
 #  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);
@@ -4117,14 +4144,14 @@ PP(pp_system)
     result = 0;
     if (PL_op->op_flags & OPf_STACKED) {
 	SV *really = *++MARK;
-#  ifdef WIN32
+#  if defined(WIN32) || defined(OS2)
 	value = (I32)do_aspawn(really, MARK, SP);
 #  else
 	value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
 #  endif
     }
     else if (SP - MARK != 1) {
-#  ifdef WIN32
+#  if defined(WIN32) || defined(OS2)
 	value = (I32)do_aspawn(Nullsv, MARK, SP);
 #  else
 	value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);