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 #ifndef OpSIBLING
60 # define OpSIBLING(o) (o)->op_sibling
61 #endif
62
63 static int not_here(const char *s) __attribute__noreturn__;
64 static int
not_here(const char * s)65 not_here(const char *s)
66 {
67 croak("%s not implemented on this architecture", s);
68 NORETURN_FUNCTION_END;
69 }
70
71 #ifndef PerlIO
72 #define PerlIO_fileno(f) fileno(f)
73 #endif
74
75 static int
io_blocking(pTHX_ InputStream f,int block)76 io_blocking(pTHX_ InputStream f, int block)
77 {
78 int fd = -1;
79 #if defined(HAS_FCNTL)
80 int RETVAL;
81 if (!f) {
82 errno = EBADF;
83 return -1;
84 }
85 fd = PerlIO_fileno(f);
86 if (fd < 0) {
87 errno = EBADF;
88 return -1;
89 }
90 RETVAL = fcntl(fd, F_GETFL, 0);
91 if (RETVAL >= 0) {
92 int mode = RETVAL;
93 int newmode = mode;
94 #ifdef O_NONBLOCK
95 /* POSIX style */
96
97 # ifndef O_NDELAY
98 # define O_NDELAY O_NONBLOCK
99 # endif
100 /* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
101 * after a successful F_SETFL of an O_NONBLOCK. */
102 RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
103
104 if (block == 0) {
105 newmode &= ~O_NDELAY;
106 newmode |= O_NONBLOCK;
107 } else if (block > 0) {
108 newmode &= ~(O_NDELAY|O_NONBLOCK);
109 }
110 #else
111 /* Not POSIX - better have O_NDELAY or we can't cope.
112 * for BSD-ish machines this is an acceptable alternative
113 * for SysV we can't tell "would block" from EOF but that is
114 * the way SysV is...
115 */
116 RETVAL = RETVAL & O_NDELAY ? 0 : 1;
117
118 if (block == 0) {
119 newmode |= O_NDELAY;
120 } else if (block > 0) {
121 newmode &= ~O_NDELAY;
122 }
123 #endif
124 if (newmode != mode) {
125 const int ret = fcntl(fd, F_SETFL, newmode);
126 if (ret < 0)
127 RETVAL = ret;
128 }
129 }
130 return RETVAL;
131 #else
132 # ifdef WIN32
133 if (block >= 0) {
134 unsigned long flags = !block;
135 /* ioctl claims to take char* but really needs a u_long sized buffer */
136 const int ret = ioctl(fd, FIONBIO, (char*)&flags);
137 if (ret != 0)
138 return -1;
139 /* Win32 has no way to get the current blocking status of a socket.
140 * However, we don't want to just return undef, because there's no way
141 * to tell that the ioctl succeeded.
142 */
143 return flags;
144 }
145 /* TODO: Perhaps set $! to ENOTSUP? */
146 return -1;
147 # else
148 return -1;
149 # endif
150 #endif
151 }
152
153
154 MODULE = IO PACKAGE = IO::Seekable PREFIX = f
155
156 void
157 fgetpos(handle)
158 InputStream handle
159 CODE:
160 if (handle) {
161 #ifdef PerlIO
162 #if PERL_VERSION_LT(5,8,0)
163 Fpos_t pos;
164 ST(0) = sv_newmortal();
165 if (PerlIO_getpos(handle, &pos) != 0) {
166 ST(0) = &PL_sv_undef;
167 }
168 else {
169 sv_setpvn(ST(0), (char *)&pos, sizeof(Fpos_t));
170 }
171 #else
172 ST(0) = sv_newmortal();
173 if (PerlIO_getpos(handle, ST(0)) != 0) {
174 ST(0) = &PL_sv_undef;
175 }
176 #endif
177 #else
178 Fpos_t pos;
179 if (fgetpos(handle, &pos)) {
180 ST(0) = &PL_sv_undef;
181 } else {
182 # if PERL_VERSION_GE(5,11,0)
183 ST(0) = newSVpvn_flags((char*)&pos, sizeof(Fpos_t), SVs_TEMP);
184 # else
185 ST(0) = sv_2mortal(newSVpvn((char*)&pos, sizeof(Fpos_t)));
186 # endif
187 }
188 #endif
189 }
190 else {
191 errno = EINVAL;
192 ST(0) = &PL_sv_undef;
193 }
194
195 SysRet
196 fsetpos(handle, pos)
197 InputStream handle
198 SV * pos
199 CODE:
200 if (handle) {
201 #ifdef PerlIO
202 #if PERL_VERSION_LT(5,8,0)
203 char *p;
204 STRLEN len;
205 if (SvOK(pos) && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
206 RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
207 }
208 else {
209 RETVAL = -1;
210 errno = EINVAL;
211 }
212 #else
213 RETVAL = PerlIO_setpos(handle, pos);
214 #endif
215 #else
216 char *p;
217 STRLEN len;
218 if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
219 RETVAL = fsetpos(handle, (Fpos_t*)p);
220 }
221 else {
222 RETVAL = -1;
223 errno = EINVAL;
224 }
225 #endif
226 }
227 else {
228 RETVAL = -1;
229 errno = EINVAL;
230 }
231 OUTPUT:
232 RETVAL
233
234 MODULE = IO PACKAGE = IO::File PREFIX = f
235
236 void
237 new_tmpfile(packname = "IO::File")
238 const char * packname
239 PREINIT:
240 OutputStream fp;
241 GV *gv;
242 CODE:
243 #ifdef PerlIO
244 fp = PerlIO_tmpfile();
245 #else
246 fp = tmpfile();
247 #endif
248 gv = (GV*)SvREFCNT_inc(newGVgen(packname));
249 if (gv)
250 (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
251 if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
252 ST(0) = sv_2mortal(newRV_inc((SV*)gv));
253 sv_bless(ST(0), gv_stashpv(packname, TRUE));
254 SvREFCNT_dec(gv); /* undo increment in newRV() */
255 }
256 else {
257 ST(0) = &PL_sv_undef;
258 SvREFCNT_dec(gv);
259 }
260
261 MODULE = IO PACKAGE = IO::Poll
262
263 void
_poll(timeout,...)264 _poll(timeout,...)
265 int timeout;
266 PPCODE:
267 {
268 #ifdef HAS_POLL
269 const int nfd = (items - 1) / 2;
270 SV *tmpsv = sv_2mortal(NEWSV(999,nfd * sizeof(struct pollfd)));
271 /* We should pass _some_ valid pointer even if nfd is zero, but it
272 * doesn't matter what it is, since we're telling it to not check any fds.
273 */
274 struct pollfd *fds = nfd ? (struct pollfd *)SvPVX(tmpsv) : (struct pollfd *)tmpsv;
275 int i,j,ret;
276 for(i=1, j=0 ; j < nfd ; j++) {
277 fds[j].fd = SvIV(ST(i));
278 i++;
279 fds[j].events = (short)SvIV(ST(i));
280 i++;
281 fds[j].revents = 0;
282 }
283 if((ret = poll(fds,nfd,timeout)) >= 0) {
284 for(i=1, j=0 ; j < nfd ; j++) {
285 sv_setiv(ST(i), fds[j].fd); i++;
286 sv_setiv(ST(i), fds[j].revents); i++;
287 }
288 }
289 XSRETURN_IV(ret);
290 #else
291 not_here("IO::Poll::poll");
292 #endif
293 }
294
295 MODULE = IO PACKAGE = IO::Handle PREFIX = io_
296
297 void
298 io_blocking(handle,blk=-1)
299 InputStream handle
300 int blk
301 PROTOTYPE: $;$
302 CODE:
303 {
304 const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
305 if(ret >= 0)
306 XSRETURN_IV(ret);
307 else
308 XSRETURN_UNDEF;
309 }
310
311 MODULE = IO PACKAGE = IO::Handle PREFIX = f
312
313 int
314 ungetc(handle, c)
315 InputStream handle
316 SV * c
317 CODE:
318 if (handle) {
319 #ifdef PerlIO
320 UV v;
321
322 if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
323 croak("Negative character number in ungetc()");
324
325 v = SvUV(c);
326 if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
327 RETVAL = PerlIO_ungetc(handle, (int)v);
328 else {
329 U8 buf[UTF8_MAXBYTES + 1], *end;
330 Size_t len;
331
332 if (!PerlIO_isutf8(handle))
333 croak("Wide character number in ungetc()");
334
335 /* This doesn't warn for non-chars, surrogate, and
336 * above-Unicodes */
337 end = uvchr_to_utf8_flags(buf, v, 0);
338 len = end - buf;
339 if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
340 XSRETURN_UV(v);
341 else
342 RETVAL = EOF;
343 }
344 #else
345 RETVAL = ungetc((int)SvIV(c), handle);
346 #endif
347 }
348 else {
349 RETVAL = -1;
350 errno = EINVAL;
351 }
352 OUTPUT:
353 RETVAL
354
355 int
356 ferror(handle)
357 SV * handle
358 PREINIT:
359 IO *io = sv_2io(handle);
360 InputStream in = IoIFP(io);
361 OutputStream out = IoOFP(io);
362 CODE:
363 if (in)
364 #ifdef PerlIO
365 RETVAL = PerlIO_error(in) || (out && in != out && PerlIO_error(out));
366 #else
367 RETVAL = ferror(in) || (out && in != out && ferror(out));
368 #endif
369 else {
370 RETVAL = -1;
371 errno = EINVAL;
372 }
373 OUTPUT:
374 RETVAL
375
376 int
377 clearerr(handle)
378 SV * handle
379 PREINIT:
380 IO *io = sv_2io(handle);
381 InputStream in = IoIFP(io);
382 OutputStream out = IoOFP(io);
383 CODE:
384 if (handle) {
385 #ifdef PerlIO
386 PerlIO_clearerr(in);
387 if (in != out)
388 PerlIO_clearerr(out);
389 #else
390 clearerr(in);
391 if (in != out)
392 clearerr(out);
393 #endif
394 RETVAL = 0;
395 }
396 else {
397 RETVAL = -1;
398 errno = EINVAL;
399 }
400 OUTPUT:
401 RETVAL
402
403 int
404 untaint(handle)
405 SV * handle
406 CODE:
407 #ifdef IOf_UNTAINT
408 IO * io;
409 io = sv_2io(handle);
410 if (io) {
411 IoFLAGS(io) |= IOf_UNTAINT;
412 RETVAL = 0;
413 }
414 else {
415 #endif
416 RETVAL = -1;
417 errno = EINVAL;
418 #ifdef IOf_UNTAINT
419 }
420 #endif
421 OUTPUT:
422 RETVAL
423
424 SysRet
425 fflush(handle)
426 OutputStream handle
427 CODE:
428 if (handle)
429 #ifdef PerlIO
430 RETVAL = PerlIO_flush(handle);
431 #else
432 RETVAL = Fflush(handle);
433 #endif
434 else {
435 RETVAL = -1;
436 errno = EINVAL;
437 }
438 OUTPUT:
439 RETVAL
440
441 void
442 setbuf(handle, ...)
443 OutputStream handle
444 CODE:
445 if (handle)
446 #ifdef PERLIO_IS_STDIO
447 {
448 char *buf = items == 2 && SvPOK(ST(1)) ?
449 sv_grow(ST(1), BUFSIZ) : 0;
450 setbuf(handle, buf);
451 }
452 #else
453 not_here("IO::Handle::setbuf");
454 #endif
455
456 SysRet
457 setvbuf(...)
458 CODE:
459 if (items != 4)
460 Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
461 #if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
462 {
463 OutputStream handle = 0;
464 char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
465 int type;
466 int size;
467
468 if (items == 4) {
469 handle = IoOFP(sv_2io(ST(0)));
470 buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
471 type = (int)SvIV(ST(2));
472 size = (int)SvIV(ST(3));
473 }
474 if (!handle) /* Try input stream. */
475 handle = IoIFP(sv_2io(ST(0)));
476 if (items == 4 && handle)
477 RETVAL = setvbuf(handle, buf, type, size);
478 else {
479 RETVAL = -1;
480 errno = EINVAL;
481 }
482 }
483 #else
484 RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
485 #endif
486 OUTPUT:
487 RETVAL
488
489
490 SysRet
491 fsync(arg)
492 SV * arg
493 PREINIT:
494 OutputStream handle = NULL;
495 CODE:
496 #if defined(HAS_FSYNC) || defined(_WIN32)
497 handle = IoOFP(sv_2io(arg));
498 if (!handle)
499 handle = IoIFP(sv_2io(arg));
500 if (handle) {
501 int fd = PerlIO_fileno(handle);
502 if (fd >= 0) {
503 # ifdef _WIN32
504 RETVAL = _commit(fd);
505 # else
506 RETVAL = fsync(fd);
507 # endif
508 } else {
509 RETVAL = -1;
510 errno = EBADF;
511 }
512 } else {
513 RETVAL = -1;
514 errno = EINVAL;
515 }
516 #else
517 RETVAL = (SysRet) not_here("IO::Handle::sync");
518 #endif
519 OUTPUT:
520 RETVAL
521
522 # To make these two work correctly with the open pragma, the readline op
523 # needs to pick up the lexical hints at the method's callsite. This doesn't
524 # work in pure Perl, because the hints are read from the most recent nextstate,
525 # and the nextstate of the Perl subroutines show *here* hold the lexical state
526 # for the IO package.
527 #
528 # There's no clean way to implement this - this approach, while complex, seems
529 # to be the most robust, and avoids manipulating external state (ie op checkers)
530 #
531 # sub getline {
532 # @_ == 1 or croak 'usage: $io->getline()';
533 # my $this = shift;
534 # return scalar <$this>;
535 # }
536 #
537 # sub getlines {
538 # @_ == 1 or croak 'usage: $io->getlines()';
539 # wantarray or
540 # croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
541 # my $this = shift;
542 # return <$this>;
543 # }
544
545 # If this is deprecated, should it warn, and should it be removed at some point?
546 # *gets = \&getline; # deprecated
547
548 void
549 getlines(...)
550 ALIAS:
551 IO::Handle::getline = 1
552 IO::Handle::gets = 2
553 INIT:
554 UNOP myop;
555 SV *io;
556 OP *was = PL_op;
557 PPCODE:
558 if (items != 1)
559 Perl_croak(aTHX_ "usage: $io->%s()", ix ? "getline" : "getlines");
560 if (!ix && GIMME_V != G_LIST)
561 Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline");
562 Zero(&myop, 1, UNOP);
563 myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED;
564 myop.op_ppaddr = PL_ppaddr[OP_READLINE];
565 myop.op_type = OP_READLINE;
566 /* I don't know if we need this, but it's correct as far as the control flow
567 goes. However, if we *do* need it, do we need to set anything else up? */
568 myop.op_next = PL_op->op_next;
569 /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful
570 state check for PL_op->op_type == OP_READLINE */
571 PL_op = (OP *) &myop;
572 io = ST(0);
573 /* Our target (which we need to provide, as we don't have a pad entry.
574 I think that this is only needed for G_SCALAR - maybe we can get away
575 with NULL for list context? */
576 PUSHs(sv_newmortal());
577 XPUSHs(io);
578 PUTBACK;
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 PL_ppaddr[OP_READLINE](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