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