File Coverage

dist/IO/IO.xs
Criterion Covered Total %
statement 98 122 80.3
branch n/a
condition n/a
subroutine n/a
total 98 122 80.3


line stmt bran cond sub time code
1           /*
2           * Copyright (c) 1997-8 Graham Barr . 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
17           #endif
18           #if defined(I_FCNTL) || defined(HAS_FCNTL)
19           # include
20           #endif
21            
22           #ifndef SIOCATMARK
23           # ifdef I_SYS_SOCKIO
24           # include
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 0         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 36         if(!f) {
83 0         errno = EBADF;
84           return -1;
85           }
86 36         RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
87 36         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 36         RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
99            
100 36         if (block == 0) {
101 16         newmode &= ~O_NDELAY;
102 16         newmode |= O_NONBLOCK;
103 20         } else if (block > 0) {
104 10         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 36         if (newmode != mode) {
121 26         const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
122 26         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 1698         io_pp_nextstate(pTHX)
151           {
152           dVAR;
153 1698         COP *old_curcop = PL_curcop;
154 1698         OP *next = PL_ppaddr[PL_op->op_type](aTHX);
155 1698         PL_curcop = old_curcop;
156 1698         return next;
157           }
158            
159           static OP *
160 11552         io_ck_lineseq(pTHX_ OP *o)
161           {
162 11552         OP *kid = cBINOPo->op_first;
163 34656         for (; kid; kid = kid->op_sibling)
164 23104         if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
165 11552         kid->op_ppaddr = io_pp_nextstate;
166 11552         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 1100         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 1100         ST(0) = sv_newmortal();
189 1100         if (PerlIO_getpos(handle, ST(0)) != 0) {
190 0         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 0         errno = EINVAL;
208 0         ST(0) = &PL_sv_undef;
209           }
210            
211           SysRet
212           fsetpos(handle, pos)
213           InputStream handle
214           SV * pos
215           CODE:
216 1096         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 1096         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 0         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 350         fp = PerlIO_tmpfile();
261           #else
262           fp = tmpfile();
263           #endif
264 350         gv = (GV*)SvREFCNT_inc(newGVgen(packname));
265 350         if (gv)
266 350         (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
267 350         if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
268 350         ST(0) = sv_2mortal(newRV((SV*)gv));
269 350         sv_bless(ST(0), gv_stashpv(packname, TRUE));
270 350         SvREFCNT_dec(gv); /* undo increment in newRV() */
271           }
272           else {
273 0         ST(0) = &PL_sv_undef;
274 0         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 4         const int nfd = (items - 1) / 2;
286 4         SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
287 4         struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
288           int i,j,ret;
289 8         for(i=1, j=0 ; j < nfd ; j++) {
290 4         fds[j].fd = SvIV(ST(i));
291 4         i++;
292 4         fds[j].events = (short)SvIV(ST(i));
293 4         i++;
294 4         fds[j].revents = 0;
295           }
296 4         if((ret = poll(fds,nfd,timeout)) >= 0) {
297 4         for(i=1, j=0 ; j < nfd ; j++) {
298 4         sv_setiv(ST(i), fds[j].fd); i++;
299 4         sv_setiv(ST(i), fds[j].revents); i++;
300           }
301           }
302 4         SvREFCNT_dec(tmpsv);
303 4         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 36         const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
319 36         if(ret >= 0)
320 36         XSRETURN_IV(ret);
321           else
322 0         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 32828         if (handle) {
333           #ifdef PerlIO
334           UV v;
335            
336 32828         if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
337 0         croak("Negative character number in ungetc()");
338            
339 32828         v = SvUV(c);
340 32828         if (NATIVE_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
341 16684         RETVAL = PerlIO_ungetc(handle, (int)v);
342           else {
343           U8 buf[UTF8_MAXBYTES + 1], *end;
344           Size_t len;
345            
346 16144         if (!PerlIO_isutf8(handle))
347 0         croak("Wide character number in ungetc()");
348            
349           /* This doesn't warn for non-chars, surrogate, and
350           * above-Unicodes */
351 16144         end = uvchr_to_utf8_flags(buf, v, 0);
352 16144         len = end - buf;
353 16144         if (PerlIO_unread(handle, &buf, len) == len)
354 16144         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 0         errno = EINVAL;
365           }
366           OUTPUT:
367           RETVAL
368            
369           int
370           ferror(handle)
371           InputStream handle
372           CODE:
373 0         if (handle)
374           #ifdef PerlIO
375 0         RETVAL = PerlIO_error(handle);
376           #else
377           RETVAL = ferror(handle);
378           #endif
379           else {
380           RETVAL = -1;
381 0         errno = EINVAL;
382           }
383           OUTPUT:
384           RETVAL
385            
386           int
387           clearerr(handle)
388           InputStream handle
389           CODE:
390 50         if (handle) {
391           #ifdef PerlIO
392 50         PerlIO_clearerr(handle);
393           #else
394           clearerr(handle);
395           #endif
396           RETVAL = 0;
397           }
398           else {
399           RETVAL = -1;
400 0         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 24         io = sv_2io(handle);
412 24         if (io) {
413 24         IoFLAGS(io) |= IOf_UNTAINT;
414           RETVAL = 0;
415           }
416           else {
417           #endif
418           RETVAL = -1;
419 0         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 366         if (handle)
431           #ifdef PerlIO
432 366         RETVAL = PerlIO_flush(handle);
433           #else
434           RETVAL = Fflush(handle);
435           #endif
436           else {
437           RETVAL = -1;
438 0         errno = EINVAL;
439           }
440           OUTPUT:
441           RETVAL
442            
443           void
444           setbuf(handle, ...)
445           OutputStream handle
446           CODE:
447 0         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 0         if (items != 4)
462 0         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 2         handle = IoOFP(sv_2io(arg));
500 2         if (!handle)
501 2         handle = IoIFP(sv_2io(arg));
502 2         if(handle)
503 2         RETVAL = fsync(PerlIO_fileno(handle));
504           else {
505           RETVAL = -1;
506 0         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 1444         OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
518 1444         PL_check[OP_LINESEQ] = io_ck_lineseq;
519 1444         RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
520 1444         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 0         fd = PerlIO_fileno(sock);
536           #ifdef HAS_SOCKATMARK
537 0         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 1444         stash = gv_stashpvn("IO::Poll", 8, TRUE);
565           #ifdef POLLIN
566 1444         newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
567           #endif
568           #ifdef POLLPRI
569 1444         newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
570           #endif
571           #ifdef POLLOUT
572 1444         newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
573           #endif
574           #ifdef POLLRDNORM
575 1444         newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
576           #endif
577           #ifdef POLLWRNORM
578 1444         newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
579           #endif
580           #ifdef POLLRDBAND
581 1444         newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
582           #endif
583           #ifdef POLLWRBAND
584 1444         newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
585           #endif
586           #ifdef POLLNORM
587           newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
588           #endif
589           #ifdef POLLERR
590 1444         newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
591           #endif
592           #ifdef POLLHUP
593 1444         newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
594           #endif
595           #ifdef POLLNVAL
596 1444         newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
597           #endif
598           /*
599           * constant subs for IO::Handle
600           */
601 1444         stash = gv_stashpvn("IO::Handle", 10, TRUE);
602           #ifdef _IOFBF
603 1444         newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
604           #endif
605           #ifdef _IOLBF
606 1444         newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
607           #endif
608           #ifdef _IONBF
609 1444         newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
610           #endif
611           #ifdef SEEK_SET
612 1444         newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
613           #endif
614           #ifdef SEEK_CUR
615 1444         newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
616           #endif
617           #ifdef SEEK_END
618 1444         newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
619           #endif
620           }
621