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 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 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 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