This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Build fixes for Win32 after the Coverity smoke.
[perl5.git] / dist / IO / IO.xs
index dfbe3bd..4b13feb 100644 (file)
@@ -57,6 +57,10 @@ typedef FILE * OutputStream;
 # define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
 #endif
 
+#ifndef dVAR
+#  define dVAR dNOOP
+#endif
+
 static int not_here(const char *s) __attribute__noreturn__;
 static int
 not_here(const char *s)
@@ -65,6 +69,31 @@ not_here(const char *s)
     NORETURN_FUNCTION_END;
 }
 
+#ifndef UVCHR_IS_INVARIANT   /* For use with Perls without this macro */
+#   if ('A' == 65)
+#       define UVCHR_IS_INVARIANT(cp) ((cp) < 128)
+#   elif (defined(NATIVE_IS_INVARIANT)) /* EBCDIC on old Perl */
+#       define UVCHR_IS_INVARIANT(cp) ((cp) < 256 && NATIVE_IS_INVARIANT(cp))
+#   elif defined(isASCII)    /* EBCDIC on very old Perl */
+        /* In EBCDIC, the invariants are the code points corresponding to ASCII,
+         * plus all the controls.  All but one EBCDIC control is below SPACE; it
+         * varies depending on the code page, determined by the ord of '^' */
+#       define UVCHR_IS_INVARIANT(cp) (isASCII(cp)                            \
+                                       || (cp) < ' '                          \
+                                       || (('^' == 106)    /* POSIX-BC */     \
+                                          ? (cp) == 95                        \
+                                          : (cp) == 0xFF)) /* 1047 or 037 */
+#   else    /* EBCDIC on very very old Perl */
+        /* This assumes isascii() is available, but that could be fixed by
+         * having the macro test for each printable ASCII char */
+#       define UVCHR_IS_INVARIANT(cp) (isascii(cp)                            \
+                                       || (cp) < ' '                          \
+                                       || (('^' == 106)    /* POSIX-BC */     \
+                                          ? (cp) == 95                        \
+                                          : (cp) == 0xFF)) /* 1047 or 037 */
+#   endif
+#endif
+
 
 #ifndef PerlIO
 #define PerlIO_fileno(f) fileno(f)
@@ -73,13 +102,19 @@ not_here(const char *s)
 static int
 io_blocking(pTHX_ InputStream f, int block)
 {
+    int fd = -1;
 #if defined(HAS_FCNTL)
     int RETVAL;
-    if(!f) {
+    if (!f) {
        errno = EBADF;
        return -1;
     }
-    RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
+    fd = PerlIO_fileno(f);
+    if (fd < 0) {
+      errno = EBADF;
+      return -1;
+    }
+    RETVAL = fcntl(fd, F_GETFL, 0);
     if (RETVAL >= 0) {
        int mode = RETVAL;
        int newmode = mode;
@@ -114,7 +149,7 @@ io_blocking(pTHX_ InputStream f, int block)
        }
 #endif
        if (newmode != mode) {
-           const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
+            const int ret = fcntl(fd, F_SETFL, newmode);
            if (ret < 0)
                RETVAL = ret;
        }
@@ -123,9 +158,9 @@ io_blocking(pTHX_ InputStream f, int block)
 #else
 #   ifdef WIN32
     if (block >= 0) {
-        unsigned long flags = !block;
+       unsigned long flags = !block;
        /* ioctl claims to take char* but really needs a u_long sized buffer */
-        const int ret = ioctl(PerlIO_fileno(f), FIONBIO, (char*)&flags);
+       const int ret = ioctl(fd, FIONBIO, (char*)&flags);
        if (ret != 0)
            return -1;
        /* Win32 has no way to get the current blocking status of a socket.
@@ -142,6 +177,27 @@ io_blocking(pTHX_ InputStream f, int block)
 #endif
 }
 
+static OP *
+io_pp_nextstate(pTHX)
+{
+    dVAR;
+    COP *old_curcop = PL_curcop;
+    OP *next = PL_ppaddr[PL_op->op_type](aTHX);
+    PL_curcop = old_curcop;
+    return next;
+}
+
+static OP *
+io_ck_lineseq(pTHX_ OP *o)
+{
+    OP *kid = cBINOPo->op_first;
+    for (; kid; kid = kid->op_sibling)
+       if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+           kid->op_ppaddr = io_pp_nextstate;
+    return o;
+}
+
+
 MODULE = IO    PACKAGE = IO::Seekable  PREFIX = f
 
 void
@@ -302,14 +358,38 @@ MODULE = IO       PACKAGE = IO::Handle    PREFIX = f
 int
 ungetc(handle, c)
        InputStream     handle
-       int             c
+       SV *            c
     CODE:
-       if (handle)
+       if (handle) {
 #ifdef PerlIO
-           RETVAL = PerlIO_ungetc(handle, c);
+            UV v;
+
+            if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
+                croak("Negative character number in ungetc()");
+
+            v = SvUV(c);
+            if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
+                RETVAL = PerlIO_ungetc(handle, (int)v);
+            else {
+                U8 buf[UTF8_MAXBYTES + 1], *end;
+                Size_t len;
+
+                if (!PerlIO_isutf8(handle))
+                    croak("Wide character number in ungetc()");
+
+                /* This doesn't warn for non-chars, surrogate, and
+                 * above-Unicodes */
+                end = uvchr_to_utf8_flags(buf, v, 0);
+                len = end - buf;
+                if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
+                    XSRETURN_UV(v);
+                else
+                    RETVAL = EOF;
+            }
 #else
-           RETVAL = ungetc(c, handle);
+            RETVAL = ungetc((int)SvIV(c), handle);
 #endif
+        }
        else {
            RETVAL = -1;
            errno = EINVAL;
@@ -441,13 +521,24 @@ setvbuf(...)
 
 
 SysRet
-fsync(handle)
-       OutputStream handle
+fsync(arg)
+       SV * arg
+    PREINIT:
+       OutputStream handle = NULL;
     CODE:
 #ifdef HAS_FSYNC
-       if(handle)
-           RETVAL = fsync(PerlIO_fileno(handle));
-       else {
+       handle = IoOFP(sv_2io(arg));
+       if (!handle)
+           handle = IoIFP(sv_2io(arg));
+       if (handle) {
+           int fd = PerlIO_fileno(handle);
+           if (fd >= 0) {
+               RETVAL = fsync(fd);
+           } else {
+               RETVAL = -1;
+               errno = EBADF;
+           }
+       } else {
            RETVAL = -1;
            errno = EINVAL;
        }
@@ -457,6 +548,16 @@ fsync(handle)
     OUTPUT:
        RETVAL
 
+SV *
+_create_getline_subs(const char *code)
+    CODE:
+       OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
+       PL_check[OP_LINESEQ] = io_ck_lineseq;
+       RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
+       PL_check[OP_LINESEQ] = io_old_ck_lineseq;
+    OUTPUT:
+       RETVAL
+
 
 MODULE = IO    PACKAGE = IO::Socket
 
@@ -465,18 +566,27 @@ sockatmark (sock)
    InputStream sock
    PROTOTYPE: $
    PREINIT:
-     int fd;
+     int fd = PerlIO_fileno(sock);
    CODE:
    {
-     fd = PerlIO_fileno(sock);
 #ifdef HAS_SOCKATMARK
-     RETVAL = sockatmark(fd);
+     if (fd < 0) {
+       errno = EBADF;
+       RETVAL = -1;
+     } else {
+       RETVAL = sockatmark(fd);
+     }
 #else
      {
+     if (fd < 0) {
+       errno = EBADF;
+       RETVAL = -1;
+     }
+     else {
        int flag = 0;
 #   ifdef SIOCATMARK
 #     if defined(NETWARE) || defined(WIN32)
-       if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
+       if (ioctl(fd, SIOCATMARK, (char*)&flag) != 0)
 #     else
        if (ioctl(fd, SIOCATMARK, &flag) != 0)
 #     endif
@@ -486,6 +596,7 @@ sockatmark (sock)
 #   endif
        RETVAL = flag;
      }
+     }
 #endif
    }
    OUTPUT: