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