1			/*
     2			 * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
     3			 * This program is free software; you can redistribute it and/or
     4			 * modify it under the same terms as Perl itself.
     5			 */
     6			
     7			#define PERL_EXT_IO
     8			
     9			#define PERL_NO_GET_CONTEXT
    10			#include "EXTERN.h"
    11			#define PERLIO_NOT_STDIO 1
    12			#include "perl.h"
    13			#include "XSUB.h"
    14			#include "poll.h"
    15			#ifdef I_UNISTD
    16			#  include <unistd.h>
    17			#endif
    18			#if defined(I_FCNTL) || defined(HAS_FCNTL)
    19			#  include <fcntl.h>
    20			#endif
    21			
    22			#ifndef SIOCATMARK
    23			#   ifdef I_SYS_SOCKIO
    24			#       include <sys/sockio.h>
    25			#   endif
    26			#endif
    27			
    28			#ifdef PerlIO
    29			#if defined(MACOS_TRADITIONAL) && defined(USE_SFIO)
    30			#define PERLIO_IS_STDIO 1
    31			#undef setbuf
    32			#undef setvbuf
    33			#define setvbuf		_stdsetvbuf
    34			#define setbuf(f,b)	( __sf_setbuf(f,b) )
    35			#endif
    36			typedef int SysRet;
    37			typedef PerlIO * InputStream;
    38			typedef PerlIO * OutputStream;
    39			#else
    40			#define PERLIO_IS_STDIO 1
    41			typedef int SysRet;
    42			typedef FILE * InputStream;
    43			typedef FILE * OutputStream;
    44			#endif
    45			
    46			#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
    47			
    48			#ifndef gv_stashpvn
    49			#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
    50			#endif
    51			
    52			static int not_here(const char *s) __attribute__noreturn__;
    53			static int
    54			not_here(const char *s)
    55	      ######    {
    56	      ######        croak("%s not implemented on this architecture", s);
    57			    NORETURN_FUNCTION_END;
    58			}
    59			
    60			
    61			#ifndef PerlIO
    62			#define PerlIO_fileno(f) fileno(f)
    63			#endif
    64			
    65			static int
    66			io_blocking(pTHX_ InputStream f, int block)
    67	          10    {
    68			#if defined(HAS_FCNTL)
    69	          10        int RETVAL;
    70	          10        if(!f) {
    71	      ######    	errno = EBADF;
    72	      ######    	return -1;
    73			    }
    74	          10        RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
    75	          10        if (RETVAL >= 0) {
    76	          10    	int mode = RETVAL;
    77	          10    	int newmode = mode;
    78			#ifdef O_NONBLOCK
    79				/* POSIX style */
    80			
    81			# ifndef O_NDELAY
    82			#  define O_NDELAY O_NONBLOCK
    83			# endif
    84				/* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
    85				 * after a successful F_SETFL of an O_NONBLOCK. */
    86	          10    	RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
    87			
    88	          10    	if (block == 0) {
    89	           4    	    newmode &= ~O_NDELAY;
    90	           4    	    newmode |= O_NONBLOCK;
    91	           6    	} else if (block > 0) {
    92	           1    	    newmode &= ~(O_NDELAY|O_NONBLOCK);
    93				}
    94			#else
    95				/* Not POSIX - better have O_NDELAY or we can't cope.
    96				 * for BSD-ish machines this is an acceptable alternative
    97				 * for SysV we can't tell "would block" from EOF but that is
    98				 * the way SysV is...
    99				 */
   100				RETVAL = RETVAL & O_NDELAY ? 0 : 1;
   101			
   102				if (block == 0) {
   103				    newmode |= O_NDELAY;
   104				} else if (block > 0) {
   105				    newmode &= ~O_NDELAY;
   106				}
   107			#endif
   108	          10    	if (newmode != mode) {
   109	           5    	    const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
   110	           5    	    if (ret < 0)
   111	      ######    		RETVAL = ret;
   112				}
   113			    }
   114	          10        return RETVAL;
   115			#else
   116			    return -1;
   117			#endif
   118			}
   119			
   120			MODULE = IO	PACKAGE = IO::Seekable	PREFIX = f
   121			
   122			void
   123			fgetpos(handle)
   124				InputStream	handle
   125			    CODE:
   126	           1    	if (handle) {
   127			#ifdef PerlIO
   128	           1    	    ST(0) = sv_2mortal(newSV(0));
   129	           1    	    if (PerlIO_getpos(handle, ST(0)) != 0) {
   130	      ######    		ST(0) = &PL_sv_undef;
   131				    }
   132			#else
   133				    if (fgetpos(handle, &pos)) {
   134					ST(0) = &PL_sv_undef;
   135				    } else {
   136					ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
   137				    }
   138			#endif
   139				}
   140				else {
   141	      ######    	    ST(0) = &PL_sv_undef;
   142	      ######    	    errno = EINVAL;
   143				}
   144			
   145			SysRet
   146			fsetpos(handle, pos)
   147				InputStream	handle
   148				SV *		pos
   149			    CODE:
   150	           2    	if (handle) {
   151			#ifdef PerlIO
   152	           2    	    RETVAL = PerlIO_setpos(handle, pos);
   153			#else
   154				    char *p;
   155				    STRLEN len;
   156				    if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
   157					RETVAL = fsetpos(handle, (Fpos_t*)p);
   158				    }
   159				    else {
   160					RETVAL = -1;
   161					errno = EINVAL;
   162				    }
   163			#endif
   164				}
   165				else {
   166	      ######    	    RETVAL = -1;
   167	      ######    	    errno = EINVAL;
   168				}
   169			    OUTPUT:
   170				RETVAL
   171			
   172			MODULE = IO	PACKAGE = IO::File	PREFIX = f
   173			
   174			void
   175			new_tmpfile(packname = "IO::File")
   176			    const char *	packname
   177			    PREINIT:
   178	          16    	OutputStream fp;
   179	          16    	GV *gv;
   180			    CODE:
   181			#ifdef PerlIO
   182	          16    	fp = PerlIO_tmpfile();
   183			#else
   184				fp = tmpfile();
   185			#endif
   186	          16    	gv = (GV*)SvREFCNT_inc(newGVgen(packname));
   187	          16    	hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
   188	          16    	if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
   189	          16    	    ST(0) = sv_2mortal(newRV((SV*)gv));
   190	          16    	    sv_bless(ST(0), gv_stashpv(packname, TRUE));
   191	          16    	    SvREFCNT_dec(gv);   /* undo increment in newRV() */
   192				}
   193				else {
   194	      ######    	    ST(0) = &PL_sv_undef;
   195	      ######    	    SvREFCNT_dec(gv);
   196				}
   197			
   198			MODULE = IO	PACKAGE = IO::Poll
   199			
   200			void
   201			_poll(timeout,...)
   202				int timeout;
   203			PPCODE:
   204			{
   205			#ifdef HAS_POLL
   206	           2        const int nfd = (items - 1) / 2;
   207	           2        SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
   208	           2        struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
   209	           2        int i,j,ret;
   210	           4        for(i=1, j=0  ; j < nfd ; j++) {
   211	           2    	fds[j].fd = SvIV(ST(i));
   212	           2    	i++;
   213	           2    	fds[j].events = (short)SvIV(ST(i));
   214	           2    	i++;
   215	           2    	fds[j].revents = 0;
   216			    }
   217	           2        if((ret = poll(fds,nfd,timeout)) >= 0) {
   218	           4    	for(i=1, j=0 ; j < nfd ; j++) {
   219	           2    	    sv_setiv(ST(i), fds[j].fd); i++;
   220	           2    	    sv_setiv(ST(i), fds[j].revents); i++;
   221				}
   222			    }
   223	           2        SvREFCNT_dec(tmpsv);
   224	           2        XSRETURN_IV(ret);
   225			#else
   226				not_here("IO::Poll::poll");
   227			#endif
   228			}
   229			
   230			MODULE = IO	PACKAGE = IO::Handle	PREFIX = io_
   231			
   232			void
   233			io_blocking(handle,blk=-1)
   234				InputStream	handle
   235				int		blk
   236			PROTOTYPE: $;$
   237			CODE:
   238			{
   239	          10        const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
   240	          10        if(ret >= 0)
   241	          10    	XSRETURN_IV(ret);
   242			    else
   243	      ######    	XSRETURN_UNDEF;
   244			}
   245			
   246			MODULE = IO	PACKAGE = IO::Handle	PREFIX = f
   247			
   248			int
   249			ungetc(handle, c)
   250				InputStream	handle
   251				int		c
   252			    CODE:
   253	           2    	if (handle)
   254			#ifdef PerlIO
   255	           2    	    RETVAL = PerlIO_ungetc(handle, c);
   256			#else
   257				    RETVAL = ungetc(c, handle);
   258			#endif
   259				else {
   260	      ######    	    RETVAL = -1;
   261	      ######    	    errno = EINVAL;
   262				}
   263			    OUTPUT:
   264				RETVAL
   265			
   266			int
   267			ferror(handle)
   268				InputStream	handle
   269			    CODE:
   270	      ######    	if (handle)
   271			#ifdef PerlIO
   272	      ######    	    RETVAL = PerlIO_error(handle);
   273			#else
   274				    RETVAL = ferror(handle);
   275			#endif
   276				else {
   277	      ######    	    RETVAL = -1;
   278	      ######    	    errno = EINVAL;
   279				}
   280			    OUTPUT:
   281				RETVAL
   282			
   283			int
   284			clearerr(handle)
   285				InputStream	handle
   286			    CODE:
   287	      ######    	if (handle) {
   288			#ifdef PerlIO
   289	      ######    	    PerlIO_clearerr(handle);
   290			#else
   291				    clearerr(handle);
   292			#endif
   293	      ######    	    RETVAL = 0;
   294				}
   295				else {
   296	      ######    	    RETVAL = -1;
   297	      ######    	    errno = EINVAL;
   298				}
   299			    OUTPUT:
   300				RETVAL
   301			
   302			int
   303			untaint(handle)
   304			       SV *	handle
   305			    CODE:
   306			#ifdef IOf_UNTAINT
   307	           1    	IO * io;
   308	           1    	io = sv_2io(handle);
   309	           1    	if (io) {
   310	           1    	    IoFLAGS(io) |= IOf_UNTAINT;
   311	           1    	    RETVAL = 0;
   312				}
   313			        else {
   314			#endif
   315	      ######    	    RETVAL = -1;
   316	      ######    	    errno = EINVAL;
   317			#ifdef IOf_UNTAINT
   318				}
   319			#endif
   320			    OUTPUT:
   321				RETVAL
   322			
   323			SysRet
   324			fflush(handle)
   325				OutputStream	handle
   326			    CODE:
   327	           6    	if (handle)
   328			#ifdef PerlIO
   329	           4    	    RETVAL = PerlIO_flush(handle);
   330			#else
   331				    RETVAL = Fflush(handle);
   332			#endif
   333				else {
   334	           2    	    RETVAL = -1;
   335	           2    	    errno = EINVAL;
   336				}
   337			    OUTPUT:
   338				RETVAL
   339			
   340			void
   341			setbuf(handle, ...)
   342				OutputStream	handle
   343			    CODE:
   344	      ######    	if (handle)
   345			#ifdef PERLIO_IS_STDIO
   346			        {
   347				    char *buf = items == 2 && SvPOK(ST(1)) ?
   348				      sv_grow(ST(1), BUFSIZ) : 0;
   349				    setbuf(handle, buf);
   350				}
   351			#else
   352	      ######    	    not_here("IO::Handle::setbuf");
   353			#endif
   354			
   355			SysRet
   356			setvbuf(...)
   357			    CODE:
   358	      ######    	if (items != 4)
   359	      ######                Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
   360			#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
   361			    {
   362			        OutputStream	handle = 0;
   363				char *		buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
   364				int		type;
   365				int		size;
   366			
   367				if (items == 4) {
   368				    handle = IoOFP(sv_2io(ST(0)));
   369				    buf    = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
   370				    type   = (int)SvIV(ST(2));
   371				    size   = (int)SvIV(ST(3));
   372				}
   373				if (!handle)			/* Try input stream. */
   374				    handle = IoIFP(sv_2io(ST(0)));
   375				if (items == 4 && handle)
   376				    RETVAL = setvbuf(handle, buf, type, size);
   377				else {
   378				    RETVAL = -1;
   379				    errno = EINVAL;
   380				}
   381			    }
   382			#else
   383	      ######    	RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
   384			#endif
   385			    OUTPUT:
   386				RETVAL
   387			
   388			
   389			SysRet
   390			fsync(handle)
   391				OutputStream handle
   392			    CODE:
   393			#ifdef HAS_FSYNC
   394	      ######    	if(handle)
   395	      ######    	    RETVAL = fsync(PerlIO_fileno(handle));
   396				else {
   397	      ######    	    RETVAL = -1;
   398	      ######    	    errno = EINVAL;
   399				}
   400			#else
   401				RETVAL = (SysRet) not_here("IO::Handle::sync");
   402			#endif
   403			    OUTPUT:
   404				RETVAL
   405			
   406			
   407			MODULE = IO	PACKAGE = IO::Socket
   408			
   409			SysRet
   410			sockatmark (sock)
   411			   InputStream sock
   412			   PROTOTYPE: $
   413			   PREINIT:
   414	      ######         int fd;
   415			   CODE:
   416			   {
   417	      ######         fd = PerlIO_fileno(sock);
   418			#ifdef HAS_SOCKATMARK
   419	      ######         RETVAL = sockatmark(fd);
   420			#else
   421			     {
   422			       int flag = 0;
   423			#   ifdef SIOCATMARK
   424			#     if defined(NETWARE) || defined(WIN32)
   425			       if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
   426			#     else
   427			       if (ioctl(fd, SIOCATMARK, &flag) != 0)
   428			#     endif
   429				 XSRETURN_UNDEF;
   430			#   else
   431			       not_here("IO::Socket::atmark");
   432			#   endif
   433			       RETVAL = flag;
   434			     }
   435			#endif
   436			   }
   437			   OUTPUT:
   438			     RETVAL
   439			
   440			BOOT:
   441			{
   442	          99        HV *stash;
   443			    /*
   444			     * constant subs for IO::Poll
   445			     */
   446	          99        stash = gv_stashpvn("IO::Poll", 8, TRUE);
   447			#ifdef	POLLIN
   448	          99    	newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
   449			#endif
   450			#ifdef	POLLPRI
   451	          99            newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
   452			#endif
   453			#ifdef	POLLOUT
   454	          99            newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
   455			#endif
   456			#ifdef	POLLRDNORM
   457	          99            newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
   458			#endif
   459			#ifdef	POLLWRNORM
   460	          99            newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
   461			#endif
   462			#ifdef	POLLRDBAND
   463	          99            newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
   464			#endif
   465			#ifdef	POLLWRBAND
   466	          99            newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
   467			#endif
   468			#ifdef	POLLNORM
   469			        newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
   470			#endif
   471			#ifdef	POLLERR
   472	          99            newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
   473			#endif
   474			#ifdef	POLLHUP
   475	          99            newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
   476			#endif
   477			#ifdef	POLLNVAL
   478	          99            newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
   479			#endif
   480			    /*
   481			     * constant subs for IO::Handle
   482			     */
   483	          99        stash = gv_stashpvn("IO::Handle", 10, TRUE);
   484			#ifdef _IOFBF
   485	          99            newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
   486			#endif
   487			#ifdef _IOLBF
   488	          99            newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
   489			#endif
   490			#ifdef _IONBF
   491	          99            newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
   492			#endif
   493			#ifdef SEEK_SET
   494	          99            newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
   495			#endif
   496			#ifdef SEEK_CUR
   497	          99            newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
   498			#endif
   499			#ifdef SEEK_END
   500	          99            newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
   501			#endif
   502			}
   503			
   504