diff options
Diffstat (limited to 'contrib/perl5/ext/IO/IO.xs')
| -rw-r--r-- | contrib/perl5/ext/IO/IO.xs | 300 |
1 files changed, 234 insertions, 66 deletions
diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs index 300581e..1b79cfd 100644 --- a/contrib/perl5/ext/IO/IO.xs +++ b/contrib/perl5/ext/IO/IO.xs @@ -1,20 +1,20 @@ +/* + * 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_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 #ifdef PerlIO @@ -28,6 +28,12 @@ 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(char *s) { @@ -35,56 +41,99 @@ not_here(char *s) return -1; } -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; + +#ifndef PerlIO +#define PerlIO_fileno(f) fileno(f) #endif - break; - case 'S': - if (strEQ(name, "SEEK_SET")) -#ifdef SEEK_SET - { *pval = SEEK_SET; return TRUE; } + +static int +io_blocking(InputStream f, int block) +{ + int RETVAL; + if(!f) { + errno = EBADF; + return -1; + } +#if defined(HAS_FCNTL) + RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0); + if (RETVAL >= 0) { + int mode = RETVAL; +#ifdef O_NONBLOCK + /* POSIX style */ +#if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK + /* Ooops has O_NDELAY too - make sure we don't + * get SysV behaviour by mistake. */ + + /* E.g. In 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) { + if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) { + int ret; + mode = (mode & ~O_NDELAY) | O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else + if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) { + int ret; + mode &= ~(O_NONBLOCK | O_NDELAY); + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + } #else - return FALSE; -#endif - if (strEQ(name, "SEEK_CUR")) -#ifdef SEEK_CUR - { *pval = SEEK_CUR; return TRUE; } + /* Standard POSIX */ + RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; + + if ((block == 0) && !(mode & O_NONBLOCK)) { + int ret; + mode |= O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else if ((block > 0) && (mode & O_NONBLOCK)) { + int ret; + mode &= ~O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } +#endif #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) && !(mode & O_NDELAY)) { + int ret; + mode |= O_NDELAY; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else if ((block > 0) && (mode & O_NDELAY)) { + int ret; + mode &= ~O_NDELAY; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } #endif - if (strEQ(name, "SEEK_END")) -#ifdef SEEK_END - { *pval = SEEK_END; return TRUE; } + } + return RETVAL; #else - return FALSE; + return -1; #endif - break; - } - - return FALSE; } - MODULE = IO PACKAGE = IO::Seekable PREFIX = f SV * @@ -110,9 +159,9 @@ fsetpos(handle, pos) InputStream handle SV * pos CODE: - char *p; - STRLEN n_a; - if (handle && (p = SvPVx(pos, n_a)) && n_a == sizeof(Fpos_t)) + char *p; + STRLEN len; + if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) #ifdef PerlIO RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); #else @@ -144,24 +193,63 @@ 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::Poll + +void +_poll(timeout,...) + int timeout; +PPCODE: +{ +#ifdef HAS_POLL + 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 = 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: +{ + int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0); + if(ret >= 0) + XSRETURN_IV(ret); + else + XSRETURN_UNDEF; +} + MODULE = IO PACKAGE = IO::Handle PREFIX = f -SV * -constant(name) - char * name - CODE: - IV i; - if (constant(name, &i)) - ST(0) = sv_2mortal(newSViv(i)); - else - ST(0) = &PL_sv_undef; int ungetc(handle, c) @@ -274,8 +362,7 @@ setvbuf(handle, buf, type, size) int type int size CODE: -/* Should check HAS_SETVBUF once Configure tests for that */ -#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF) if (!handle) /* Try input stream. */ handle = IoIFP(sv_2io(ST(0))); if (handle) @@ -291,3 +378,84 @@ 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 + + +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 +} |
