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