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