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