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