move Time-HiRes from cpan to dist
[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 = 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     SvREFCNT_dec(tmpsv);
341     XSRETURN_IV(ret);
342 #else
343         not_here("IO::Poll::poll");
344 #endif
345 }
346
347 MODULE = IO     PACKAGE = IO::Handle    PREFIX = io_
348
349 void
350 io_blocking(handle,blk=-1)
351         InputStream     handle
352         int             blk
353 PROTOTYPE: $;$
354 CODE:
355 {
356     const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
357     if(ret >= 0)
358         XSRETURN_IV(ret);
359     else
360         XSRETURN_UNDEF;
361 }
362
363 MODULE = IO     PACKAGE = IO::Handle    PREFIX = f
364
365 int
366 ungetc(handle, c)
367         InputStream     handle
368         SV *            c
369     CODE:
370         if (handle) {
371 #ifdef PerlIO
372             UV v;
373
374             if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
375                 croak("Negative character number in ungetc()");
376
377             v = SvUV(c);
378             if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
379                 RETVAL = PerlIO_ungetc(handle, (int)v);
380             else {
381                 U8 buf[UTF8_MAXBYTES + 1], *end;
382                 Size_t len;
383
384                 if (!PerlIO_isutf8(handle))
385                     croak("Wide character number in ungetc()");
386
387                 /* This doesn't warn for non-chars, surrogate, and
388                  * above-Unicodes */
389                 end = uvchr_to_utf8_flags(buf, v, 0);
390                 len = end - buf;
391                 if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
392                     XSRETURN_UV(v);
393                 else
394                     RETVAL = EOF;
395             }
396 #else
397             RETVAL = ungetc((int)SvIV(c), handle);
398 #endif
399         }
400         else {
401             RETVAL = -1;
402             errno = EINVAL;
403         }
404     OUTPUT:
405         RETVAL
406
407 int
408 ferror(handle)
409         InputStream     handle
410     CODE:
411         if (handle)
412 #ifdef PerlIO
413             RETVAL = PerlIO_error(handle);
414 #else
415             RETVAL = ferror(handle);
416 #endif
417         else {
418             RETVAL = -1;
419             errno = EINVAL;
420         }
421     OUTPUT:
422         RETVAL
423
424 int
425 clearerr(handle)
426         InputStream     handle
427     CODE:
428         if (handle) {
429 #ifdef PerlIO
430             PerlIO_clearerr(handle);
431 #else
432             clearerr(handle);
433 #endif
434             RETVAL = 0;
435         }
436         else {
437             RETVAL = -1;
438             errno = EINVAL;
439         }
440     OUTPUT:
441         RETVAL
442
443 int
444 untaint(handle)
445        SV *     handle
446     CODE:
447 #ifdef IOf_UNTAINT
448         IO * io;
449         io = sv_2io(handle);
450         if (io) {
451             IoFLAGS(io) |= IOf_UNTAINT;
452             RETVAL = 0;
453         }
454         else {
455 #endif
456             RETVAL = -1;
457             errno = EINVAL;
458 #ifdef IOf_UNTAINT
459         }
460 #endif
461     OUTPUT:
462         RETVAL
463
464 SysRet
465 fflush(handle)
466         OutputStream    handle
467     CODE:
468         if (handle)
469 #ifdef PerlIO
470             RETVAL = PerlIO_flush(handle);
471 #else
472             RETVAL = Fflush(handle);
473 #endif
474         else {
475             RETVAL = -1;
476             errno = EINVAL;
477         }
478     OUTPUT:
479         RETVAL
480
481 void
482 setbuf(handle, ...)
483         OutputStream    handle
484     CODE:
485         if (handle)
486 #ifdef PERLIO_IS_STDIO
487         {
488             char *buf = items == 2 && SvPOK(ST(1)) ?
489               sv_grow(ST(1), BUFSIZ) : 0;
490             setbuf(handle, buf);
491         }
492 #else
493             not_here("IO::Handle::setbuf");
494 #endif
495
496 SysRet
497 setvbuf(...)
498     CODE:
499         if (items != 4)
500             Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
501 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
502     {
503         OutputStream    handle = 0;
504         char *          buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
505         int             type;
506         int             size;
507
508         if (items == 4) {
509             handle = IoOFP(sv_2io(ST(0)));
510             buf    = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
511             type   = (int)SvIV(ST(2));
512             size   = (int)SvIV(ST(3));
513         }
514         if (!handle)                    /* Try input stream. */
515             handle = IoIFP(sv_2io(ST(0)));
516         if (items == 4 && handle)
517             RETVAL = setvbuf(handle, buf, type, size);
518         else {
519             RETVAL = -1;
520             errno = EINVAL;
521         }
522     }
523 #else
524         RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
525 #endif
526     OUTPUT:
527         RETVAL
528
529
530 SysRet
531 fsync(arg)
532         SV * arg
533     PREINIT:
534         OutputStream handle = NULL;
535     CODE:
536 #ifdef HAS_FSYNC
537         handle = IoOFP(sv_2io(arg));
538         if (!handle)
539             handle = IoIFP(sv_2io(arg));
540         if (handle) {
541             int fd = PerlIO_fileno(handle);
542             if (fd >= 0) {
543                 RETVAL = fsync(fd);
544             } else {
545                 RETVAL = -1;
546                 errno = EBADF;
547             }
548         } else {
549             RETVAL = -1;
550             errno = EINVAL;
551         }
552 #else
553         RETVAL = (SysRet) not_here("IO::Handle::sync");
554 #endif
555     OUTPUT:
556         RETVAL
557
558 SV *
559 _create_getline_subs(const char *code)
560     CODE:
561         OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
562         PL_check[OP_LINESEQ] = io_ck_lineseq;
563         RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
564         PL_check[OP_LINESEQ] = io_old_ck_lineseq;
565     OUTPUT:
566         RETVAL
567
568
569 MODULE = IO     PACKAGE = IO::Socket
570
571 SysRet
572 sockatmark (sock)
573    InputStream sock
574    PROTOTYPE: $
575    PREINIT:
576      int fd;
577    CODE:
578      fd = PerlIO_fileno(sock);
579      if (fd < 0) {
580        errno = EBADF;
581        RETVAL = -1;
582      }
583 #ifdef HAS_SOCKATMARK
584      else {
585        RETVAL = sockatmark(fd);
586      }
587 #else
588      else {
589        int flag = 0;
590 #   ifdef SIOCATMARK
591 #     if defined(NETWARE) || defined(WIN32)
592        if (ioctl(fd, SIOCATMARK, (char*)&flag) != 0)
593 #     else
594        if (ioctl(fd, SIOCATMARK, &flag) != 0)
595 #     endif
596          XSRETURN_UNDEF;
597 #   else
598        not_here("IO::Socket::atmark");
599 #   endif
600        RETVAL = flag;
601      }
602 #endif
603    OUTPUT:
604      RETVAL
605
606 BOOT:
607 {
608     HV *stash;
609     /*
610      * constant subs for IO::Poll
611      */
612     stash = gv_stashpvn("IO::Poll", 8, TRUE);
613 #ifdef  POLLIN
614         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
615 #endif
616 #ifdef  POLLPRI
617         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
618 #endif
619 #ifdef  POLLOUT
620         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
621 #endif
622 #ifdef  POLLRDNORM
623         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
624 #endif
625 #ifdef  POLLWRNORM
626         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
627 #endif
628 #ifdef  POLLRDBAND
629         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
630 #endif
631 #ifdef  POLLWRBAND
632         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
633 #endif
634 #ifdef  POLLNORM
635         newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
636 #endif
637 #ifdef  POLLERR
638         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
639 #endif
640 #ifdef  POLLHUP
641         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
642 #endif
643 #ifdef  POLLNVAL
644         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
645 #endif
646     /*
647      * constant subs for IO::Handle
648      */
649     stash = gv_stashpvn("IO::Handle", 10, TRUE);
650 #ifdef _IOFBF
651         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
652 #endif
653 #ifdef _IOLBF
654         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
655 #endif
656 #ifdef _IONBF
657         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
658 #endif
659 #ifdef SEEK_SET
660         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
661 #endif
662 #ifdef SEEK_CUR
663         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
664 #endif
665 #ifdef SEEK_END
666         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
667 #endif
668 }
669