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