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