X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cf7fe8a27ac6ee8776974a7c83e80425f2ec0ff8..766a733e849204725c27391cf2992d649af4aba6:/ext/IO/IO.xs diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index a434d08..13b198c 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -4,6 +4,7 @@ * 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" @@ -27,87 +28,26 @@ typedef FILE * InputStream; typedef FILE * OutputStream; #endif -#include "patchlevel.h" - -#if (PATCHLEVEL < 3) || ((PATCHLEVEL == 3) && (SUBVERSION < 22)) - /* before 5.003_22 */ -# define MY_start_subparse(fmt,flags) start_subparse() -#else -# if (PATCHLEVEL == 3) && (SUBVERSION == 22) - /* 5.003_22 */ -# define MY_start_subparse(fmt,flags) start_subparse(flags) -# else - /* 5.003_23 onwards */ -# define MY_start_subparse(fmt,flags) start_subparse(fmt,flags) -# endif -#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(s) -char *s; +not_here(char *s) { croak("%s not implemented on this architecture", s); return -1; } -#ifndef newCONSTSUB -/* - * Define an XSUB that returns a constant scalar. The resulting structure is - * identical to that created by the parser when it parses code like : - * - * sub xyz () { 123 } - * - * This allows the constants from the XSUB to be inlined. - * - * !!! THIS SHOULD BE ADDED INTO THE CORE CODE !!!! - * - */ - -static void -newCONSTSUB(stash,name,sv) - HV *stash; - char *name; - SV *sv; -{ -#ifdef dTHR - dTHR; -#endif - U32 oldhints = hints; - HV *old_cop_stash = curcop->cop_stash; - HV *old_curstash = curstash; - line_t oldline = curcop->cop_line; - curcop->cop_line = copline; - - hints &= ~HINT_BLOCK_SCOPE; - if(stash) - curstash = curcop->cop_stash = stash; - - newSUB( - MY_start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), - newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */ - newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) - ); - - hints = oldhints; - curcop->cop_stash = old_cop_stash; - curstash = old_curstash; - curcop->cop_line = oldline; -} -#endif #ifndef PerlIO #define PerlIO_fileno(f) fileno(f) #endif static int -io_blocking(f,block) -InputStream f; -int block; +io_blocking(InputStream f, int block) { int RETVAL; if(!f) { @@ -119,29 +59,34 @@ int block; if (RETVAL >= 0) { int mode = RETVAL; #ifdef O_NONBLOCK - /* POSIX style */ + /* 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 - */ - RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; - - 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; + /* 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 - /* Standard POSIX */ + /* Standard POSIX */ RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; if ((block == 0) && !(mode & O_NONBLOCK)) { @@ -158,11 +103,11 @@ int block; if(ret < 0) RETVAL = ret; } -#endif +#endif #else /* 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 + * for SysV we can't tell "would block" from EOF but that is * the way SysV is... */ RETVAL = RETVAL & O_NDELAY ? 0 : 1; @@ -196,16 +141,21 @@ 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) = &sv_undef; + ST(0) = &PL_sv_undef; errno = EINVAL; } @@ -214,12 +164,21 @@ fsetpos(handle, pos) InputStream handle SV * pos CODE: - if (handle) + if (handle) { #ifdef PerlIO - RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos)); + RETVAL = PerlIO_setpos(handle, pos); #else - RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); + 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; @@ -249,13 +208,13 @@ new_tmpfile(packname = "IO::File") SvREFCNT_dec(gv); /* undo increment in newRV() */ } else { - ST(0) = &sv_undef; + ST(0) = &PL_sv_undef; SvREFCNT_dec(gv); } MODULE = IO PACKAGE = IO::Poll -void +void _poll(timeout,...) int timeout; PPCODE: @@ -415,8 +374,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) @@ -512,11 +470,4 @@ BOOT: #ifdef SEEK_END newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END)); #endif - /* - * constant subs for IO - */ - stash = gv_stashpvn("IO", 2, TRUE); -#ifdef EINPROGRESS - newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS)); -#endif }