[asperl] add AS patch#21 (misc. fixes)

[p5sagit/p5-mst-13.2.git] / doio.c

diff --git a/doio.c b/doio.c
index d293282..61c21b5 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -171,8 +171,11 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
            if (strNE(name,"-"))
                TAINT_ENV();
            TAINT_PROPER("piped open");
-           if (dowarn && name[strlen(name)-1] == '|')
-               warn("Can't do bidirectional pipe");
+           if (name[strlen(name)-1] == '|') {
+               name[strlen(name)-1] = '\0' ;
+               if (dowarn)
+                   warn("Can't do bidirectional pipe");
+           }
            fp = PerlProc_popen(name,"w");
            writing = 1;
        }
@@ -503,7 +506,7 @@ nextargv(register GV *gv)
                    (void)fchown(lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-                   (void)chown(oldname,fileuid,filegid);
+                   (void)PerlLIO_chown(oldname,fileuid,filegid);
 #endif
 #endif
                }
@@ -717,6 +720,46 @@ do_sysseek(GV *gv, long int pos, int whence)
     return -1L;
 }
 
+int
+do_binmode(PerlIO *fp, int iotype, int flag)
+{
+    if (flag != TRUE)
+       croak("panic: unsetting binmode"); /* Not implemented yet */
+#ifdef DOSISH
+#ifdef atarist
+    if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
+       return 1;
+    else
+       return 0;
+#else
+    if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
+#if defined(WIN32) && defined(__BORLANDC__)
+       /* The translation mode of the stream is maintained independent
+        * of the translation mode of the fd in the Borland RTL (heavy
+        * digging through their runtime sources reveal).  User has to
+        * set the mode explicitly for the stream (though they don't
+        * document this anywhere). GSAR 97-5-24
+        */
+       PerlIO_seek(fp,0L,0);
+       ((FILE*)fp)->flags |= _F_BIN;
+#endif
+       return 1;
+    }
+    else
+       return 0;
+#endif
+#else
+#if defined(USEMYBINMODE)
+    if (my_binmode(fp,iotype) != NULL)
+       return 1;
+    else
+       return 0;
+#else
+    return 1;
+#endif
+#endif
+}
+
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
        /* code courtesy of William Kucharski */
 #define HAS_CHSIZE
@@ -1042,7 +1085,9 @@ apply(I32 type, register SV **mark, register SV **sp)
     SV **oldmark = mark;
 
 #define APPLY_TAINT_PROPER() \
-    if (!(tainting && tainted)) {} else { goto taint_proper; }
+    STMT_START {                                               \
+       if (tainting && tainted) { goto taint_proper_label; }   \
+    } STMT_END
 
     /* This is a first heuristic; it doesn't catch tainting magic. */
     if (tainting) {
@@ -1082,7 +1127,7 @@ apply(I32 type, register SV **mark, register SV **sp)
            while (++mark <= sp) {
                char *name = SvPVx(*mark, na);
                APPLY_TAINT_PROPER();
-               if (chown(name, val, val2))
+               if (PerlLIO_chown(name, val, val2))
                    tot--;
            }
        }
@@ -1222,7 +1267,7 @@ apply(I32 type, register SV **mark, register SV **sp)
     }
     return tot;
 
-  taint_proper:
+  taint_proper_label:
     TAINT_PROPER(what);
     return 0;  /* this should never happen */
 
@@ -1344,6 +1389,9 @@ do_ipcget(I32 optype, SV **mark, SV **sp)
 /* Solaris manpage says that it uses (like linux)
    int semctl (int semid, int semnum, int cmd, union semun arg)
    but the system include files do not define union semun !!!!
+   Note: Linux/glibc *does* declare union semun in <sys/sem_buf.h>
+   but, unlike the older Linux libc and Solaris, it has an extra
+   struct seminfo * on the end.
 */
 union semun {
      int val;
@@ -1360,9 +1408,25 @@ do_ipcctl(I32 optype, SV **mark, SV **sp)
     char *a;
     I32 id, n, cmd, infosize, getinfo;
     I32 ret = -1;
-#if defined(__linux__) || (defined(__sun) && defined(__svr4__))
-/* XXX Need metaconfig test */
-    union semun unsemds;
+/* XXX REALLY need metaconfig test */
+/* linux and Solaris2 use:
+   int semctl (int semid, int semnum, int cmd, union semun arg)
+   instead of:
+   int semctl (int semid, int semnum, int cmd, struct semid_ds *arg);
+   Solaris and Linux (pre-glibc) use
+       union semun {
+            int val;
+            struct semid_ds *buf;
+            ushort *array;
+       };
+   but Solaris doesn't declare it in a header file (we declared it
+   explicitly earlier). Linux/glibc declares a *different* union semun
+   so we just refer to "union semun" here.
+    
+*/
+#if defined(__linux__) || (defined(__sun__) && defined(__svr4__))
+#   define SEMCTL_SEMUN
+    union semun unsemds, semun;
 #endif
 
     id = SvIVx(*++mark);
@@ -1393,17 +1457,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp)
        else if (cmd == GETALL || cmd == SETALL)
        {
            struct semid_ds semds;
-#if defined(__linux__) || (defined(__sun) && defined(__svr4__))
-       /* XXX Need metaconfig test */
-/* linux and Solaris2 uses :
-   int semctl (int semid, int semnum, int cmd, union semun arg)
-       union semun {
-            int val;
-            struct semid_ds *buf;
-            ushort *array;
-       };
-*/
-            union semun semun;
+#ifdef SEMCTL_SEMUN
             semun.buf = &semds;
            if (semctl(id, 0, IPC_STAT, semun) == -1)
 #else
@@ -1454,7 +1508,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp)
 #endif
 #ifdef HAS_SEM
     case OP_SEMCTL:
-#if defined(__linux__) || (defined(__sun) && defined(__svr4__))
+#ifdef SEMCTL_SEMUN
        /* XXX Need metaconfig test */
         unsemds.buf = (struct semid_ds *)a;
        ret = semctl(id, n, cmd, unsemds);