remove the platform dependencies of the write.t tests introduced

[perl5.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index 4de214d..87ac75f 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -50,6 +50,11 @@
 
 #include "XSUB.h"
 
+#ifdef __Lynx__
+/* Missing proto on LynxOS */
+int mkstemp(char*);
+#endif
+
 /* Call the callback or PerlIOBase, and return failure. */
 #define Perl_PerlIO_or_Base(f, callback, base, failure, args)  \
        if (PerlIOValid(f)) {                                   \
@@ -288,7 +293,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
            return PerlIO_tmpfile();
        else {
            char *name = SvPV_nolen(*args);
-           if (*mode == '#') {
+           if (*mode == IoTYPE_NUMERIC) {
                fd = PerlLIO_open3(name, imode, perm);
                if (fd >= 0)
                    return PerlIO_fdopen(fd, (char *) mode + 1);
@@ -735,7 +740,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
        len = strlen(name);
     for (i = 0; i < PL_known_layers->cur; i++) {
        PerlIO_funcs *f = PL_known_layers->array[i].funcs;
-       if (memEQ(f->name, name, len)) {
+       if (memEQ(f->name, name, len) && f->name[len] == 0) {
            PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
            return f;
        }
@@ -916,7 +921,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                    char q = ((*s == '\'') ? '"' : '\'');
                    if (ckWARN(WARN_LAYER))
                        Perl_warner(aTHX_ packWARN(WARN_LAYER),
-                             "perlio: invalid separator character %c%c%c in layer specification list %s",
+                             "Invalid separator character %c%c%c in PerlIO layer specification %s",
                              q, *s, q, s);
                    SETERRNO(EINVAL, LIB_INVARG);
                    return -1;
@@ -953,7 +958,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                            e--;
                            if (ckWARN(WARN_LAYER))
                                Perl_warner(aTHX_ packWARN(WARN_LAYER),
-                                     "perlio: argument list not closed for layer \"%.*s\"",
+                                     "Argument list not closed for PerlIO layer \"%.*s\"",
                                      (int) (e - s), s);
                            return -1;
                        default:
@@ -976,7 +981,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                    }
                    else {
                        if (warn_layer)
-                           Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"",
+                           Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
                                  (int) llen, s);
                        return -1;
                    }
@@ -1960,7 +1965,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     if (tab->Set_ptrcnt != NULL)
        l->flags |= PERLIO_F_FASTGETS;
     if (mode) {
-       if (*mode == '#' || *mode == 'I')
+       if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
            mode++;
        switch (*mode++) {
        case 'r':
@@ -2276,7 +2281,7 @@ int
 PerlIOUnix_oflags(const char *mode)
 {
     int oflags = -1;
-    if (*mode == 'I' || *mode == '#')
+    if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
        mode++;
     switch (*mode) {
     case 'r':
@@ -2375,6 +2380,28 @@ PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     return code;
 }
 
+IV
+PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
+{
+    int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+    Off_t new;
+    if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
+#ifdef  ESPIPE
+       SETERRNO(ESPIPE, LIB_INVARG);
+#else
+       SETERRNO(EINVAL, LIB_INVARG);
+#endif
+       return -1;
+    }
+    new  = PerlLIO_lseek(fd, offset, whence);
+    if (new == (Off_t) - 1)
+     {
+      return -1;
+     }
+    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
+    return  0;
+}
+
 PerlIO *
 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
                IV n, const char *mode, int fd, int imode,
@@ -2386,7 +2413,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     }
     if (narg > 0) {
        char *path = SvPV_nolen(*args);
-       if (*mode == '#')
+       if (*mode == IoTYPE_NUMERIC)
            mode++;
        else {
            imode = PerlIOUnix_oflags(mode);
@@ -2397,7 +2424,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
        }
     }
     if (fd >= 0) {
-       if (*mode == 'I')
+       if (*mode == IoTYPE_IMPLICIT)
            mode++;
        if (!f) {
            f = PerlIO_allocate(aTHX);
@@ -2409,6 +2436,8 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
        }
         PerlIOUnix_setfd(aTHX_ f, fd, imode);
        PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+       if (*mode == IoTYPE_APPEND)
+           PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
        return f;
     }
     else {
@@ -2485,28 +2514,6 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
     }
 }
 
-IV
-PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
-{
-    int fd = PerlIOSelf(f, PerlIOUnix)->fd;
-    Off_t new;
-    if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
-#ifdef  ESPIPE
-       SETERRNO(ESPIPE, LIB_INVARG);
-#else
-       SETERRNO(EINVAL, LIB_INVARG);
-#endif
-       return -1;
-    }
-    new  = PerlLIO_lseek(fd, offset, whence);
-    if (new == (Off_t) - 1)
-     {
-      return -1;
-     }
-    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
-    return  0;
-}
-
 Off_t
 PerlIOUnix_tell(pTHX_ PerlIO *f)
 {
@@ -2606,8 +2613,10 @@ char *
 PerlIOStdio_mode(const char *mode, char *tmode)
 {
     char *ret = tmode;
-    while (*mode) {
-       *tmode++ = *mode++;
+    if (mode) {
+       while (*mode) {
+           *tmode++ = *mode++;
+       }
     }
 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
     *tmode++ = 'b';
@@ -2705,7 +2714,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     else {
        if (narg > 0) {
            char *path = SvPV_nolen(*args);
-           if (*mode == '#') {
+           if (*mode == IoTYPE_NUMERIC) {
                mode++;
                fd = PerlLIO_open3(path, imode, perm);
            }
@@ -2741,7 +2750,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
        if (fd >= 0) {
            FILE *stdio = NULL;
            int init = 0;
-           if (*mode == 'I') {
+           if (*mode == IoTYPE_IMPLICIT) {
                init = 1;
                mode++;
            }
@@ -2866,6 +2875,10 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
      */
     f->_file = -1;
     return 1;
+#  elif defined(__EMX__)
+    /* f->_flags &= ~_IOOPEN; */       /* Will leak stream->_buffer */
+    f->_handle = -1;
+    return 1;
 #  elif defined(__CYGWIN__)
     /* There may be a better way on CYGWIN:
         - we could insert a dummy func in the _close function entry
@@ -3431,7 +3444,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     else {
        PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
        int init = 0;
-       if (*mode == 'I') {
+       if (*mode == IoTYPE_IMPLICIT) {
            init = 1;
            /*
             * mode++;
@@ -4705,9 +4718,16 @@ PerlIO_getname(PerlIO *f, char *buf)
     dTHX;
     char *name = NULL;
 #ifdef VMS
+    bool exported = FALSE;
     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
-    if (stdio)
+    if (!stdio) {
+       stdio = PerlIO_exportFILE(f,0);
+       exported = TRUE;
+    }
+    if (stdio) {
        name = fgetname(stdio, buf);
+       if (exported) PerlIO_releaseFILE(f,stdio);
+    }
 #else
     Perl_croak(aTHX_ "Don't know how to get file name");
 #endif
@@ -4859,7 +4879,7 @@ PerlIO_tmpfile(void)
      if (fd >= 0)
          f = PerlIO_fdopen(fd, "w+b");
 #else /* WIN32 */
-#    ifdef HAS_MKSTEMP
+#    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
      SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
 
      /*