This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate change #14062 from macperl;
[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 #ifdef MACOS_TRADITIONAL
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
53 not_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
64 static int
65 io_blocking(pTHX_ InputStream f, int block)
66 {
67     int RETVAL;
68     if(!f) {
69         errno = EBADF;
70         return -1;
71     }
72 #if defined(HAS_FCNTL)
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
152 MODULE = IO     PACKAGE = IO::Seekable  PREFIX = f
153
154 void
155 fgetpos(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
177 SysRet
178 fsetpos(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
204 MODULE = IO     PACKAGE = IO::File      PREFIX = f
205
206 void
207 new_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
230 MODULE = IO     PACKAGE = IO::Poll
231
232 void
233 _poll(timeout,...)
234         int timeout;
235 PPCODE:
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 = 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
262 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
263
264 void
265 io_blocking(handle,blk=-1)
266         InputStream     handle
267         int             blk
268 PROTOTYPE: $;$
269 CODE:
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
278 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
279
280 int
281 ungetc(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
298 int
299 ferror(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
315 int
316 clearerr(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
334 int
335 untaint(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
355 SysRet
356 fflush(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
372 void
373 setbuf(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
387 SysRet
388 setvbuf(...)
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
421 SysRet
422 fsync(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
439 MODULE = IO     PACKAGE = IO::Socket
440
441 SysRet
442 sockatmark (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
472 BOOT:
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