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 #define NEED_newCONSTSUB
15 #define NEED_newSVpvn_flags
16 #include "ppport.h"
17 #include "poll.h"
18 #ifdef I_UNISTD
19 # include <unistd.h>
20 #endif
21 #if defined(I_FCNTL) || defined(HAS_FCNTL)
22 # include <fcntl.h>
23 #endif
24
25 #ifndef SIOCATMARK
26 # ifdef I_SYS_SOCKIO
27 # include <sys/sockio.h>
28 # endif
29 #endif
30
31 #ifdef PerlIO
32 #if defined(MACOS_TRADITIONAL) && defined(USE_SFIO)
33 #define PERLIO_IS_STDIO 1
34 #undef setbuf
35 #undef setvbuf
36 #define setvbuf _stdsetvbuf
37 #define setbuf(f,b) ( __sf_setbuf(f,b) )
38 #endif
39 typedef int SysRet;
40 typedef PerlIO * InputStream;
41 typedef PerlIO * OutputStream;
42 #else
43 #define PERLIO_IS_STDIO 1
44 typedef int SysRet;
45 typedef FILE * InputStream;
46 typedef FILE * OutputStream;
47 #endif
48
49 #define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
50
51 #ifndef __attribute__noreturn__
52 # define __attribute__noreturn__
53 #endif
54
55 #ifndef NORETURN_FUNCTION_END
56 # define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
57 #endif
58
59 static int not_here(const char *s) __attribute__noreturn__;
60 static int
not_here(const char * s)61 not_here(const char *s)
62 {
63 croak("%s not implemented on this architecture", s);
64 NORETURN_FUNCTION_END;
65 }
66
67 #ifndef PerlIO
68 #define PerlIO_fileno(f) fileno(f)
69 #endif
70
71 static int
io_blocking(pTHX_ InputStream f,int block)72 io_blocking(pTHX_ InputStream f, int block)
73 {
74 int fd = -1;
75 if (!f) {
76 errno = EBADF;
77 return -1;
78 }
79 fd = PerlIO_fileno(f);
80 if (fd < 0) {
81 errno = EBADF;
82 return -1;
83 }
84 #if defined(HAS_FCNTL)
85 int RETVAL = fcntl(fd, F_GETFL, 0);
86 if (RETVAL >= 0) {
87 int mode = RETVAL;
88 int newmode = mode;
89 # ifdef O_NONBLOCK
90 /* POSIX style */
91
92 # ifndef O_NDELAY
93 # define O_NDELAY O_NONBLOCK
94 # endif
95 /* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
96 * after a successful F_SETFL of an O_NONBLOCK. */
97 RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
98
99 if (block == 0) {
100 newmode &= ~O_NDELAY;
101 newmode |= O_NONBLOCK;
102 } else if (block > 0) {
103 newmode &= ~(O_NDELAY|O_NONBLOCK);
104 }
105 # else
106 /* Not POSIX - better have O_NDELAY or we can't cope.
107 * for BSD-ish machines this is an acceptable alternative
108 * for SysV we can't tell "would block" from EOF but that is
109 * the way SysV is...
110 */
111 RETVAL = RETVAL & O_NDELAY ? 0 : 1;
112
113 if (block == 0) {
114 newmode |= O_NDELAY;
115 } else if (block > 0) {
116 newmode &= ~O_NDELAY;
117 }
118 # endif
119 if (newmode != mode) {
120 const int ret = fcntl(fd, F_SETFL, newmode);
121 if (ret < 0)
122 RETVAL = ret;
123 }
124 }
125 return RETVAL;
126 #elif defined(WIN32)
127 if (block >= 0) {
128 unsigned long flags = !block;
129 /* ioctl claims to take char* but really needs a u_long sized buffer */
130
131 if (ioctl(fd, FIONBIO, (char*)&flags) != 0)
132 return -1;
133 /* Win32 has no way to get the current blocking status of a socket.
134 * However, we don't want to just return undef, because there's no way
135 * to tell that the ioctl succeeded.
136 */
137 return flags;
138 }
139 /* TODO: Perhaps set $! to ENOTSUP? */
140 return -1;
141 #else
142 return -1;
143 #endif
144 }
145
146
147 MODULE = IO PACKAGE = IO::Seekable PREFIX = f
148
149 void
150 fgetpos(handle)
151 InputStream handle
152 CODE:
153 if (handle) {
154 #ifdef PerlIO
155 #if PERL_VERSION_LT(5,8,0)
156 Fpos_t pos;
157 ST(0) = sv_newmortal();
158 if (PerlIO_getpos(handle, &pos) != 0) {
159 ST(0) = &PL_sv_undef;
160 }
161 else {
162 sv_setpvn(ST(0), (char *)&pos, sizeof(Fpos_t));
163 }
164 #else
165 ST(0) = sv_newmortal();
166 if (PerlIO_getpos(handle, ST(0)) != 0) {
167 ST(0) = &PL_sv_undef;
168 }
169 #endif
170 #else
171 Fpos_t pos;
172 if (fgetpos(handle, &pos)) {
173 ST(0) = &PL_sv_undef;
174 } else {
175 # if PERL_VERSION_GE(5,11,0)
176 ST(0) = newSVpvn_flags((char*)&pos, sizeof(Fpos_t), SVs_TEMP);
177 # else
178 ST(0) = sv_2mortal(newSVpvn((char*)&pos, sizeof(Fpos_t)));
179 # endif
180 }
181 #endif
182 }
183 else {
184 errno = EINVAL;
185 ST(0) = &PL_sv_undef;
186 }
187
188 SysRet
189 fsetpos(handle, pos)
190 InputStream handle
191 SV * pos
192 CODE:
193 if (handle) {
194 #ifdef PerlIO
195 #if PERL_VERSION_LT(5,8,0)
196 char *p;
197 STRLEN len;
198 if (SvOK(pos) && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
199 RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
200 }
201 else {
202 RETVAL = -1;
203 errno = EINVAL;
204 }
205 #else
206 RETVAL = PerlIO_setpos(handle, pos);
207 #endif
208 #else
209 char *p;
210 STRLEN len;
211 if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
212 RETVAL = fsetpos(handle, (Fpos_t*)p);
213 }
214 else {
215 RETVAL = -1;
216 errno = EINVAL;
217 }
218 #endif
219 }
220 else {
221 RETVAL = -1;
222 errno = EINVAL;
223 }
224 OUTPUT:
225 RETVAL
226
227 MODULE = IO PACKAGE = IO::File PREFIX = f
228
229 void
230 new_tmpfile(packname = "IO::File")
231 const char * packname
232 PREINIT:
233 OutputStream fp;
234 GV *gv;
235 CODE:
236 #ifdef PerlIO
237 fp = PerlIO_tmpfile();
238 #else
239 fp = tmpfile();
240 #endif
241 gv = (GV*)SvREFCNT_inc(newGVgen(packname));
242 if (gv)
243 (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
244 if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
245 ST(0) = sv_2mortal(newRV_inc((SV*)gv));
246 sv_bless(ST(0), gv_stashpv(packname, TRUE));
247 SvREFCNT_dec(gv); /* undo increment in newRV() */
248 }
249 else {
250 ST(0) = &PL_sv_undef;
251 SvREFCNT_dec(gv);
252 }
253
254 MODULE = IO PACKAGE = IO::Poll
255
256 void
_poll(timeout,...)257 _poll(timeout,...)
258 int timeout;
259 PPCODE:
260 {
261 #ifdef HAS_POLL
262 const int nfd = (items - 1) / 2;
263 SV *tmpsv = sv_2mortal(NEWSV(999,nfd * sizeof(struct pollfd)));
264 /* We should pass _some_ valid pointer even if nfd is zero, but it
265 * doesn't matter what it is, since we're telling it to not check any fds.
266 */
267 struct pollfd *fds = nfd ? (struct pollfd *)SvPVX(tmpsv) : (struct pollfd *)tmpsv;
268 int i,j,ret;
269 for(i=1, j=0 ; j < nfd ; j++) {
270 fds[j].fd = SvIV(ST(i));
271 i++;
272 fds[j].events = (short)SvIV(ST(i));
273 i++;
274 fds[j].revents = 0;
275 }
276 if((ret = poll(fds,nfd,timeout)) >= 0) {
277 for(i=1, j=0 ; j < nfd ; j++) {
278 sv_setiv(ST(i), fds[j].fd); i++;
279 sv_setiv(ST(i), fds[j].revents); i++;
280 }
281 }
282 XSRETURN_IV(ret);
283 #else
284 not_here("IO::Poll::poll");
285 #endif
286 }
287
288 MODULE = IO PACKAGE = IO::Handle PREFIX = io_
289
290 void
291 io_blocking(handle,blk=-1)
292 InputStream handle
293 int blk
294 PROTOTYPE: $;$
295 CODE:
296 {
297 const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
298 if(ret >= 0)
299 XSRETURN_IV(ret);
300 else
301 XSRETURN_UNDEF;
302 }
303
304 MODULE = IO PACKAGE = IO::Handle PREFIX = f
305
306 int
307 ungetc(handle, c)
308 InputStream handle
309 SV * c
310 CODE:
311 if (handle) {
312 #ifdef PerlIO
313 UV v;
314
315 if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
316 croak("Negative character number in ungetc()");
317
318 v = SvUV(c);
319 if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
320 RETVAL = PerlIO_ungetc(handle, (int)v);
321 else {
322 U8 buf[UTF8_MAXBYTES + 1], *end;
323 Size_t len;
324
325 if (!PerlIO_isutf8(handle))
326 croak("Wide character number in ungetc()");
327
328 /* This doesn't warn for non-chars, surrogate, and
329 * above-Unicodes */
330 end = uvchr_to_utf8_flags(buf, v, 0);
331 len = end - buf;
332 if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
333 XSRETURN_UV(v);
334 else
335 RETVAL = EOF;
336 }
337 #else
338 RETVAL = ungetc((int)SvIV(c), handle);
339 #endif
340 }
341 else {
342 RETVAL = -1;
343 errno = EINVAL;
344 }
345 OUTPUT:
346 RETVAL
347
348 int
349 ferror(handle)
350 SV * handle
351 PREINIT:
352 IO *io = sv_2io(handle);
353 InputStream in = IoIFP(io);
354 OutputStream out = IoOFP(io);
355 CODE:
356 if (in)
357 #ifdef PerlIO
358 RETVAL = PerlIO_error(in) || (out && in != out && PerlIO_error(out));
359 #else
360 RETVAL = ferror(in) || (out && in != out && ferror(out));
361 #endif
362 else {
363 RETVAL = -1;
364 errno = EINVAL;
365 }
366 OUTPUT:
367 RETVAL
368
369 int
370 clearerr(handle)
371 SV * handle
372 PREINIT:
373 IO *io = sv_2io(handle);
374 InputStream in = IoIFP(io);
375 OutputStream out = IoOFP(io);
376 CODE:
377 if (handle) {
378 #ifdef PerlIO
379 PerlIO_clearerr(in);
380 if (in != out)
381 PerlIO_clearerr(out);
382 #else
383 clearerr(in);
384 if (in != out)
385 clearerr(out);
386 #endif
387 RETVAL = 0;
388 }
389 else {
390 RETVAL = -1;
391 errno = EINVAL;
392 }
393 OUTPUT:
394 RETVAL
395
396 int
397 untaint(handle)
398 SV * handle
399 CODE:
400 #ifdef IOf_UNTAINT
401 IO * io;
402 io = sv_2io(handle);
403 if (io) {
404 IoFLAGS(io) |= IOf_UNTAINT;
405 RETVAL = 0;
406 }
407 else {
408 #endif
409 RETVAL = -1;
410 errno = EINVAL;
411 #ifdef IOf_UNTAINT
412 }
413 #endif
414 OUTPUT:
415 RETVAL
416
417 SysRet
418 fflush(handle)
419 OutputStream handle
420 CODE:
421 if (handle)
422 #ifdef PerlIO
423 RETVAL = PerlIO_flush(handle);
424 #else
425 RETVAL = Fflush(handle);
426 #endif
427 else {
428 RETVAL = -1;
429 errno = EINVAL;
430 }
431 OUTPUT:
432 RETVAL
433
434 void
435 setbuf(handle, ...)
436 OutputStream handle
437 CODE:
438 if (handle)
439 #ifdef PERLIO_IS_STDIO
440 {
441 char *buf = items == 2 && SvPOK(ST(1)) ?
442 sv_grow(ST(1), BUFSIZ) : 0;
443 setbuf(handle, buf);
444 }
445 #else
446 not_here("IO::Handle::setbuf");
447 #endif
448
449 SysRet
450 setvbuf(...)
451 CODE:
452 if (items != 4)
453 Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
454 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
455 {
456 OutputStream handle = 0;
457 char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
458 int type;
459 int size;
460
461 if (items == 4) {
462 handle = IoOFP(sv_2io(ST(0)));
463 buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
464 type = (int)SvIV(ST(2));
465 size = (int)SvIV(ST(3));
466 }
467 if (!handle) /* Try input stream. */
468 handle = IoIFP(sv_2io(ST(0)));
469 if (items == 4 && handle)
470 RETVAL = setvbuf(handle, buf, type, size);
471 else {
472 RETVAL = -1;
473 errno = EINVAL;
474 }
475 }
476 #else
477 RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
478 #endif
479 OUTPUT:
480 RETVAL
481
482
483 SysRet
484 fsync(arg)
485 SV * arg
486 PREINIT:
487 OutputStream handle = NULL;
488 CODE:
489 #if defined(HAS_FSYNC) || defined(_WIN32)
490 handle = IoOFP(sv_2io(arg));
491 if (!handle)
492 handle = IoIFP(sv_2io(arg));
493 if (handle) {
494 int fd = PerlIO_fileno(handle);
495 if (fd >= 0) {
496 # ifdef _WIN32
497 RETVAL = _commit(fd);
498 # else
499 RETVAL = fsync(fd);
500 # endif
501 } else {
502 RETVAL = -1;
503 errno = EBADF;
504 }
505 } else {
506 RETVAL = -1;
507 errno = EINVAL;
508 }
509 #else
510 RETVAL = (SysRet) not_here("IO::Handle::sync");
511 #endif
512 OUTPUT:
513 RETVAL
514
515 # To make these two work correctly with the open pragma, the readline op
516 # needs to pick up the lexical hints at the method's callsite. This doesn't
517 # work in pure Perl, because the hints are read from the most recent nextstate,
518 # and the nextstate of the Perl subroutines show *here* hold the lexical state
519 # for the IO package.
520 #
521 # There's no clean way to implement this - this approach, while complex, seems
522 # to be the most robust, and avoids manipulating external state (ie op checkers)
523 #
524 # sub getline {
525 # @_ == 1 or croak 'usage: $io->getline()';
526 # my $this = shift;
527 # return scalar <$this>;
528 # }
529 #
530 # sub getlines {
531 # @_ == 1 or croak 'usage: $io->getlines()';
532 # wantarray or
533 # croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
534 # my $this = shift;
535 # return <$this>;
536 # }
537
538 # If this is deprecated, should it warn, and should it be removed at some point?
539 # *gets = \&getline; # deprecated
540
541 void
542 getlines(...)
543 ALIAS:
544 IO::Handle::getline = 1
545 IO::Handle::gets = 2
546 INIT:
547 UNOP myop;
548 SV *io;
549 OP *was = PL_op;
550 PPCODE:
551 if (items != 1)
552 Perl_croak(aTHX_ "usage: $io->%s()", ix ? "getline" : "getlines");
553 if (!ix && GIMME_V != G_LIST)
554 Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline");
555 Zero(&myop, 1, UNOP);
556 #if PERL_VERSION_GE(5,39,6)
557 myop.op_flags = (ix ? (OPf_WANT_SCALAR | OPf_STACKED) : OPf_WANT_LIST);
558 #else
559 myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED;
560 #endif
561 myop.op_ppaddr = PL_ppaddr[OP_READLINE];
562 myop.op_type = OP_READLINE;
563 myop.op_next = NULL; /* return from the runops loop below after 1 op */
564 /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful
565 state check for PL_op->op_type == OP_READLINE */
566 PL_op = (OP *) &myop;
567 io = ST(0);
568 /* For scalar functions (getline/gets), provide a target on the stack,
569 * as we don't have a pad entry. */
570 #if PERL_VERSION_GE(5,39,6)
571 if (ix)
572 #endif
573 PUSHs(sv_newmortal());
574 XPUSHs(io);
575 PUTBACK;
576 /* call a new runops loop for just the one op rather than just calling
577 * pp_readline directly, as the former will handle the call coming
578 * from a ref-counted stack */
579 /* And effectively we get away with tail calling pp_readline, as it stacks
580 exactly the return value(s) we need to return. */
581 CALLRUNOPS(aTHX);
582 PL_op = was;
583 /* And we don't want to reach the line
584 PL_stack_sp = sp;
585 that xsubpp adds after our body becase PL_stack_sp is correct, not sp */
586 return;
587
588 MODULE = IO PACKAGE = IO::Socket
589
590 SysRet
591 sockatmark (sock)
592 InputStream sock
593 PROTOTYPE: $
594 PREINIT:
595 int fd;
596 CODE:
597 fd = PerlIO_fileno(sock);
598 if (fd < 0) {
599 errno = EBADF;
600 RETVAL = -1;
601 }
602 #ifdef HAS_SOCKATMARK
603 else {
604 RETVAL = sockatmark(fd);
605 }
606 #else
607 else {
608 int flag = 0;
609 # ifdef SIOCATMARK
610 # if defined(NETWARE) || defined(WIN32)
611 if (ioctl(fd, SIOCATMARK, (char*)&flag) != 0)
612 # else
613 if (ioctl(fd, SIOCATMARK, &flag) != 0)
614 # endif
615 XSRETURN_UNDEF;
616 # else
617 not_here("IO::Socket::atmark");
618 # endif
619 RETVAL = flag;
620 }
621 #endif
622 OUTPUT:
623 RETVAL
624
625 BOOT:
626 {
627 HV *stash;
628 /*
629 * constant subs for IO::Poll
630 */
631 stash = gv_stashpvn("IO::Poll", 8, TRUE);
632 #ifdef POLLIN
633 newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
634 #endif
635 #ifdef POLLPRI
636 newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
637 #endif
638 #ifdef POLLOUT
639 newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
640 #endif
641 #ifdef POLLRDNORM
642 newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
643 #endif
644 #ifdef POLLWRNORM
645 newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
646 #endif
647 #ifdef POLLRDBAND
648 newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
649 #endif
650 #ifdef POLLWRBAND
651 newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
652 #endif
653 #ifdef POLLNORM
654 newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
655 #endif
656 #ifdef POLLERR
657 newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
658 #endif
659 #ifdef POLLHUP
660 newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
661 #endif
662 #ifdef POLLNVAL
663 newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
664 #endif
665 /*
666 * constant subs for IO::Handle
667 */
668 stash = gv_stashpvn("IO::Handle", 10, TRUE);
669 #ifdef _IOFBF
670 newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
671 #endif
672 #ifdef _IOLBF
673 newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
674 #endif
675 #ifdef _IONBF
676 newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
677 #endif
678 #ifdef SEEK_SET
679 newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
680 #endif
681 #ifdef SEEK_CUR
682 newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
683 #endif
684 #ifdef SEEK_END
685 newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
686 #endif
687 }
688
689