X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FIO%2FIO.xs;h=b3125aa6017d7b3a7b717f9bcf31ff785ea7812b;hb=8ca60cef700efb73a84648ac3b19fd3a3eecd992;hp=a434cca78bd0fc00cea0e75ab895c72166998ac4;hpb=cd661bb69faf0e70cffcc62a2ca9539a1dd6a09d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs
index a434cca..b3125aa 100644
--- a/ext/IO/IO.xs
+++ b/ext/IO/IO.xs
@@ -1,23 +1,38 @@
+/*
+ * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ */
+
+#define PERL_EXT_IO
+
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #define PERLIO_NOT_STDIO 1
 #include "perl.h"
 #include "XSUB.h"
-
+#include "poll.h"
 #ifdef I_UNISTD
 #  include <unistd.h>
 #endif
-#ifdef I_FCNTL
-#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
-#define _NO_OLDNAMES
-#endif 
+#if defined(I_FCNTL) || defined(HAS_FCNTL)
 #  include <fcntl.h>
-#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
-#undef _NO_OLDNAMES
-#endif 
+#endif
 
+#ifndef SIOCATMARK
+#   ifdef I_SYS_SOCKIO
+#       include <sys/sockio.h>
+#   endif
 #endif
 
 #ifdef PerlIO
+#if defined(MACOS_TRADITIONAL) && defined(USE_SFIO)
+#define PERLIO_IS_STDIO 1
+#undef setbuf
+#undef setvbuf
+#define setvbuf		_stdsetvbuf
+#define setbuf(f,b)	( __sf_setbuf(f,b) )
+#endif
 typedef int SysRet;
 typedef PerlIO * InputStream;
 typedef PerlIO * OutputStream;
@@ -28,77 +43,99 @@ typedef FILE * InputStream;
 typedef FILE * OutputStream;
 #endif
 
+#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
+
+#ifndef gv_stashpvn
+#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+static int not_here(const char *s) __attribute__noreturn__;
 static int
-not_here(char *s)
+not_here(const char *s)
 {
     croak("%s not implemented on this architecture", s);
-    return -1;
+    NORETURN_FUNCTION_END;
 }
 
-static bool
-constant(char *name, IV *pval)
-{
-    switch (*name) {
-    case '_':
-	if (strEQ(name, "_IOFBF"))
-#ifdef _IOFBF
-	    { *pval = _IOFBF; return TRUE; }
-#else
-	    return FALSE;
-#endif
-	if (strEQ(name, "_IOLBF"))
-#ifdef _IOLBF
-	    { *pval = _IOLBF; return TRUE; }
-#else
-	    return FALSE;
-#endif
-	if (strEQ(name, "_IONBF"))
-#ifdef _IONBF
-	    { *pval = _IONBF; return TRUE; }
-#else
-	    return FALSE;
-#endif
-	break;
-    case 'S':
-	if (strEQ(name, "SEEK_SET"))
-#ifdef SEEK_SET
-	    { *pval = SEEK_SET; return TRUE; }
-#else
-	    return FALSE;
+
+#ifndef PerlIO
+#define PerlIO_fileno(f) fileno(f)
 #endif
-	if (strEQ(name, "SEEK_CUR"))
-#ifdef SEEK_CUR
-	    { *pval = SEEK_CUR; return TRUE; }
+
+static int
+io_blocking(pTHX_ InputStream f, int block)
+{
+#if defined(HAS_FCNTL)
+    int RETVAL;
+    if(!f) {
+	errno = EBADF;
+	return -1;
+    }
+    RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
+    if (RETVAL >= 0) {
+	int mode = RETVAL;
+	int newmode = mode;
+#ifdef O_NONBLOCK
+	/* POSIX style */
+
+# ifndef O_NDELAY
+#  define O_NDELAY O_NONBLOCK
+# endif
+	/* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
+	 * after a successful F_SETFL of an O_NONBLOCK. */
+	RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
+
+	if (block == 0) {
+	    newmode &= ~O_NDELAY;
+	    newmode |= O_NONBLOCK;
+	} else if (block > 0) {
+	    newmode &= ~(O_NDELAY|O_NONBLOCK);
+	}
 #else
-	    return FALSE;
+	/* Not POSIX - better have O_NDELAY or we can't cope.
+	 * for BSD-ish machines this is an acceptable alternative
+	 * for SysV we can't tell "would block" from EOF but that is
+	 * the way SysV is...
+	 */
+	RETVAL = RETVAL & O_NDELAY ? 0 : 1;
+
+	if (block == 0) {
+	    newmode |= O_NDELAY;
+	} else if (block > 0) {
+	    newmode &= ~O_NDELAY;
+	}
 #endif
-	if (strEQ(name, "SEEK_END"))
-#ifdef SEEK_END
-	    { *pval = SEEK_END; return TRUE; }
+	if (newmode != mode) {
+	    const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
+	    if (ret < 0)
+		RETVAL = ret;
+	}
+    }
+    return RETVAL;
 #else
-	    return FALSE;
+    return -1;
 #endif
-	break;
-    }
-
-    return FALSE;
 }
 
-
 MODULE = IO	PACKAGE = IO::Seekable	PREFIX = f
 
-SV *
+void
 fgetpos(handle)
 	InputStream	handle
     CODE:
 	if (handle) {
-	    Fpos_t pos;
 #ifdef PerlIO
-	    PerlIO_getpos(handle, &pos);
+	    ST(0) = sv_2mortal(newSV(0));
+	    if (PerlIO_getpos(handle, ST(0)) != 0) {
+		ST(0) = &PL_sv_undef;
+	    }
 #else
-	    fgetpos(handle, &pos);
+	    if (fgetpos(handle, &pos)) {
+		ST(0) = &PL_sv_undef;
+	    } else {
+		ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
+	    }
 #endif
-	    ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
 	}
 	else {
 	    ST(0) = &PL_sv_undef;
@@ -110,13 +147,21 @@ fsetpos(handle, pos)
 	InputStream	handle
 	SV *		pos
     CODE:
-	char *p;
-	if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t))
+	if (handle) {
 #ifdef PerlIO
-	    RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+	    RETVAL = PerlIO_setpos(handle, pos);
 #else
-	    RETVAL = fsetpos(handle, (Fpos_t*)p);
+	    char *p;
+	    STRLEN len;
+	    if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
+		RETVAL = fsetpos(handle, (Fpos_t*)p);
+	    }
+	    else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
 #endif
+	}
 	else {
 	    RETVAL = -1;
 	    errno = EINVAL;
@@ -126,9 +171,9 @@ fsetpos(handle, pos)
 
 MODULE = IO	PACKAGE = IO::File	PREFIX = f
 
-SV *
+void
 new_tmpfile(packname = "IO::File")
-    char *		packname
+    const char *	packname
     PREINIT:
 	OutputStream fp;
 	GV *gv;
@@ -143,24 +188,62 @@ new_tmpfile(packname = "IO::File")
 	if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
 	    ST(0) = sv_2mortal(newRV((SV*)gv));
 	    sv_bless(ST(0), gv_stashpv(packname, TRUE));
-	    SvREFCNT_dec(gv);	/* undo increment in newRV() */
+	    SvREFCNT_dec(gv);   /* undo increment in newRV() */
 	}
 	else {
 	    ST(0) = &PL_sv_undef;
 	    SvREFCNT_dec(gv);
 	}
 
-MODULE = IO	PACKAGE = IO::Handle	PREFIX = f
+MODULE = IO	PACKAGE = IO::Poll
 
-SV *
-constant(name)
-	char *		name
-    CODE:
-	IV i;
-	if (constant(name, &i))
-	    ST(0) = sv_2mortal(newSViv(i));
-	else
-	    ST(0) = &PL_sv_undef;
+void
+_poll(timeout,...)
+	int timeout;
+PPCODE:
+{
+#ifdef HAS_POLL
+    const int nfd = (items - 1) / 2;
+    SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
+    struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
+    int i,j,ret;
+    for(i=1, j=0  ; j < nfd ; j++) {
+	fds[j].fd = SvIV(ST(i));
+	i++;
+	fds[j].events = (short)SvIV(ST(i));
+	i++;
+	fds[j].revents = 0;
+    }
+    if((ret = poll(fds,nfd,timeout)) >= 0) {
+	for(i=1, j=0 ; j < nfd ; j++) {
+	    sv_setiv(ST(i), fds[j].fd); i++;
+	    sv_setiv(ST(i), fds[j].revents); i++;
+	}
+    }
+    SvREFCNT_dec(tmpsv);
+    XSRETURN_IV(ret);
+#else
+	not_here("IO::Poll::poll");
+#endif
+}
+
+MODULE = IO	PACKAGE = IO::Handle	PREFIX = io_
+
+void
+io_blocking(handle,blk=-1)
+	InputStream	handle
+	int		blk
+PROTOTYPE: $;$
+CODE:
+{
+    const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
+    if(ret >= 0)
+	XSRETURN_IV(ret);
+    else
+	XSRETURN_UNDEF;
+}
+
+MODULE = IO	PACKAGE = IO::Handle	PREFIX = f
 
 int
 ungetc(handle, c)
@@ -255,34 +338,47 @@ fflush(handle)
 	RETVAL
 
 void
-setbuf(handle, buf)
+setbuf(handle, ...)
 	OutputStream	handle
-	char *		buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
     CODE:
 	if (handle)
 #ifdef PERLIO_IS_STDIO
+        {
+	    char *buf = items == 2 && SvPOK(ST(1)) ?
+	      sv_grow(ST(1), BUFSIZ) : 0;
 	    setbuf(handle, buf);
+	}
 #else
 	    not_here("IO::Handle::setbuf");
 #endif
 
 SysRet
-setvbuf(handle, buf, type, size)
-	OutputStream	handle
-	char *		buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
-	int		type
-	int		size
+setvbuf(...)
     CODE:
-/* Should check HAS_SETVBUF once Configure tests for that */
-#if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
+	if (items != 4)
+            Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
+#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
+    {
+        OutputStream	handle = 0;
+	char *		buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+	int		type;
+	int		size;
+
+	if (items == 4) {
+	    handle = IoOFP(sv_2io(ST(0)));
+	    buf    = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+	    type   = (int)SvIV(ST(2));
+	    size   = (int)SvIV(ST(3));
+	}
 	if (!handle)			/* Try input stream. */
 	    handle = IoIFP(sv_2io(ST(0)));
-	if (handle)
+	if (items == 4 && handle)
 	    RETVAL = setvbuf(handle, buf, type, size);
 	else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
+    }
 #else
 	RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
 #endif
@@ -290,3 +386,118 @@ setvbuf(handle, buf, type, size)
 	RETVAL
 
 
+SysRet
+fsync(handle)
+	OutputStream handle
+    CODE:
+#ifdef HAS_FSYNC
+	if(handle)
+	    RETVAL = fsync(PerlIO_fileno(handle));
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+#else
+	RETVAL = (SysRet) not_here("IO::Handle::sync");
+#endif
+    OUTPUT:
+	RETVAL
+
+
+MODULE = IO	PACKAGE = IO::Socket
+
+SysRet
+sockatmark (sock)
+   InputStream sock
+   PROTOTYPE: $
+   PREINIT:
+     int fd;
+   CODE:
+   {
+     fd = PerlIO_fileno(sock);
+#ifdef HAS_SOCKATMARK
+     RETVAL = sockatmark(fd);
+#else
+     {
+       int flag = 0;
+#   ifdef SIOCATMARK
+#     if defined(NETWARE) || defined(WIN32)
+       if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
+#     else
+       if (ioctl(fd, SIOCATMARK, &flag) != 0)
+#     endif
+	 XSRETURN_UNDEF;
+#   else
+       not_here("IO::Socket::atmark");
+#   endif
+       RETVAL = flag;
+     }
+#endif
+   }
+   OUTPUT:
+     RETVAL
+
+BOOT:
+{
+    HV *stash;
+    /*
+     * constant subs for IO::Poll
+     */
+    stash = gv_stashpvn("IO::Poll", 8, TRUE);
+#ifdef	POLLIN
+	newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
+#endif
+#ifdef	POLLPRI
+        newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
+#endif
+#ifdef	POLLOUT
+        newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
+#endif
+#ifdef	POLLRDNORM
+        newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
+#endif
+#ifdef	POLLWRNORM
+        newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
+#endif
+#ifdef	POLLRDBAND
+        newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
+#endif
+#ifdef	POLLWRBAND
+        newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
+#endif
+#ifdef	POLLNORM
+        newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
+#endif
+#ifdef	POLLERR
+        newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
+#endif
+#ifdef	POLLHUP
+        newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
+#endif
+#ifdef	POLLNVAL
+        newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
+#endif
+    /*
+     * constant subs for IO::Handle
+     */
+    stash = gv_stashpvn("IO::Handle", 10, TRUE);
+#ifdef _IOFBF
+        newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
+#endif
+#ifdef _IOLBF
+        newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
+#endif
+#ifdef _IONBF
+        newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
+#endif
+#ifdef SEEK_SET
+        newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
+#endif
+#ifdef SEEK_CUR
+        newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
+#endif
+#ifdef SEEK_END
+        newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
+#endif
+}
+