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