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