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