1 /* 2 * perlio.c 3 * Copyright (c) 1996-2006, Nick Ing-Simmons 4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public License 7 * or the Artistic License, as specified in the README file. 8 */ 9 10 /* 11 * Hour after hour for nearly three weary days he had jogged up and down, 12 * over passes, and through long dales, and across many streams. 13 * 14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"] 15 */ 16 17 /* This file contains the functions needed to implement PerlIO, which 18 * is Perl's private replacement for the C stdio library. This is used 19 * by default unless you compile with -Uuseperlio or run with 20 * PERLIO=:stdio (but don't do this unless you know what you're doing) 21 */ 22 23 /* 24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get 25 * at the dispatch tables, even when we do not need it for other reasons. 26 * Invent a dSYS macro to abstract this out 27 */ 28 #ifdef PERL_IMPLICIT_SYS 29 #define dSYS dTHX 30 #else 31 #define dSYS dNOOP 32 #endif 33 34 #define PERLIO_NOT_STDIO 0 35 /* 36 * This file provides those parts of PerlIO abstraction 37 * which are not #defined in perlio.h. 38 * Which these are depends on various Configure #ifdef's 39 */ 40 41 #include "EXTERN.h" 42 #define PERL_IN_PERLIO_C 43 #include "perl.h" 44 45 #ifdef PERL_IMPLICIT_CONTEXT 46 #undef dSYS 47 #define dSYS dTHX 48 #endif 49 50 #include "XSUB.h" 51 52 #ifdef VMS 53 #include <rms.h> 54 #endif 55 56 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags) 57 58 /* Call the callback or PerlIOBase, and return failure. */ 59 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ 60 if (PerlIOValid(f)) { \ 61 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ 62 if (tab && tab->callback) \ 63 return (*tab->callback) args; \ 64 else \ 65 return PerlIOBase_ ## base args; \ 66 } \ 67 else \ 68 SETERRNO(EBADF, SS_IVCHAN); \ 69 return failure 70 71 /* Call the callback or fail, and return failure. */ 72 #define Perl_PerlIO_or_fail(f, callback, failure, args) \ 73 if (PerlIOValid(f)) { \ 74 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ 75 if (tab && tab->callback) \ 76 return (*tab->callback) args; \ 77 SETERRNO(EINVAL, LIB_INVARG); \ 78 } \ 79 else \ 80 SETERRNO(EBADF, SS_IVCHAN); \ 81 return failure 82 83 /* Call the callback or PerlIOBase, and be void. */ 84 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \ 85 if (PerlIOValid(f)) { \ 86 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ 87 if (tab && tab->callback) \ 88 (*tab->callback) args; \ 89 else \ 90 PerlIOBase_ ## base args; \ 91 } \ 92 else \ 93 SETERRNO(EBADF, SS_IVCHAN) 94 95 /* Call the callback or fail, and be void. */ 96 #define Perl_PerlIO_or_fail_void(f, callback, args) \ 97 if (PerlIOValid(f)) { \ 98 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ 99 if (tab && tab->callback) \ 100 (*tab->callback) args; \ 101 else \ 102 SETERRNO(EINVAL, LIB_INVARG); \ 103 } \ 104 else \ 105 SETERRNO(EBADF, SS_IVCHAN) 106 107 #if defined(__osf__) && _XOPEN_SOURCE < 500 108 extern int fseeko(FILE *, off_t, int); 109 extern off_t ftello(FILE *); 110 #endif 111 112 #define NATIVE_0xd CR_NATIVE 113 #define NATIVE_0xa LF_NATIVE 114 115 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode); 116 117 int 118 perlsio_binmode(FILE *fp, int iotype, int mode) 119 { 120 /* 121 * This used to be contents of do_binmode in doio.c 122 */ 123 #ifdef DOSISH 124 dTHX; 125 PERL_UNUSED_ARG(iotype); 126 #ifdef NETWARE 127 if (PerlLIO_setmode(fp, mode) != -1) { 128 #else 129 if (PerlLIO_setmode(fileno(fp), mode) != -1) { 130 #endif 131 return 1; 132 } 133 else 134 return 0; 135 #else 136 # if defined(USEMYBINMODE) 137 dTHX; 138 # if defined(__CYGWIN__) 139 PERL_UNUSED_ARG(iotype); 140 # endif 141 if (my_binmode(fp, iotype, mode) != FALSE) 142 return 1; 143 else 144 return 0; 145 # else 146 PERL_UNUSED_ARG(fp); 147 PERL_UNUSED_ARG(iotype); 148 PERL_UNUSED_ARG(mode); 149 return 1; 150 # endif 151 #endif 152 } 153 154 #ifndef O_ACCMODE 155 #define O_ACCMODE 3 /* Assume traditional implementation */ 156 #endif 157 158 int 159 PerlIO_intmode2str(int rawmode, char *mode, int *writing) 160 { 161 const int result = rawmode & O_ACCMODE; 162 int ix = 0; 163 int ptype; 164 switch (result) { 165 case O_RDONLY: 166 ptype = IoTYPE_RDONLY; 167 break; 168 case O_WRONLY: 169 ptype = IoTYPE_WRONLY; 170 break; 171 case O_RDWR: 172 default: 173 ptype = IoTYPE_RDWR; 174 break; 175 } 176 if (writing) 177 *writing = (result != O_RDONLY); 178 179 if (result == O_RDONLY) { 180 mode[ix++] = 'r'; 181 } 182 #ifdef O_APPEND 183 else if (rawmode & O_APPEND) { 184 mode[ix++] = 'a'; 185 if (result != O_WRONLY) 186 mode[ix++] = '+'; 187 } 188 #endif 189 else { 190 if (result == O_WRONLY) 191 mode[ix++] = 'w'; 192 else { 193 mode[ix++] = 'r'; 194 mode[ix++] = '+'; 195 } 196 } 197 #if O_BINARY != 0 198 /* Unless O_BINARY is different from zero, bit-and:ing 199 * with it won't do much good. */ 200 if (rawmode & O_BINARY) 201 mode[ix++] = 'b'; 202 # endif 203 mode[ix] = '\0'; 204 return ptype; 205 } 206 207 #ifndef PERLIO_LAYERS 208 int 209 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 210 { 211 if (!names || !*names 212 || strEQ(names, ":crlf") 213 || strEQ(names, ":raw") 214 || strEQ(names, ":bytes") 215 ) { 216 return 0; 217 } 218 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names); 219 /* 220 * NOTREACHED 221 */ 222 return -1; 223 } 224 225 void 226 PerlIO_destruct(pTHX) 227 { 228 } 229 230 int 231 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) 232 { 233 return perlsio_binmode(fp, iotype, mode); 234 } 235 236 PerlIO * 237 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 238 { 239 #if defined(PERL_MICRO) || defined(__SYMBIAN32__) 240 return NULL; 241 #elif defined(PERL_IMPLICIT_SYS) 242 return PerlSIO_fdupopen(f); 243 #else 244 # ifdef WIN32 245 return win32_fdupopen(f); 246 # else 247 if (f) { 248 const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f)); 249 if (fd >= 0) { 250 char mode[8]; 251 # ifdef DJGPP 252 const int omode = djgpp_get_stream_mode(f); 253 # else 254 const int omode = fcntl(fd, F_GETFL); 255 # endif 256 PerlIO_intmode2str(omode,mode,NULL); 257 /* the r+ is a hack */ 258 return PerlIO_fdopen(fd, mode); 259 } 260 return NULL; 261 } 262 else { 263 SETERRNO(EBADF, SS_IVCHAN); 264 } 265 # endif 266 return NULL; 267 #endif 268 } 269 270 271 /* 272 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries 273 */ 274 275 PerlIO * 276 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 277 int imode, int perm, PerlIO *old, int narg, SV **args) 278 { 279 if (narg) { 280 if (narg > 1) { 281 Perl_croak(aTHX_ "More than one argument to open"); 282 } 283 if (*args == &PL_sv_undef) 284 return PerlIO_tmpfile(); 285 else { 286 STRLEN len; 287 const char *name = SvPV_const(*args, len); 288 if (!IS_SAFE_PATHNAME(name, len, "open")) 289 return NULL; 290 291 if (*mode == IoTYPE_NUMERIC) { 292 fd = PerlLIO_open3_cloexec(name, imode, perm); 293 if (fd >= 0) 294 return PerlIO_fdopen(fd, mode + 1); 295 } 296 else if (old) { 297 return PerlIO_reopen(name, mode, old); 298 } 299 else { 300 return PerlIO_open(name, mode); 301 } 302 } 303 } 304 else { 305 return PerlIO_fdopen(fd, (char *) mode); 306 } 307 return NULL; 308 } 309 310 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ 311 XS(XS_PerlIO__Layer__find) 312 { 313 dXSARGS; 314 if (items < 2) 315 Perl_croak(aTHX_ "Usage class->find(name[,load])"); 316 else { 317 const char * const name = SvPV_nolen_const(ST(1)); 318 ST(0) = (strEQ(name, "crlf") 319 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; 320 XSRETURN(1); 321 } 322 } 323 324 325 void 326 Perl_boot_core_PerlIO(pTHX) 327 { 328 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 329 } 330 331 #endif 332 333 334 /*======================================================================================*/ 335 /* 336 * Implement all the PerlIO interface ourselves. 337 */ 338 339 #include "perliol.h" 340 341 void 342 PerlIO_debug(const char *fmt, ...) 343 { 344 va_list ap; 345 dSYS; 346 347 if (!DEBUG_i_TEST) 348 return; 349 350 va_start(ap, fmt); 351 352 if (!PL_perlio_debug_fd) { 353 if (!TAINTING_get && 354 PerlProc_getuid() == PerlProc_geteuid() && 355 PerlProc_getgid() == PerlProc_getegid()) { 356 const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); 357 if (s && *s) 358 PL_perlio_debug_fd = PerlLIO_open3_cloexec(s, 359 O_WRONLY | O_CREAT | O_APPEND, 0666); 360 else 361 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ 362 } else { 363 /* tainting or set*id, so ignore the environment and send the 364 debug output to stderr, like other -D switches. */ 365 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ 366 } 367 } 368 if (PL_perlio_debug_fd > 0) { 369 #ifdef USE_ITHREADS 370 const char * const s = CopFILE(PL_curcop); 371 /* Use fixed buffer as sv_catpvf etc. needs SVs */ 372 char buffer[1024]; 373 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); 374 # ifdef USE_QUADMATH 375 # ifdef HAS_VSNPRINTF 376 /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf() 377 should be, otherwise the system isn't likely to support quadmath. 378 Nothing should be calling PerlIO_debug() with floating point anyway. 379 */ 380 const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); 381 # else 382 STATIC_ASSERT_STMT(0); 383 # endif 384 # else 385 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); 386 # endif 387 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); 388 #else 389 const char *s = CopFILE(PL_curcop); 390 STRLEN len; 391 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)", 392 (IV) CopLINE(PL_curcop)); 393 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); 394 395 s = SvPV_const(sv, len); 396 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len)); 397 SvREFCNT_dec(sv); 398 #endif 399 } 400 va_end(ap); 401 } 402 403 /*--------------------------------------------------------------------------------------*/ 404 405 /* 406 * Inner level routines 407 */ 408 409 /* check that the head field of each layer points back to the head */ 410 411 #ifdef DEBUGGING 412 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f) 413 static void 414 PerlIO_verify_head(pTHX_ PerlIO *f) 415 { 416 PerlIOl *head, *p; 417 int seen = 0; 418 #ifndef PERL_IMPLICIT_SYS 419 PERL_UNUSED_CONTEXT; 420 #endif 421 if (!PerlIOValid(f)) 422 return; 423 p = head = PerlIOBase(f)->head; 424 assert(p); 425 do { 426 assert(p->head == head); 427 if (p == (PerlIOl*)f) 428 seen = 1; 429 p = p->next; 430 } while (p); 431 assert(seen); 432 } 433 #else 434 # define VERIFY_HEAD(f) 435 #endif 436 437 438 /* 439 * Table of pointers to the PerlIO structs (malloc'ed) 440 */ 441 #define PERLIO_TABLE_SIZE 64 442 443 static void 444 PerlIO_init_table(pTHX) 445 { 446 if (PL_perlio) 447 return; 448 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl); 449 } 450 451 452 453 PerlIO * 454 PerlIO_allocate(pTHX) 455 { 456 /* 457 * Find a free slot in the table, allocating new table as necessary 458 */ 459 PerlIOl **last; 460 PerlIOl *f; 461 last = &PL_perlio; 462 while ((f = *last)) { 463 int i; 464 last = (PerlIOl **) (f); 465 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 466 if (!((++f)->next)) { 467 goto good_exit; 468 } 469 } 470 } 471 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl); 472 if (!f) { 473 return NULL; 474 } 475 *last = (PerlIOl*) f++; 476 477 good_exit: 478 f->flags = 0; /* lockcnt */ 479 f->tab = NULL; 480 f->head = f; 481 return (PerlIO*) f; 482 } 483 484 #undef PerlIO_fdupopen 485 PerlIO * 486 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 487 { 488 if (PerlIOValid(f)) { 489 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 490 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) ); 491 if (tab && tab->Dup) 492 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); 493 else { 494 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); 495 } 496 } 497 else 498 SETERRNO(EBADF, SS_IVCHAN); 499 500 return NULL; 501 } 502 503 void 504 PerlIO_cleantable(pTHX_ PerlIOl **tablep) 505 { 506 PerlIOl * const table = *tablep; 507 if (table) { 508 int i; 509 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0])); 510 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { 511 PerlIOl * const f = table + i; 512 if (f->next) { 513 PerlIO_close(&(f->next)); 514 } 515 } 516 Safefree(table); 517 *tablep = NULL; 518 } 519 } 520 521 522 PerlIO_list_t * 523 PerlIO_list_alloc(pTHX) 524 { 525 PerlIO_list_t *list; 526 PERL_UNUSED_CONTEXT; 527 Newxz(list, 1, PerlIO_list_t); 528 list->refcnt = 1; 529 return list; 530 } 531 532 void 533 PerlIO_list_free(pTHX_ PerlIO_list_t *list) 534 { 535 if (list) { 536 if (--list->refcnt == 0) { 537 if (list->array) { 538 IV i; 539 for (i = 0; i < list->cur; i++) 540 SvREFCNT_dec(list->array[i].arg); 541 Safefree(list->array); 542 } 543 Safefree(list); 544 } 545 } 546 } 547 548 void 549 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) 550 { 551 PerlIO_pair_t *p; 552 PERL_UNUSED_CONTEXT; 553 554 if (list->cur >= list->len) { 555 const IV new_len = list->len + 8; 556 if (list->array) 557 Renew(list->array, new_len, PerlIO_pair_t); 558 else 559 Newx(list->array, new_len, PerlIO_pair_t); 560 list->len = new_len; 561 } 562 p = &(list->array[list->cur++]); 563 p->funcs = funcs; 564 if ((p->arg = arg)) { 565 SvREFCNT_inc_simple_void_NN(arg); 566 } 567 } 568 569 PerlIO_list_t * 570 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) 571 { 572 PerlIO_list_t *list = NULL; 573 if (proto) { 574 int i; 575 list = PerlIO_list_alloc(aTHX); 576 for (i=0; i < proto->cur; i++) { 577 SV *arg = proto->array[i].arg; 578 #ifdef USE_ITHREADS 579 if (arg && param) 580 arg = sv_dup(arg, param); 581 #else 582 PERL_UNUSED_ARG(param); 583 #endif 584 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); 585 } 586 } 587 return list; 588 } 589 590 void 591 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) 592 { 593 #ifdef USE_ITHREADS 594 PerlIOl **table = &proto->Iperlio; 595 PerlIOl *f; 596 PL_perlio = NULL; 597 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); 598 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); 599 PerlIO_init_table(aTHX); 600 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) ); 601 while ((f = *table)) { 602 int i; 603 table = (PerlIOl **) (f++); 604 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 605 if (f->next) { 606 (void) fp_dup(&(f->next), 0, param); 607 } 608 f++; 609 } 610 } 611 #else 612 PERL_UNUSED_CONTEXT; 613 PERL_UNUSED_ARG(proto); 614 PERL_UNUSED_ARG(param); 615 #endif 616 } 617 618 void 619 PerlIO_destruct(pTHX) 620 { 621 PerlIOl **table = &PL_perlio; 622 PerlIOl *f; 623 #ifdef USE_ITHREADS 624 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) ); 625 #endif 626 while ((f = *table)) { 627 int i; 628 table = (PerlIOl **) (f++); 629 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 630 PerlIO *x = &(f->next); 631 const PerlIOl *l; 632 while ((l = *x)) { 633 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { 634 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) ); 635 PerlIO_flush(x); 636 PerlIO_pop(aTHX_ x); 637 } 638 else { 639 x = PerlIONext(x); 640 } 641 } 642 f++; 643 } 644 } 645 } 646 647 void 648 PerlIO_pop(pTHX_ PerlIO *f) 649 { 650 const PerlIOl *l = *f; 651 VERIFY_HEAD(f); 652 if (l) { 653 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, 654 l->tab ? l->tab->name : "(Null)") ); 655 if (l->tab && l->tab->Popped) { 656 /* 657 * If popped returns non-zero do not free its layer structure 658 * it has either done so itself, or it is shared and still in 659 * use 660 */ 661 if ((*l->tab->Popped) (aTHX_ f) != 0) 662 return; 663 } 664 if (PerlIO_lockcnt(f)) { 665 /* we're in use; defer freeing the structure */ 666 PerlIOBase(f)->flags = PERLIO_F_CLEARED; 667 PerlIOBase(f)->tab = NULL; 668 } 669 else { 670 *f = l->next; 671 Safefree(l); 672 } 673 674 } 675 } 676 677 /* Return as an array the stack of layers on a filehandle. Note that 678 * the stack is returned top-first in the array, and there are three 679 * times as many array elements as there are layers in the stack: the 680 * first element of a layer triplet is the name, the second one is the 681 * arguments, and the third one is the flags. */ 682 683 AV * 684 PerlIO_get_layers(pTHX_ PerlIO *f) 685 { 686 AV * const av = newAV(); 687 688 if (PerlIOValid(f)) { 689 PerlIOl *l = PerlIOBase(f); 690 691 while (l) { 692 /* There is some collusion in the implementation of 693 XS_PerlIO_get_layers - it knows that name and flags are 694 generated as fresh SVs here, and takes advantage of that to 695 "copy" them by taking a reference. If it changes here, it needs 696 to change there too. */ 697 SV * const name = l->tab && l->tab->name ? 698 newSVpv(l->tab->name, 0) : &PL_sv_undef; 699 SV * const arg = l->tab && l->tab->Getarg ? 700 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; 701 av_push(av, name); 702 av_push(av, arg); 703 av_push(av, newSViv((IV)l->flags)); 704 l = l->next; 705 } 706 } 707 708 return av; 709 } 710 711 /*--------------------------------------------------------------------------------------*/ 712 /* 713 * XS Interface for perl code 714 */ 715 716 PerlIO_funcs * 717 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) 718 { 719 720 IV i; 721 if ((SSize_t) len <= 0) 722 len = strlen(name); 723 for (i = 0; i < PL_known_layers->cur; i++) { 724 PerlIO_funcs * const f = PL_known_layers->array[i].funcs; 725 const STRLEN this_len = strlen(f->name); 726 if (this_len == len && memEQ(f->name, name, len)) { 727 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); 728 return f; 729 } 730 } 731 if (load && PL_subname && PL_def_layerlist 732 && PL_def_layerlist->cur >= 2) { 733 if (PL_in_load_module) { 734 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); 735 return NULL; 736 } else { 737 SV * const pkgsv = newSVpvs("PerlIO"); 738 SV * const layer = newSVpvn(name, len); 739 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); 740 ENTER; 741 SAVEBOOL(PL_in_load_module); 742 if (cv) { 743 SAVEGENERICSV(PL_warnhook); 744 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv))); 745 } 746 PL_in_load_module = TRUE; 747 /* 748 * The two SVs are magically freed by load_module 749 */ 750 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); 751 LEAVE; 752 return PerlIO_find_layer(aTHX_ name, len, 0); 753 } 754 } 755 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) ); 756 return NULL; 757 } 758 759 #ifdef USE_ATTRIBUTES_FOR_PERLIO 760 761 static int 762 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) 763 { 764 if (SvROK(sv)) { 765 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); 766 PerlIO * const ifp = IoIFP(io); 767 PerlIO * const ofp = IoOFP(io); 768 Perl_warn(aTHX_ "set %" SVf " %p %p %p", 769 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); 770 } 771 return 0; 772 } 773 774 static int 775 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) 776 { 777 if (SvROK(sv)) { 778 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); 779 PerlIO * const ifp = IoIFP(io); 780 PerlIO * const ofp = IoOFP(io); 781 Perl_warn(aTHX_ "get %" SVf " %p %p %p", 782 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); 783 } 784 return 0; 785 } 786 787 static int 788 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) 789 { 790 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv)); 791 return 0; 792 } 793 794 static int 795 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) 796 { 797 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv)); 798 return 0; 799 } 800 801 MGVTBL perlio_vtab = { 802 perlio_mg_get, 803 perlio_mg_set, 804 NULL, /* len */ 805 perlio_mg_clear, 806 perlio_mg_free 807 }; 808 809 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */ 810 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) 811 { 812 dXSARGS; 813 SV * const sv = SvRV(ST(1)); 814 AV * const av = newAV(); 815 MAGIC *mg; 816 int count = 0; 817 int i; 818 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0); 819 SvRMAGICAL_off(sv); 820 mg = mg_find(sv, PERL_MAGIC_ext); 821 mg->mg_virtual = &perlio_vtab; 822 mg_magical(sv); 823 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv)); 824 for (i = 2; i < items; i++) { 825 STRLEN len; 826 const char * const name = SvPV_const(ST(i), len); 827 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1); 828 if (layer) { 829 av_push(av, SvREFCNT_inc_simple_NN(layer)); 830 } 831 else { 832 ST(count) = ST(i); 833 count++; 834 } 835 } 836 SvREFCNT_dec(av); 837 XSRETURN(count); 838 } 839 840 #endif /* USE_ATTRIBUTES_FOR_PERLIO */ 841 842 SV * 843 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) 844 { 845 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD); 846 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash); 847 return sv; 848 } 849 850 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */ 851 XS(XS_PerlIO__Layer__NoWarnings) 852 { 853 /* This is used as a %SIG{__WARN__} handler to suppress warnings 854 during loading of layers. 855 */ 856 dXSARGS; 857 PERL_UNUSED_VAR(items); 858 DEBUG_i( 859 if (items) 860 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) ); 861 XSRETURN(0); 862 } 863 864 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ 865 XS(XS_PerlIO__Layer__find) 866 { 867 dXSARGS; 868 if (items < 2) 869 Perl_croak(aTHX_ "Usage class->find(name[,load])"); 870 else { 871 STRLEN len; 872 const char * const name = SvPV_const(ST(1), len); 873 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; 874 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); 875 ST(0) = 876 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : 877 &PL_sv_undef; 878 XSRETURN(1); 879 } 880 } 881 882 void 883 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) 884 { 885 if (!PL_known_layers) 886 PL_known_layers = PerlIO_list_alloc(aTHX); 887 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL); 888 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) ); 889 } 890 891 int 892 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) 893 { 894 if (names) { 895 const char *s = names; 896 while (*s) { 897 while (isSPACE(*s) || *s == ':') 898 s++; 899 if (*s) { 900 STRLEN llen = 0; 901 const char *e = s; 902 const char *as = NULL; 903 STRLEN alen = 0; 904 if (!isIDFIRST(*s)) { 905 /* 906 * Message is consistent with how attribute lists are 907 * passed. Even though this means "foo : : bar" is 908 * seen as an invalid separator character. 909 */ 910 const char q = ((*s == '\'') ? '"' : '\''); 911 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), 912 "Invalid separator character %c%c%c in PerlIO layer specification %s", 913 q, *s, q, s); 914 SETERRNO(EINVAL, LIB_INVARG); 915 return -1; 916 } 917 do { 918 e++; 919 } while (isWORDCHAR(*e)); 920 llen = e - s; 921 if (*e == '(') { 922 int nesting = 1; 923 as = ++e; 924 while (nesting) { 925 switch (*e++) { 926 case ')': 927 if (--nesting == 0) 928 alen = (e - 1) - as; 929 break; 930 case '(': 931 ++nesting; 932 break; 933 case '\\': 934 /* 935 * It's a nul terminated string, not allowed 936 * to \ the terminating null. Anything other 937 * character is passed over. 938 */ 939 if (*e++) { 940 break; 941 } 942 /* Fall through */ 943 case '\0': 944 e--; 945 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), 946 "Argument list not closed for PerlIO layer \"%.*s\"", 947 (int) (e - s), s); 948 return -1; 949 default: 950 /* 951 * boring. 952 */ 953 break; 954 } 955 } 956 } 957 if (e > s) { 958 PerlIO_funcs * const layer = 959 PerlIO_find_layer(aTHX_ s, llen, 1); 960 if (layer) { 961 SV *arg = NULL; 962 if (as) 963 arg = newSVpvn(as, alen); 964 PerlIO_list_push(aTHX_ av, layer, 965 (arg) ? arg : &PL_sv_undef); 966 SvREFCNT_dec(arg); 967 } 968 else { 969 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", 970 (int) llen, s); 971 return -1; 972 } 973 } 974 s = e; 975 } 976 } 977 } 978 return 0; 979 } 980 981 void 982 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) 983 { 984 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio; 985 #ifdef PERLIO_USING_CRLF 986 tab = &PerlIO_crlf; 987 #else 988 if (PerlIO_stdio.Set_ptrcnt) 989 tab = &PerlIO_stdio; 990 #endif 991 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) ); 992 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef); 993 } 994 995 SV * 996 PerlIO_arg_fetch(PerlIO_list_t *av, IV n) 997 { 998 return av->array[n].arg; 999 } 1000 1001 PerlIO_funcs * 1002 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) 1003 { 1004 if (n >= 0 && n < av->cur) { 1005 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n, 1006 av->array[n].funcs->name) ); 1007 return av->array[n].funcs; 1008 } 1009 if (!def) 1010 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); 1011 return def; 1012 } 1013 1014 IV 1015 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1016 { 1017 PERL_UNUSED_ARG(mode); 1018 PERL_UNUSED_ARG(arg); 1019 PERL_UNUSED_ARG(tab); 1020 if (PerlIOValid(f)) { 1021 PerlIO_flush(f); 1022 PerlIO_pop(aTHX_ f); 1023 return 0; 1024 } 1025 return -1; 1026 } 1027 1028 PERLIO_FUNCS_DECL(PerlIO_remove) = { 1029 sizeof(PerlIO_funcs), 1030 "pop", 1031 0, 1032 PERLIO_K_DUMMY | PERLIO_K_UTF8, 1033 PerlIOPop_pushed, 1034 NULL, 1035 PerlIOBase_open, 1036 NULL, 1037 NULL, 1038 NULL, 1039 NULL, 1040 NULL, 1041 NULL, 1042 NULL, 1043 NULL, 1044 NULL, 1045 NULL, 1046 NULL, /* flush */ 1047 NULL, /* fill */ 1048 NULL, 1049 NULL, 1050 NULL, 1051 NULL, 1052 NULL, /* get_base */ 1053 NULL, /* get_bufsiz */ 1054 NULL, /* get_ptr */ 1055 NULL, /* get_cnt */ 1056 NULL, /* set_ptrcnt */ 1057 }; 1058 1059 PerlIO_list_t * 1060 PerlIO_default_layers(pTHX) 1061 { 1062 if (!PL_def_layerlist) { 1063 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); 1064 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; 1065 PL_def_layerlist = PerlIO_list_alloc(aTHX); 1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); 1067 #if defined(WIN32) 1068 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); 1069 #if 0 1070 osLayer = &PerlIO_win32; 1071 #endif 1072 #endif 1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); 1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); 1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); 1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); 1077 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); 1078 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); 1079 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); 1080 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer, 1081 &PL_sv_undef); 1082 if (s) { 1083 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); 1084 } 1085 else { 1086 PerlIO_default_buffer(aTHX_ PL_def_layerlist); 1087 } 1088 } 1089 if (PL_def_layerlist->cur < 2) { 1090 PerlIO_default_buffer(aTHX_ PL_def_layerlist); 1091 } 1092 return PL_def_layerlist; 1093 } 1094 1095 void 1096 Perl_boot_core_PerlIO(pTHX) 1097 { 1098 #ifdef USE_ATTRIBUTES_FOR_PERLIO 1099 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES, 1100 __FILE__); 1101 #endif 1102 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 1103 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__); 1104 } 1105 1106 PerlIO_funcs * 1107 PerlIO_default_layer(pTHX_ I32 n) 1108 { 1109 PerlIO_list_t * const av = PerlIO_default_layers(aTHX); 1110 if (n < 0) 1111 n += av->cur; 1112 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio)); 1113 } 1114 1115 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) 1116 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0) 1117 1118 void 1119 PerlIO_stdstreams(pTHX) 1120 { 1121 if (!PL_perlio) { 1122 PerlIO_init_table(aTHX); 1123 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); 1124 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); 1125 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); 1126 } 1127 } 1128 1129 PerlIO * 1130 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) 1131 { 1132 VERIFY_HEAD(f); 1133 if (tab->fsize != sizeof(PerlIO_funcs)) { 1134 Perl_croak( aTHX_ 1135 "%s (%" UVuf ") does not match %s (%" UVuf ")", 1136 "PerlIO layer function table size", (UV)tab->fsize, 1137 "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); 1138 } 1139 if (tab->size) { 1140 PerlIOl *l; 1141 if (tab->size < sizeof(PerlIOl)) { 1142 Perl_croak( aTHX_ 1143 "%s (%" UVuf ") smaller than %s (%" UVuf ")", 1144 "PerlIO layer instance size", (UV)tab->size, 1145 "size expected by this perl", (UV)sizeof(PerlIOl) ); 1146 } 1147 /* Real layer with a data area */ 1148 if (f) { 1149 char *temp; 1150 Newxz(temp, tab->size, char); 1151 l = (PerlIOl*)temp; 1152 if (l) { 1153 l->next = *f; 1154 l->tab = (PerlIO_funcs*) tab; 1155 l->head = ((PerlIOl*)f)->head; 1156 *f = l; 1157 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", 1158 (void*)f, tab->name, 1159 (mode) ? mode : "(Null)", (void*)arg) ); 1160 if (*l->tab->Pushed && 1161 (*l->tab->Pushed) 1162 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { 1163 PerlIO_pop(aTHX_ f); 1164 return NULL; 1165 } 1166 } 1167 else 1168 return NULL; 1169 } 1170 } 1171 else if (f) { 1172 /* Pseudo-layer where push does its own stack adjust */ 1173 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, 1174 (mode) ? mode : "(Null)", (void*)arg) ); 1175 if (tab->Pushed && 1176 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { 1177 return NULL; 1178 } 1179 } 1180 return f; 1181 } 1182 1183 PerlIO * 1184 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 1185 IV n, const char *mode, int fd, int imode, int perm, 1186 PerlIO *old, int narg, SV **args) 1187 { 1188 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0)); 1189 if (tab && tab->Open) { 1190 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); 1191 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) { 1192 PerlIO_close(ret); 1193 return NULL; 1194 } 1195 return ret; 1196 } 1197 SETERRNO(EINVAL, LIB_INVARG); 1198 return NULL; 1199 } 1200 1201 IV 1202 PerlIOBase_binmode(pTHX_ PerlIO *f) 1203 { 1204 if (PerlIOValid(f)) { 1205 /* Is layer suitable for raw stream ? */ 1206 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { 1207 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ 1208 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1209 } 1210 else { 1211 /* Not suitable - pop it */ 1212 PerlIO_pop(aTHX_ f); 1213 } 1214 return 0; 1215 } 1216 return -1; 1217 } 1218 1219 IV 1220 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1221 { 1222 PERL_UNUSED_ARG(mode); 1223 PERL_UNUSED_ARG(arg); 1224 PERL_UNUSED_ARG(tab); 1225 1226 if (PerlIOValid(f)) { 1227 PerlIO *t; 1228 const PerlIOl *l; 1229 PerlIO_flush(f); 1230 /* 1231 * Strip all layers that are not suitable for a raw stream 1232 */ 1233 t = f; 1234 while (t && (l = *t)) { 1235 if (l->tab && l->tab->Binmode) { 1236 /* Has a handler - normal case */ 1237 if ((*l->tab->Binmode)(aTHX_ t) == 0) { 1238 if (*t == l) { 1239 /* Layer still there - move down a layer */ 1240 t = PerlIONext(t); 1241 } 1242 } 1243 else { 1244 return -1; 1245 } 1246 } 1247 else { 1248 /* No handler - pop it */ 1249 PerlIO_pop(aTHX_ t); 1250 } 1251 } 1252 if (PerlIOValid(f)) { 1253 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f, 1254 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") ); 1255 return 0; 1256 } 1257 } 1258 return -1; 1259 } 1260 1261 int 1262 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, 1263 PerlIO_list_t *layers, IV n, IV max) 1264 { 1265 int code = 0; 1266 while (n < max) { 1267 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); 1268 if (tab) { 1269 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { 1270 code = -1; 1271 break; 1272 } 1273 } 1274 n++; 1275 } 1276 return code; 1277 } 1278 1279 int 1280 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 1281 { 1282 int code = 0; 1283 ENTER; 1284 save_scalar(PL_errgv); 1285 if (f && names) { 1286 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); 1287 code = PerlIO_parse_layers(aTHX_ layers, names); 1288 if (code == 0) { 1289 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); 1290 } 1291 PerlIO_list_free(aTHX_ layers); 1292 } 1293 LEAVE; 1294 return code; 1295 } 1296 1297 1298 /*--------------------------------------------------------------------------------------*/ 1299 /* 1300 * Given the abstraction above the public API functions 1301 */ 1302 1303 int 1304 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) 1305 { 1306 PERL_UNUSED_ARG(iotype); 1307 PERL_UNUSED_ARG(mode); 1308 1309 DEBUG_i( 1310 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f, 1311 (PerlIOBase(f) && PerlIOBase(f)->tab) ? 1312 PerlIOBase(f)->tab->name : "(Null)", 1313 iotype, mode, (names) ? names : "(Null)") ); 1314 1315 if (names) { 1316 /* Do not flush etc. if (e.g.) switching encodings. 1317 if a pushed layer knows it needs to flush lower layers 1318 (for example :unix which is never going to call them) 1319 it can do the flush when it is pushed. 1320 */ 1321 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0); 1322 } 1323 else { 1324 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ 1325 #ifdef PERLIO_USING_CRLF 1326 /* Legacy binmode only has meaning if O_TEXT has a value distinct from 1327 O_BINARY so we can look for it in mode. 1328 */ 1329 if (!(mode & O_BINARY)) { 1330 /* Text mode */ 1331 /* FIXME?: Looking down the layer stack seems wrong, 1332 but is a way of reaching past (say) an encoding layer 1333 to flip CRLF-ness of the layer(s) below 1334 */ 1335 while (*f) { 1336 /* Perhaps we should turn on bottom-most aware layer 1337 e.g. Ilya's idea that UNIX TTY could serve 1338 */ 1339 if (PerlIOBase(f)->tab && 1340 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) 1341 { 1342 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { 1343 /* Not in text mode - flush any pending stuff and flip it */ 1344 PerlIO_flush(f); 1345 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 1346 } 1347 /* Only need to turn it on in one layer so we are done */ 1348 return TRUE; 1349 } 1350 f = PerlIONext(f); 1351 } 1352 /* Not finding a CRLF aware layer presumably means we are binary 1353 which is not what was requested - so we failed 1354 We _could_ push :crlf layer but so could caller 1355 */ 1356 return FALSE; 1357 } 1358 #endif 1359 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw 1360 So code that used to be here is now in PerlIORaw_pushed(). 1361 */ 1362 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL)); 1363 } 1364 } 1365 1366 int 1367 PerlIO__close(pTHX_ PerlIO *f) 1368 { 1369 if (PerlIOValid(f)) { 1370 PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1371 if (tab && tab->Close) 1372 return (*tab->Close)(aTHX_ f); 1373 else 1374 return PerlIOBase_close(aTHX_ f); 1375 } 1376 else { 1377 SETERRNO(EBADF, SS_IVCHAN); 1378 return -1; 1379 } 1380 } 1381 1382 int 1383 Perl_PerlIO_close(pTHX_ PerlIO *f) 1384 { 1385 const int code = PerlIO__close(aTHX_ f); 1386 while (PerlIOValid(f)) { 1387 PerlIO_pop(aTHX_ f); 1388 if (PerlIO_lockcnt(f)) 1389 /* we're in use; the 'pop' deferred freeing the structure */ 1390 f = PerlIONext(f); 1391 } 1392 return code; 1393 } 1394 1395 int 1396 Perl_PerlIO_fileno(pTHX_ PerlIO *f) 1397 { 1398 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); 1399 } 1400 1401 1402 static PerlIO_funcs * 1403 PerlIO_layer_from_ref(pTHX_ SV *sv) 1404 { 1405 /* 1406 * For any scalar type load the handler which is bundled with perl 1407 */ 1408 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) { 1409 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); 1410 /* This isn't supposed to happen, since PerlIO::scalar is core, 1411 * but could happen anyway in smaller installs or with PAR */ 1412 if (!f) 1413 /* diag_listed_as: Unknown PerlIO layer "%s" */ 1414 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); 1415 return f; 1416 } 1417 1418 /* 1419 * For other types allow if layer is known but don't try and load it 1420 */ 1421 switch (SvTYPE(sv)) { 1422 case SVt_PVAV: 1423 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0); 1424 case SVt_PVHV: 1425 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0); 1426 case SVt_PVCV: 1427 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0); 1428 case SVt_PVGV: 1429 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0); 1430 default: 1431 return NULL; 1432 } 1433 } 1434 1435 PerlIO_list_t * 1436 PerlIO_resolve_layers(pTHX_ const char *layers, 1437 const char *mode, int narg, SV **args) 1438 { 1439 PerlIO_list_t *def = PerlIO_default_layers(aTHX); 1440 int incdef = 1; 1441 if (!PL_perlio) 1442 PerlIO_stdstreams(aTHX); 1443 if (narg) { 1444 SV * const arg = *args; 1445 /* 1446 * If it is a reference but not an object see if we have a handler 1447 * for it 1448 */ 1449 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { 1450 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); 1451 if (handler) { 1452 def = PerlIO_list_alloc(aTHX); 1453 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); 1454 incdef = 0; 1455 } 1456 /* 1457 * Don't fail if handler cannot be found :via(...) etc. may do 1458 * something sensible else we will just stringfy and open 1459 * resulting string. 1460 */ 1461 } 1462 } 1463 if (!layers || !*layers) 1464 layers = Perl_PerlIO_context_layers(aTHX_ mode); 1465 if (layers && *layers) { 1466 PerlIO_list_t *av; 1467 if (incdef) { 1468 av = PerlIO_clone_list(aTHX_ def, NULL); 1469 } 1470 else { 1471 av = def; 1472 } 1473 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { 1474 return av; 1475 } 1476 else { 1477 PerlIO_list_free(aTHX_ av); 1478 return NULL; 1479 } 1480 } 1481 else { 1482 if (incdef) 1483 def->refcnt++; 1484 return def; 1485 } 1486 } 1487 1488 PerlIO * 1489 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 1490 int imode, int perm, PerlIO *f, int narg, SV **args) 1491 { 1492 if (!f && narg == 1 && *args == &PL_sv_undef) { 1493 imode = PerlIOUnix_oflags(mode); 1494 1495 if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) { 1496 if (!layers || !*layers) 1497 layers = Perl_PerlIO_context_layers(aTHX_ mode); 1498 if (layers && *layers) 1499 PerlIO_apply_layers(aTHX_ f, mode, layers); 1500 } 1501 } 1502 else { 1503 PerlIO_list_t *layera; 1504 IV n; 1505 PerlIO_funcs *tab = NULL; 1506 if (PerlIOValid(f)) { 1507 /* 1508 * This is "reopen" - it is not tested as perl does not use it 1509 * yet 1510 */ 1511 PerlIOl *l = *f; 1512 layera = PerlIO_list_alloc(aTHX); 1513 while (l) { 1514 SV *arg = NULL; 1515 if (l->tab && l->tab->Getarg) 1516 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); 1517 PerlIO_list_push(aTHX_ layera, l->tab, 1518 (arg) ? arg : &PL_sv_undef); 1519 SvREFCNT_dec(arg); 1520 l = *PerlIONext(&l); 1521 } 1522 } 1523 else { 1524 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); 1525 if (!layera) { 1526 return NULL; 1527 } 1528 } 1529 /* 1530 * Start at "top" of layer stack 1531 */ 1532 n = layera->cur - 1; 1533 while (n >= 0) { 1534 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); 1535 if (t && t->Open) { 1536 tab = t; 1537 break; 1538 } 1539 n--; 1540 } 1541 if (tab) { 1542 /* 1543 * Found that layer 'n' can do opens - call it 1544 */ 1545 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { 1546 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); 1547 } 1548 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", 1549 tab->name, layers ? layers : "(Null)", mode, fd, 1550 imode, perm, (void*)f, narg, (void*)args) ); 1551 if (tab->Open) 1552 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, 1553 f, narg, args); 1554 else { 1555 SETERRNO(EINVAL, LIB_INVARG); 1556 f = NULL; 1557 } 1558 if (f) { 1559 if (n + 1 < layera->cur) { 1560 /* 1561 * More layers above the one that we used to open - 1562 * apply them now 1563 */ 1564 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { 1565 /* If pushing layers fails close the file */ 1566 PerlIO_close(f); 1567 f = NULL; 1568 } 1569 } 1570 } 1571 } 1572 PerlIO_list_free(aTHX_ layera); 1573 } 1574 return f; 1575 } 1576 1577 1578 SSize_t 1579 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 1580 { 1581 PERL_ARGS_ASSERT_PERLIO_READ; 1582 1583 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count)); 1584 } 1585 1586 SSize_t 1587 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1588 { 1589 PERL_ARGS_ASSERT_PERLIO_UNREAD; 1590 1591 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count)); 1592 } 1593 1594 SSize_t 1595 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1596 { 1597 PERL_ARGS_ASSERT_PERLIO_WRITE; 1598 1599 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count)); 1600 } 1601 1602 int 1603 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 1604 { 1605 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence)); 1606 } 1607 1608 Off_t 1609 Perl_PerlIO_tell(pTHX_ PerlIO *f) 1610 { 1611 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f)); 1612 } 1613 1614 int 1615 Perl_PerlIO_flush(pTHX_ PerlIO *f) 1616 { 1617 if (f) { 1618 if (*f) { 1619 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1620 1621 if (tab && tab->Flush) 1622 return (*tab->Flush) (aTHX_ f); 1623 else 1624 return 0; /* If no Flush defined, silently succeed. */ 1625 } 1626 else { 1627 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); 1628 SETERRNO(EBADF, SS_IVCHAN); 1629 return -1; 1630 } 1631 } 1632 else { 1633 /* 1634 * Is it good API design to do flush-all on NULL, a potentially 1635 * erroneous input? Maybe some magical value (PerlIO* 1636 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar 1637 * things on fflush(NULL), but should we be bound by their design 1638 * decisions? --jhi 1639 */ 1640 PerlIOl **table = &PL_perlio; 1641 PerlIOl *ff; 1642 int code = 0; 1643 while ((ff = *table)) { 1644 int i; 1645 table = (PerlIOl **) (ff++); 1646 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1647 if (ff->next && PerlIO_flush(&(ff->next)) != 0) 1648 code = -1; 1649 ff++; 1650 } 1651 } 1652 return code; 1653 } 1654 } 1655 1656 void 1657 PerlIOBase_flush_linebuf(pTHX) 1658 { 1659 PerlIOl **table = &PL_perlio; 1660 PerlIOl *f; 1661 while ((f = *table)) { 1662 int i; 1663 table = (PerlIOl **) (f++); 1664 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1665 if (f->next 1666 && (PerlIOBase(&(f->next))-> 1667 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1668 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1669 PerlIO_flush(&(f->next)); 1670 f++; 1671 } 1672 } 1673 } 1674 1675 int 1676 Perl_PerlIO_fill(pTHX_ PerlIO *f) 1677 { 1678 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f)); 1679 } 1680 1681 int 1682 PerlIO_isutf8(PerlIO *f) 1683 { 1684 if (PerlIOValid(f)) 1685 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; 1686 else 1687 SETERRNO(EBADF, SS_IVCHAN); 1688 1689 return -1; 1690 } 1691 1692 int 1693 Perl_PerlIO_eof(pTHX_ PerlIO *f) 1694 { 1695 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f)); 1696 } 1697 1698 int 1699 Perl_PerlIO_error(pTHX_ PerlIO *f) 1700 { 1701 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f)); 1702 } 1703 1704 void 1705 Perl_PerlIO_clearerr(pTHX_ PerlIO *f) 1706 { 1707 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f)); 1708 } 1709 1710 void 1711 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f) 1712 { 1713 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f)); 1714 } 1715 1716 int 1717 PerlIO_has_base(PerlIO *f) 1718 { 1719 if (PerlIOValid(f)) { 1720 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1721 1722 if (tab) 1723 return (tab->Get_base != NULL); 1724 } 1725 1726 return 0; 1727 } 1728 1729 int 1730 PerlIO_fast_gets(PerlIO *f) 1731 { 1732 if (PerlIOValid(f)) { 1733 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { 1734 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1735 1736 if (tab) 1737 return (tab->Set_ptrcnt != NULL); 1738 } 1739 } 1740 1741 return 0; 1742 } 1743 1744 int 1745 PerlIO_has_cntptr(PerlIO *f) 1746 { 1747 if (PerlIOValid(f)) { 1748 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1749 1750 if (tab) 1751 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); 1752 } 1753 1754 return 0; 1755 } 1756 1757 int 1758 PerlIO_canset_cnt(PerlIO *f) 1759 { 1760 if (PerlIOValid(f)) { 1761 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1762 1763 if (tab) 1764 return (tab->Set_ptrcnt != NULL); 1765 } 1766 1767 return 0; 1768 } 1769 1770 STDCHAR * 1771 Perl_PerlIO_get_base(pTHX_ PerlIO *f) 1772 { 1773 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f)); 1774 } 1775 1776 SSize_t 1777 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) 1778 { 1779 /* Note that Get_bufsiz returns a Size_t */ 1780 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f)); 1781 } 1782 1783 STDCHAR * 1784 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f) 1785 { 1786 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f)); 1787 } 1788 1789 SSize_t 1790 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) 1791 { 1792 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f)); 1793 } 1794 1795 void 1796 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt) 1797 { 1798 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt)); 1799 } 1800 1801 void 1802 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 1803 { 1804 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt)); 1805 } 1806 1807 1808 /*--------------------------------------------------------------------------------------*/ 1809 /* 1810 * utf8 and raw dummy layers 1811 */ 1812 1813 IV 1814 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1815 { 1816 PERL_UNUSED_CONTEXT; 1817 PERL_UNUSED_ARG(mode); 1818 PERL_UNUSED_ARG(arg); 1819 if (PerlIOValid(f)) { 1820 if (tab && tab->kind & PERLIO_K_UTF8) 1821 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 1822 else 1823 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1824 return 0; 1825 } 1826 return -1; 1827 } 1828 1829 PERLIO_FUNCS_DECL(PerlIO_utf8) = { 1830 sizeof(PerlIO_funcs), 1831 "utf8", 1832 0, 1833 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG, 1834 PerlIOUtf8_pushed, 1835 NULL, 1836 PerlIOBase_open, 1837 NULL, 1838 NULL, 1839 NULL, 1840 NULL, 1841 NULL, 1842 NULL, 1843 NULL, 1844 NULL, 1845 NULL, 1846 NULL, 1847 NULL, /* flush */ 1848 NULL, /* fill */ 1849 NULL, 1850 NULL, 1851 NULL, 1852 NULL, 1853 NULL, /* get_base */ 1854 NULL, /* get_bufsiz */ 1855 NULL, /* get_ptr */ 1856 NULL, /* get_cnt */ 1857 NULL, /* set_ptrcnt */ 1858 }; 1859 1860 PERLIO_FUNCS_DECL(PerlIO_byte) = { 1861 sizeof(PerlIO_funcs), 1862 "bytes", 1863 0, 1864 PERLIO_K_DUMMY | PERLIO_K_MULTIARG, 1865 PerlIOUtf8_pushed, 1866 NULL, 1867 PerlIOBase_open, 1868 NULL, 1869 NULL, 1870 NULL, 1871 NULL, 1872 NULL, 1873 NULL, 1874 NULL, 1875 NULL, 1876 NULL, 1877 NULL, 1878 NULL, /* flush */ 1879 NULL, /* fill */ 1880 NULL, 1881 NULL, 1882 NULL, 1883 NULL, 1884 NULL, /* get_base */ 1885 NULL, /* get_bufsiz */ 1886 NULL, /* get_ptr */ 1887 NULL, /* get_cnt */ 1888 NULL, /* set_ptrcnt */ 1889 }; 1890 1891 PERLIO_FUNCS_DECL(PerlIO_raw) = { 1892 sizeof(PerlIO_funcs), 1893 "raw", 1894 0, 1895 PERLIO_K_DUMMY, 1896 PerlIORaw_pushed, 1897 PerlIOBase_popped, 1898 PerlIOBase_open, 1899 NULL, 1900 NULL, 1901 NULL, 1902 NULL, 1903 NULL, 1904 NULL, 1905 NULL, 1906 NULL, 1907 NULL, 1908 NULL, 1909 NULL, /* flush */ 1910 NULL, /* fill */ 1911 NULL, 1912 NULL, 1913 NULL, 1914 NULL, 1915 NULL, /* get_base */ 1916 NULL, /* get_bufsiz */ 1917 NULL, /* get_ptr */ 1918 NULL, /* get_cnt */ 1919 NULL, /* set_ptrcnt */ 1920 }; 1921 /*--------------------------------------------------------------------------------------*/ 1922 /*--------------------------------------------------------------------------------------*/ 1923 /* 1924 * "Methods" of the "base class" 1925 */ 1926 1927 IV 1928 PerlIOBase_fileno(pTHX_ PerlIO *f) 1929 { 1930 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1; 1931 } 1932 1933 char * 1934 PerlIO_modestr(PerlIO * f, char *buf) 1935 { 1936 char *s = buf; 1937 if (PerlIOValid(f)) { 1938 const IV flags = PerlIOBase(f)->flags; 1939 if (flags & PERLIO_F_APPEND) { 1940 *s++ = 'a'; 1941 if (flags & PERLIO_F_CANREAD) { 1942 *s++ = '+'; 1943 } 1944 } 1945 else if (flags & PERLIO_F_CANREAD) { 1946 *s++ = 'r'; 1947 if (flags & PERLIO_F_CANWRITE) 1948 *s++ = '+'; 1949 } 1950 else if (flags & PERLIO_F_CANWRITE) { 1951 *s++ = 'w'; 1952 if (flags & PERLIO_F_CANREAD) { 1953 *s++ = '+'; 1954 } 1955 } 1956 #ifdef PERLIO_USING_CRLF 1957 if (!(flags & PERLIO_F_CRLF)) 1958 *s++ = 'b'; 1959 #endif 1960 } 1961 *s = '\0'; 1962 return buf; 1963 } 1964 1965 1966 IV 1967 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1968 { 1969 PerlIOl * const l = PerlIOBase(f); 1970 PERL_UNUSED_CONTEXT; 1971 PERL_UNUSED_ARG(arg); 1972 1973 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | 1974 PERLIO_F_TRUNCATE | PERLIO_F_APPEND); 1975 if (tab && tab->Set_ptrcnt != NULL) 1976 l->flags |= PERLIO_F_FASTGETS; 1977 if (mode) { 1978 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) 1979 mode++; 1980 switch (*mode++) { 1981 case 'r': 1982 l->flags |= PERLIO_F_CANREAD; 1983 break; 1984 case 'a': 1985 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; 1986 break; 1987 case 'w': 1988 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; 1989 break; 1990 default: 1991 SETERRNO(EINVAL, LIB_INVARG); 1992 return -1; 1993 } 1994 #ifdef EBCDIC 1995 { 1996 /* The mode variable contains one positional parameter followed by 1997 * optional keyword parameters. The positional parameters must be 1998 * passed as lowercase characters. The keyword parameters can be 1999 * passed in mixed case. They must be separated by commas. Only one 2000 * instance of a keyword can be specified. */ 2001 int comma = 0; 2002 while (*mode) { 2003 switch (*mode++) { 2004 case '+': 2005 if(!comma) 2006 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 2007 break; 2008 case 'b': 2009 if(!comma) 2010 l->flags &= ~PERLIO_F_CRLF; 2011 break; 2012 case 't': 2013 if(!comma) 2014 l->flags |= PERLIO_F_CRLF; 2015 break; 2016 case ',': 2017 comma = 1; 2018 break; 2019 default: 2020 break; 2021 } 2022 } 2023 } 2024 #else 2025 while (*mode) { 2026 switch (*mode++) { 2027 case '+': 2028 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 2029 break; 2030 case 'b': 2031 l->flags &= ~PERLIO_F_CRLF; 2032 break; 2033 case 't': 2034 l->flags |= PERLIO_F_CRLF; 2035 break; 2036 default: 2037 SETERRNO(EINVAL, LIB_INVARG); 2038 return -1; 2039 } 2040 } 2041 #endif 2042 } 2043 else { 2044 if (l->next) { 2045 l->flags |= l->next->flags & 2046 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | 2047 PERLIO_F_APPEND); 2048 } 2049 } 2050 #if 0 2051 DEBUG_i( 2052 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", 2053 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", 2054 l->flags, PerlIO_modestr(f, temp)); 2055 ); 2056 #endif 2057 return 0; 2058 } 2059 2060 IV 2061 PerlIOBase_popped(pTHX_ PerlIO *f) 2062 { 2063 PERL_UNUSED_CONTEXT; 2064 PERL_UNUSED_ARG(f); 2065 return 0; 2066 } 2067 2068 SSize_t 2069 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2070 { 2071 /* 2072 * Save the position as current head considers it 2073 */ 2074 const Off_t old = PerlIO_tell(f); 2075 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL); 2076 PerlIOSelf(f, PerlIOBuf)->posn = old; 2077 return PerlIOBuf_unread(aTHX_ f, vbuf, count); 2078 } 2079 2080 SSize_t 2081 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2082 { 2083 STDCHAR *buf = (STDCHAR *) vbuf; 2084 if (f) { 2085 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { 2086 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2087 SETERRNO(EBADF, SS_IVCHAN); 2088 PerlIO_save_errno(f); 2089 return 0; 2090 } 2091 while (count > 0) { 2092 get_cnt: 2093 { 2094 SSize_t avail = PerlIO_get_cnt(f); 2095 SSize_t take = 0; 2096 if (avail > 0) 2097 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; 2098 if (take > 0) { 2099 STDCHAR *ptr = PerlIO_get_ptr(f); 2100 Copy(ptr, buf, take, STDCHAR); 2101 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); 2102 count -= take; 2103 buf += take; 2104 if (avail == 0) /* set_ptrcnt could have reset avail */ 2105 goto get_cnt; 2106 } 2107 if (count > 0 && avail <= 0) { 2108 if (PerlIO_fill(f) != 0) 2109 break; 2110 } 2111 } 2112 } 2113 return (buf - (STDCHAR *) vbuf); 2114 } 2115 return 0; 2116 } 2117 2118 IV 2119 PerlIOBase_noop_ok(pTHX_ PerlIO *f) 2120 { 2121 PERL_UNUSED_CONTEXT; 2122 PERL_UNUSED_ARG(f); 2123 return 0; 2124 } 2125 2126 IV 2127 PerlIOBase_noop_fail(pTHX_ PerlIO *f) 2128 { 2129 PERL_UNUSED_CONTEXT; 2130 PERL_UNUSED_ARG(f); 2131 return -1; 2132 } 2133 2134 IV 2135 PerlIOBase_close(pTHX_ PerlIO *f) 2136 { 2137 IV code = -1; 2138 if (PerlIOValid(f)) { 2139 PerlIO *n = PerlIONext(f); 2140 code = PerlIO_flush(f); 2141 PerlIOBase(f)->flags &= 2142 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2143 while (PerlIOValid(n)) { 2144 const PerlIO_funcs * const tab = PerlIOBase(n)->tab; 2145 if (tab && tab->Close) { 2146 if ((*tab->Close)(aTHX_ n) != 0) 2147 code = -1; 2148 break; 2149 } 2150 else { 2151 PerlIOBase(n)->flags &= 2152 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2153 } 2154 n = PerlIONext(n); 2155 } 2156 } 2157 else { 2158 SETERRNO(EBADF, SS_IVCHAN); 2159 } 2160 return code; 2161 } 2162 2163 IV 2164 PerlIOBase_eof(pTHX_ PerlIO *f) 2165 { 2166 PERL_UNUSED_CONTEXT; 2167 if (PerlIOValid(f)) { 2168 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; 2169 } 2170 return 1; 2171 } 2172 2173 IV 2174 PerlIOBase_error(pTHX_ PerlIO *f) 2175 { 2176 PERL_UNUSED_CONTEXT; 2177 if (PerlIOValid(f)) { 2178 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; 2179 } 2180 return 1; 2181 } 2182 2183 void 2184 PerlIOBase_clearerr(pTHX_ PerlIO *f) 2185 { 2186 if (PerlIOValid(f)) { 2187 PerlIO * const n = PerlIONext(f); 2188 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); 2189 if (PerlIOValid(n)) 2190 PerlIO_clearerr(n); 2191 } 2192 } 2193 2194 void 2195 PerlIOBase_setlinebuf(pTHX_ PerlIO *f) 2196 { 2197 PERL_UNUSED_CONTEXT; 2198 if (PerlIOValid(f)) { 2199 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; 2200 } 2201 } 2202 2203 SV * 2204 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) 2205 { 2206 if (!arg) 2207 return NULL; 2208 #ifdef USE_ITHREADS 2209 if (param) { 2210 arg = sv_dup(arg, param); 2211 SvREFCNT_inc_simple_void_NN(arg); 2212 return arg; 2213 } 2214 else { 2215 return newSVsv(arg); 2216 } 2217 #else 2218 PERL_UNUSED_ARG(param); 2219 return newSVsv(arg); 2220 #endif 2221 } 2222 2223 PerlIO * 2224 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2225 { 2226 PerlIO * const nexto = PerlIONext(o); 2227 if (PerlIOValid(nexto)) { 2228 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; 2229 if (tab && tab->Dup) 2230 f = (*tab->Dup)(aTHX_ f, nexto, param, flags); 2231 else 2232 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); 2233 } 2234 if (f) { 2235 PerlIO_funcs * const self = PerlIOBase(o)->tab; 2236 SV *arg = NULL; 2237 char buf[8]; 2238 assert(self); 2239 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", 2240 self->name, 2241 (void*)f, (void*)o, (void*)param) ); 2242 if (self->Getarg) 2243 arg = (*self->Getarg)(aTHX_ o, param, flags); 2244 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); 2245 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) 2246 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 2247 SvREFCNT_dec(arg); 2248 } 2249 return f; 2250 } 2251 2252 /* PL_perlio_fd_refcnt[] is in intrpvar.h */ 2253 2254 /* Must be called with PL_perlio_mutex locked. */ 2255 static void 2256 S_more_refcounted_fds(pTHX_ const int new_fd) 2257 PERL_TSA_REQUIRES(PL_perlio_mutex) 2258 { 2259 dVAR; 2260 const int old_max = PL_perlio_fd_refcnt_size; 2261 const int new_max = 16 + (new_fd & ~15); 2262 int *new_array; 2263 2264 #ifndef PERL_IMPLICIT_SYS 2265 PERL_UNUSED_CONTEXT; 2266 #endif 2267 2268 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n", 2269 old_max, new_fd, new_max) ); 2270 2271 if (new_fd < old_max) { 2272 return; 2273 } 2274 2275 assert (new_max > new_fd); 2276 2277 /* Use plain realloc() since we need this memory to be really 2278 * global and visible to all the interpreters and/or threads. */ 2279 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); 2280 2281 if (!new_array) { 2282 MUTEX_UNLOCK(&PL_perlio_mutex); 2283 croak_no_mem(); 2284 } 2285 2286 PL_perlio_fd_refcnt_size = new_max; 2287 PL_perlio_fd_refcnt = new_array; 2288 2289 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n", 2290 (void*)(new_array + old_max), 2291 new_max - old_max) ); 2292 2293 Zero(new_array + old_max, new_max - old_max, int); 2294 } 2295 2296 2297 void 2298 PerlIO_init(pTHX) 2299 { 2300 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */ 2301 PERL_UNUSED_CONTEXT; 2302 } 2303 2304 void 2305 PerlIOUnix_refcnt_inc(int fd) 2306 { 2307 dTHX; 2308 if (fd >= 0) { 2309 dVAR; 2310 2311 MUTEX_LOCK(&PL_perlio_mutex); 2312 if (fd >= PL_perlio_fd_refcnt_size) 2313 S_more_refcounted_fds(aTHX_ fd); 2314 2315 PL_perlio_fd_refcnt[fd]++; 2316 if (PL_perlio_fd_refcnt[fd] <= 0) { 2317 /* diag_listed_as: refcnt_inc: fd %d%s */ 2318 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", 2319 fd, PL_perlio_fd_refcnt[fd]); 2320 } 2321 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", 2322 fd, PL_perlio_fd_refcnt[fd]) ); 2323 2324 MUTEX_UNLOCK(&PL_perlio_mutex); 2325 } else { 2326 /* diag_listed_as: refcnt_inc: fd %d%s */ 2327 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); 2328 } 2329 } 2330 2331 int 2332 PerlIOUnix_refcnt_dec(int fd) 2333 { 2334 int cnt = 0; 2335 if (fd >= 0) { 2336 #ifdef DEBUGGING 2337 dTHX; 2338 #else 2339 dVAR; 2340 #endif 2341 MUTEX_LOCK(&PL_perlio_mutex); 2342 if (fd >= PL_perlio_fd_refcnt_size) { 2343 /* diag_listed_as: refcnt_dec: fd %d%s */ 2344 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", 2345 fd, PL_perlio_fd_refcnt_size); 2346 } 2347 if (PL_perlio_fd_refcnt[fd] <= 0) { 2348 /* diag_listed_as: refcnt_dec: fd %d%s */ 2349 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", 2350 fd, PL_perlio_fd_refcnt[fd]); 2351 } 2352 cnt = --PL_perlio_fd_refcnt[fd]; 2353 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); 2354 MUTEX_UNLOCK(&PL_perlio_mutex); 2355 } else { 2356 /* diag_listed_as: refcnt_dec: fd %d%s */ 2357 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); 2358 } 2359 return cnt; 2360 } 2361 2362 int 2363 PerlIOUnix_refcnt(int fd) 2364 { 2365 dTHX; 2366 int cnt = 0; 2367 if (fd >= 0) { 2368 dVAR; 2369 MUTEX_LOCK(&PL_perlio_mutex); 2370 if (fd >= PL_perlio_fd_refcnt_size) { 2371 /* diag_listed_as: refcnt: fd %d%s */ 2372 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", 2373 fd, PL_perlio_fd_refcnt_size); 2374 } 2375 if (PL_perlio_fd_refcnt[fd] <= 0) { 2376 /* diag_listed_as: refcnt: fd %d%s */ 2377 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", 2378 fd, PL_perlio_fd_refcnt[fd]); 2379 } 2380 cnt = PL_perlio_fd_refcnt[fd]; 2381 MUTEX_UNLOCK(&PL_perlio_mutex); 2382 } else { 2383 /* diag_listed_as: refcnt: fd %d%s */ 2384 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); 2385 } 2386 return cnt; 2387 } 2388 2389 void 2390 PerlIO_cleanup(pTHX) 2391 { 2392 int i; 2393 #ifdef USE_ITHREADS 2394 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) ); 2395 #else 2396 DEBUG_i( PerlIO_debug("Cleanup layers\n") ); 2397 #endif 2398 2399 /* Raise STDIN..STDERR refcount so we don't close them */ 2400 for (i=0; i < 3; i++) 2401 PerlIOUnix_refcnt_inc(i); 2402 PerlIO_cleantable(aTHX_ &PL_perlio); 2403 /* Restore STDIN..STDERR refcount */ 2404 for (i=0; i < 3; i++) 2405 PerlIOUnix_refcnt_dec(i); 2406 2407 if (PL_known_layers) { 2408 PerlIO_list_free(aTHX_ PL_known_layers); 2409 PL_known_layers = NULL; 2410 } 2411 if (PL_def_layerlist) { 2412 PerlIO_list_free(aTHX_ PL_def_layerlist); 2413 PL_def_layerlist = NULL; 2414 } 2415 } 2416 2417 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ 2418 { 2419 dVAR; 2420 #if 0 2421 /* XXX we can't rely on an interpreter being present at this late stage, 2422 XXX so we can't use a function like PerlLIO_write that relies on one 2423 being present (at least in win32) :-(. 2424 Disable for now. 2425 */ 2426 #ifdef DEBUGGING 2427 { 2428 /* By now all filehandles should have been closed, so any 2429 * stray (non-STD-)filehandles indicate *possible* (PerlIO) 2430 * errors. */ 2431 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64 2432 #define PERLIO_TEARDOWN_MESSAGE_FD 2 2433 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; 2434 int i; 2435 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { 2436 if (PL_perlio_fd_refcnt[i]) { 2437 const STRLEN len = 2438 my_snprintf(buf, sizeof(buf), 2439 "PerlIO_teardown: fd %d refcnt=%d\n", 2440 i, PL_perlio_fd_refcnt[i]); 2441 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); 2442 } 2443 } 2444 } 2445 #endif 2446 #endif 2447 /* Not bothering with PL_perlio_mutex since by now 2448 * all the interpreters are gone. */ 2449 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */ 2450 && PL_perlio_fd_refcnt) { 2451 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ 2452 PL_perlio_fd_refcnt = NULL; 2453 PL_perlio_fd_refcnt_size = 0; 2454 } 2455 } 2456 2457 /*--------------------------------------------------------------------------------------*/ 2458 /* 2459 * Bottom-most level for UNIX-like case 2460 */ 2461 2462 typedef struct { 2463 struct _PerlIO base; /* The generic part */ 2464 int fd; /* UNIX like file descriptor */ 2465 int oflags; /* open/fcntl flags */ 2466 } PerlIOUnix; 2467 2468 static void 2469 S_lockcnt_dec(pTHX_ const void* f) 2470 { 2471 #ifndef PERL_IMPLICIT_SYS 2472 PERL_UNUSED_CONTEXT; 2473 #endif 2474 PerlIO_lockcnt((PerlIO*)f)--; 2475 } 2476 2477 2478 /* call the signal handler, and if that handler happens to clear 2479 * this handle, free what we can and return true */ 2480 2481 static bool 2482 S_perlio_async_run(pTHX_ PerlIO* f) { 2483 ENTER; 2484 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f); 2485 PerlIO_lockcnt(f)++; 2486 PERL_ASYNC_CHECK(); 2487 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) { 2488 LEAVE; 2489 return 0; 2490 } 2491 /* we've just run some perl-level code that could have done 2492 * anything, including closing the file or clearing this layer. 2493 * If so, free any lower layers that have already been 2494 * cleared, then return an error. */ 2495 while (PerlIOValid(f) && 2496 (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) 2497 { 2498 const PerlIOl *l = *f; 2499 *f = l->next; 2500 Safefree(l); 2501 } 2502 LEAVE; 2503 return 1; 2504 } 2505 2506 int 2507 PerlIOUnix_oflags(const char *mode) 2508 { 2509 int oflags = -1; 2510 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) 2511 mode++; 2512 switch (*mode) { 2513 case 'r': 2514 oflags = O_RDONLY; 2515 if (*++mode == '+') { 2516 oflags = O_RDWR; 2517 mode++; 2518 } 2519 break; 2520 2521 case 'w': 2522 oflags = O_CREAT | O_TRUNC; 2523 if (*++mode == '+') { 2524 oflags |= O_RDWR; 2525 mode++; 2526 } 2527 else 2528 oflags |= O_WRONLY; 2529 break; 2530 2531 case 'a': 2532 oflags = O_CREAT | O_APPEND; 2533 if (*++mode == '+') { 2534 oflags |= O_RDWR; 2535 mode++; 2536 } 2537 else 2538 oflags |= O_WRONLY; 2539 break; 2540 } 2541 2542 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */ 2543 2544 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one 2545 * of them in, and then bit-and-masking the other them away, won't 2546 * have much of an effect. */ 2547 switch (*mode) { 2548 case 'b': 2549 #if O_TEXT != O_BINARY 2550 oflags |= O_BINARY; 2551 oflags &= ~O_TEXT; 2552 #endif 2553 mode++; 2554 break; 2555 case 't': 2556 #if O_TEXT != O_BINARY 2557 oflags |= O_TEXT; 2558 oflags &= ~O_BINARY; 2559 #endif 2560 mode++; 2561 break; 2562 default: 2563 # if O_BINARY != 0 2564 /* bit-or:ing with zero O_BINARY would be useless. */ 2565 /* 2566 * If neither "t" nor "b" was specified, open the file 2567 * in O_BINARY mode. 2568 * 2569 * Note that if something else than the zero byte was seen 2570 * here (e.g. bogus mode "rx"), just few lines later we will 2571 * set the errno and invalidate the flags. 2572 */ 2573 oflags |= O_BINARY; 2574 # endif 2575 break; 2576 } 2577 if (*mode || oflags == -1) { 2578 SETERRNO(EINVAL, LIB_INVARG); 2579 oflags = -1; 2580 } 2581 return oflags; 2582 } 2583 2584 IV 2585 PerlIOUnix_fileno(pTHX_ PerlIO *f) 2586 { 2587 PERL_UNUSED_CONTEXT; 2588 return PerlIOSelf(f, PerlIOUnix)->fd; 2589 } 2590 2591 static void 2592 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) 2593 { 2594 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix); 2595 #if defined(WIN32) 2596 Stat_t st; 2597 if (PerlLIO_fstat(fd, &st) == 0) { 2598 if (!S_ISREG(st.st_mode)) { 2599 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); 2600 PerlIOBase(f)->flags |= PERLIO_F_NOTREG; 2601 } 2602 else { 2603 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); 2604 } 2605 } 2606 #endif 2607 s->fd = fd; 2608 s->oflags = imode; 2609 PerlIOUnix_refcnt_inc(fd); 2610 PERL_UNUSED_CONTEXT; 2611 } 2612 2613 IV 2614 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2615 { 2616 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2617 if (*PerlIONext(f)) { 2618 /* We never call down so do any pending stuff now */ 2619 PerlIO_flush(PerlIONext(f)); 2620 /* 2621 * XXX could (or should) we retrieve the oflags from the open file 2622 * handle rather than believing the "mode" we are passed in? XXX 2623 * Should the value on NULL mode be 0 or -1? 2624 */ 2625 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), 2626 mode ? PerlIOUnix_oflags(mode) : -1); 2627 } 2628 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2629 2630 return code; 2631 } 2632 2633 IV 2634 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 2635 { 2636 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2637 Off_t new_loc; 2638 PERL_UNUSED_CONTEXT; 2639 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { 2640 #ifdef ESPIPE 2641 SETERRNO(ESPIPE, LIB_INVARG); 2642 #else 2643 SETERRNO(EINVAL, LIB_INVARG); 2644 #endif 2645 return -1; 2646 } 2647 new_loc = PerlLIO_lseek(fd, offset, whence); 2648 if (new_loc == (Off_t) - 1) 2649 return -1; 2650 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 2651 return 0; 2652 } 2653 2654 PerlIO * 2655 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 2656 IV n, const char *mode, int fd, int imode, 2657 int perm, PerlIO *f, int narg, SV **args) 2658 { 2659 bool known_cloexec = 0; 2660 if (PerlIOValid(f)) { 2661 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) 2662 (*PerlIOBase(f)->tab->Close)(aTHX_ f); 2663 } 2664 if (narg > 0) { 2665 if (*mode == IoTYPE_NUMERIC) 2666 mode++; 2667 else { 2668 imode = PerlIOUnix_oflags(mode); 2669 #ifdef VMS 2670 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ 2671 #else 2672 perm = 0666; 2673 #endif 2674 } 2675 if (imode != -1) { 2676 STRLEN len; 2677 const char *path = SvPV_const(*args, len); 2678 if (!IS_SAFE_PATHNAME(path, len, "open")) 2679 return NULL; 2680 fd = PerlLIO_open3_cloexec(path, imode, perm); 2681 known_cloexec = 1; 2682 } 2683 } 2684 if (fd >= 0) { 2685 if (known_cloexec) 2686 setfd_inhexec_for_sysfd(fd); 2687 else 2688 setfd_cloexec_or_inhexec_by_sysfdness(fd); 2689 if (*mode == IoTYPE_IMPLICIT) 2690 mode++; 2691 if (!f) { 2692 f = PerlIO_allocate(aTHX); 2693 } 2694 if (!PerlIOValid(f)) { 2695 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 2696 PerlLIO_close(fd); 2697 return NULL; 2698 } 2699 } 2700 PerlIOUnix_setfd(aTHX_ f, fd, imode); 2701 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2702 if (*mode == IoTYPE_APPEND) 2703 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); 2704 return f; 2705 } 2706 else { 2707 if (f) { 2708 NOOP; 2709 /* 2710 * FIXME: pop layers ??? 2711 */ 2712 } 2713 return NULL; 2714 } 2715 } 2716 2717 PerlIO * 2718 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2719 { 2720 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix); 2721 int fd = os->fd; 2722 if (flags & PERLIO_DUP_FD) { 2723 fd = PerlLIO_dup_cloexec(fd); 2724 if (fd >= 0) 2725 setfd_inhexec_for_sysfd(fd); 2726 } 2727 if (fd >= 0) { 2728 f = PerlIOBase_dup(aTHX_ f, o, param, flags); 2729 if (f) { 2730 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ 2731 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); 2732 return f; 2733 } 2734 PerlLIO_close(fd); 2735 } 2736 return NULL; 2737 } 2738 2739 2740 SSize_t 2741 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2742 { 2743 int fd; 2744 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 2745 return -1; 2746 fd = PerlIOSelf(f, PerlIOUnix)->fd; 2747 #ifdef PERLIO_STD_SPECIAL 2748 if (fd == 0) 2749 return PERLIO_STD_IN(fd, vbuf, count); 2750 #endif 2751 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || 2752 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { 2753 return 0; 2754 } 2755 while (1) { 2756 const SSize_t len = PerlLIO_read(fd, vbuf, count); 2757 if (len >= 0 || errno != EINTR) { 2758 if (len < 0) { 2759 if (errno != EAGAIN) { 2760 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2761 PerlIO_save_errno(f); 2762 } 2763 } 2764 else if (len == 0 && count != 0) { 2765 PerlIOBase(f)->flags |= PERLIO_F_EOF; 2766 SETERRNO(0,0); 2767 } 2768 return len; 2769 } 2770 /* EINTR */ 2771 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 2772 return -1; 2773 } 2774 NOT_REACHED; /*NOTREACHED*/ 2775 } 2776 2777 SSize_t 2778 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2779 { 2780 int fd; 2781 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 2782 return -1; 2783 fd = PerlIOSelf(f, PerlIOUnix)->fd; 2784 #ifdef PERLIO_STD_SPECIAL 2785 if (fd == 1 || fd == 2) 2786 return PERLIO_STD_OUT(fd, vbuf, count); 2787 #endif 2788 while (1) { 2789 const SSize_t len = PerlLIO_write(fd, vbuf, count); 2790 if (len >= 0 || errno != EINTR) { 2791 if (len < 0) { 2792 if (errno != EAGAIN) { 2793 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2794 PerlIO_save_errno(f); 2795 } 2796 } 2797 return len; 2798 } 2799 /* EINTR */ 2800 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 2801 return -1; 2802 } 2803 NOT_REACHED; /*NOTREACHED*/ 2804 } 2805 2806 Off_t 2807 PerlIOUnix_tell(pTHX_ PerlIO *f) 2808 { 2809 PERL_UNUSED_CONTEXT; 2810 2811 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR); 2812 } 2813 2814 2815 IV 2816 PerlIOUnix_close(pTHX_ PerlIO *f) 2817 { 2818 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2819 int code = 0; 2820 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { 2821 code = PerlIOBase_close(aTHX_ f); 2822 if (PerlIOUnix_refcnt_dec(fd) > 0) { 2823 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2824 return 0; 2825 } 2826 } 2827 else { 2828 SETERRNO(EBADF,SS_IVCHAN); 2829 return -1; 2830 } 2831 while (PerlLIO_close(fd) != 0) { 2832 if (errno != EINTR) { 2833 code = -1; 2834 break; 2835 } 2836 /* EINTR */ 2837 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 2838 return -1; 2839 } 2840 if (code == 0) { 2841 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2842 } 2843 return code; 2844 } 2845 2846 PERLIO_FUNCS_DECL(PerlIO_unix) = { 2847 sizeof(PerlIO_funcs), 2848 "unix", 2849 sizeof(PerlIOUnix), 2850 PERLIO_K_RAW, 2851 PerlIOUnix_pushed, 2852 PerlIOBase_popped, 2853 PerlIOUnix_open, 2854 PerlIOBase_binmode, /* binmode */ 2855 NULL, 2856 PerlIOUnix_fileno, 2857 PerlIOUnix_dup, 2858 PerlIOUnix_read, 2859 PerlIOBase_unread, 2860 PerlIOUnix_write, 2861 PerlIOUnix_seek, 2862 PerlIOUnix_tell, 2863 PerlIOUnix_close, 2864 PerlIOBase_noop_ok, /* flush */ 2865 PerlIOBase_noop_fail, /* fill */ 2866 PerlIOBase_eof, 2867 PerlIOBase_error, 2868 PerlIOBase_clearerr, 2869 PerlIOBase_setlinebuf, 2870 NULL, /* get_base */ 2871 NULL, /* get_bufsiz */ 2872 NULL, /* get_ptr */ 2873 NULL, /* get_cnt */ 2874 NULL, /* set_ptrcnt */ 2875 }; 2876 2877 /*--------------------------------------------------------------------------------------*/ 2878 /* 2879 * stdio as a layer 2880 */ 2881 2882 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE) 2883 /* perl5.8 - This ensures the last minute VMS ungetc fix is not 2884 broken by the last second glibc 2.3 fix 2885 */ 2886 #define STDIO_BUFFER_WRITABLE 2887 #endif 2888 2889 2890 typedef struct { 2891 struct _PerlIO base; 2892 FILE *stdio; /* The stream */ 2893 } PerlIOStdio; 2894 2895 IV 2896 PerlIOStdio_fileno(pTHX_ PerlIO *f) 2897 { 2898 PERL_UNUSED_CONTEXT; 2899 2900 if (PerlIOValid(f)) { 2901 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; 2902 if (s) 2903 return PerlSIO_fileno(s); 2904 } 2905 errno = EBADF; 2906 return -1; 2907 } 2908 2909 char * 2910 PerlIOStdio_mode(const char *mode, char *tmode) 2911 { 2912 char * const ret = tmode; 2913 if (mode) { 2914 while (*mode) { 2915 *tmode++ = *mode++; 2916 } 2917 } 2918 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) 2919 *tmode++ = 'b'; 2920 #endif 2921 *tmode = '\0'; 2922 return ret; 2923 } 2924 2925 IV 2926 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2927 { 2928 PerlIO *n; 2929 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { 2930 PerlIO_funcs * const toptab = PerlIOBase(n)->tab; 2931 if (toptab == tab) { 2932 /* Top is already stdio - pop self (duplicate) and use original */ 2933 PerlIO_pop(aTHX_ f); 2934 return 0; 2935 } else { 2936 const int fd = PerlIO_fileno(n); 2937 char tmode[8]; 2938 FILE *stdio; 2939 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, 2940 mode = PerlIOStdio_mode(mode, tmode)))) { 2941 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 2942 /* We never call down so do any pending stuff now */ 2943 PerlIO_flush(PerlIONext(f)); 2944 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2945 } 2946 else { 2947 return -1; 2948 } 2949 } 2950 } 2951 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2952 } 2953 2954 2955 PerlIO * 2956 PerlIO_importFILE(FILE *stdio, const char *mode) 2957 { 2958 dTHX; 2959 PerlIO *f = NULL; 2960 #ifdef EBCDIC 2961 int rc; 2962 char filename[FILENAME_MAX]; 2963 fldata_t fileinfo; 2964 #endif 2965 if (stdio) { 2966 PerlIOStdio *s; 2967 int fd0 = fileno(stdio); 2968 if (fd0 < 0) { 2969 #ifdef EBCDIC 2970 rc = fldata(stdio,filename,&fileinfo); 2971 if(rc != 0){ 2972 return NULL; 2973 } 2974 if(fileinfo.__dsorgHFS){ 2975 return NULL; 2976 } 2977 /*This MVS dataset , OK!*/ 2978 #else 2979 return NULL; 2980 #endif 2981 } 2982 if (!mode || !*mode) { 2983 /* We need to probe to see how we can open the stream 2984 so start with read/write and then try write and read 2985 we dup() so that we can fclose without loosing the fd. 2986 2987 Note that the errno value set by a failing fdopen 2988 varies between stdio implementations. 2989 */ 2990 const int fd = PerlLIO_dup_cloexec(fd0); 2991 FILE *f2; 2992 if (fd < 0) { 2993 return f; 2994 } 2995 f2 = PerlSIO_fdopen(fd, (mode = "r+")); 2996 if (!f2) { 2997 f2 = PerlSIO_fdopen(fd, (mode = "w")); 2998 } 2999 if (!f2) { 3000 f2 = PerlSIO_fdopen(fd, (mode = "r")); 3001 } 3002 if (!f2) { 3003 /* Don't seem to be able to open */ 3004 PerlLIO_close(fd); 3005 return f; 3006 } 3007 fclose(f2); 3008 } 3009 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { 3010 s = PerlIOSelf(f, PerlIOStdio); 3011 s->stdio = stdio; 3012 fd0 = fileno(stdio); 3013 if(fd0 != -1){ 3014 PerlIOUnix_refcnt_inc(fd0); 3015 setfd_cloexec_or_inhexec_by_sysfdness(fd0); 3016 } 3017 #ifdef EBCDIC 3018 else{ 3019 rc = fldata(stdio,filename,&fileinfo); 3020 if(rc != 0){ 3021 PerlIOUnix_refcnt_inc(fd0); 3022 } 3023 if(fileinfo.__dsorgHFS){ 3024 PerlIOUnix_refcnt_inc(fd0); 3025 } 3026 /*This MVS dataset , OK!*/ 3027 } 3028 #endif 3029 } 3030 } 3031 return f; 3032 } 3033 3034 PerlIO * 3035 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 3036 IV n, const char *mode, int fd, int imode, 3037 int perm, PerlIO *f, int narg, SV **args) 3038 { 3039 char tmode[8]; 3040 if (PerlIOValid(f)) { 3041 STRLEN len; 3042 const char * const path = SvPV_const(*args, len); 3043 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); 3044 FILE *stdio; 3045 if (!IS_SAFE_PATHNAME(path, len, "open")) 3046 return NULL; 3047 PerlIOUnix_refcnt_dec(fileno(s->stdio)); 3048 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), 3049 s->stdio); 3050 if (!s->stdio) 3051 return NULL; 3052 s->stdio = stdio; 3053 fd = fileno(stdio); 3054 PerlIOUnix_refcnt_inc(fd); 3055 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3056 return f; 3057 } 3058 else { 3059 if (narg > 0) { 3060 STRLEN len; 3061 const char * const path = SvPV_const(*args, len); 3062 if (!IS_SAFE_PATHNAME(path, len, "open")) 3063 return NULL; 3064 if (*mode == IoTYPE_NUMERIC) { 3065 mode++; 3066 fd = PerlLIO_open3_cloexec(path, imode, perm); 3067 } 3068 else { 3069 FILE *stdio; 3070 bool appended = FALSE; 3071 #ifdef __CYGWIN__ 3072 /* Cygwin wants its 'b' early. */ 3073 appended = TRUE; 3074 mode = PerlIOStdio_mode(mode, tmode); 3075 #endif 3076 stdio = PerlSIO_fopen(path, mode); 3077 if (stdio) { 3078 if (!f) { 3079 f = PerlIO_allocate(aTHX); 3080 } 3081 if (!appended) 3082 mode = PerlIOStdio_mode(mode, tmode); 3083 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); 3084 if (f) { 3085 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 3086 fd = fileno(stdio); 3087 PerlIOUnix_refcnt_inc(fd); 3088 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3089 } else { 3090 PerlSIO_fclose(stdio); 3091 } 3092 return f; 3093 } 3094 else { 3095 return NULL; 3096 } 3097 } 3098 } 3099 if (fd >= 0) { 3100 FILE *stdio = NULL; 3101 int init = 0; 3102 if (*mode == IoTYPE_IMPLICIT) { 3103 init = 1; 3104 mode++; 3105 } 3106 if (init) { 3107 switch (fd) { 3108 case 0: 3109 stdio = PerlSIO_stdin; 3110 break; 3111 case 1: 3112 stdio = PerlSIO_stdout; 3113 break; 3114 case 2: 3115 stdio = PerlSIO_stderr; 3116 break; 3117 } 3118 } 3119 else { 3120 stdio = PerlSIO_fdopen(fd, mode = 3121 PerlIOStdio_mode(mode, tmode)); 3122 } 3123 if (stdio) { 3124 if (!f) { 3125 f = PerlIO_allocate(aTHX); 3126 } 3127 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 3128 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 3129 fd = fileno(stdio); 3130 PerlIOUnix_refcnt_inc(fd); 3131 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3132 } 3133 return f; 3134 } 3135 PerlLIO_close(fd); 3136 } 3137 } 3138 return NULL; 3139 } 3140 3141 PerlIO * 3142 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 3143 { 3144 /* This assumes no layers underneath - which is what 3145 happens, but is not how I remember it. NI-S 2001/10/16 3146 */ 3147 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { 3148 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; 3149 const int fd = fileno(stdio); 3150 char mode[8]; 3151 if (flags & PERLIO_DUP_FD) { 3152 const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); 3153 if (dfd >= 0) { 3154 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); 3155 goto set_this; 3156 } 3157 else { 3158 NOOP; 3159 /* FIXME: To avoid messy error recovery if dup fails 3160 re-use the existing stdio as though flag was not set 3161 */ 3162 } 3163 } 3164 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); 3165 set_this: 3166 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 3167 if(stdio) { 3168 int fd = fileno(stdio); 3169 PerlIOUnix_refcnt_inc(fd); 3170 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3171 } 3172 } 3173 return f; 3174 } 3175 3176 static int 3177 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) 3178 { 3179 PERL_UNUSED_CONTEXT; 3180 3181 /* XXX this could use PerlIO_canset_fileno() and 3182 * PerlIO_set_fileno() support from Configure 3183 */ 3184 # if defined(HAS_FDCLOSE) 3185 return fdclose(f, NULL) == 0 ? 1 : 0; 3186 # elif defined(__UCLIBC__) 3187 /* uClibc must come before glibc because it defines __GLIBC__ as well. */ 3188 f->__filedes = -1; 3189 return 1; 3190 # elif defined(__GLIBC__) 3191 /* There may be a better way for GLIBC: 3192 - libio.h defines a flag to not close() on cleanup 3193 */ 3194 f->_fileno = -1; 3195 return 1; 3196 # elif defined(__sun) 3197 PERL_UNUSED_ARG(f); 3198 return 0; 3199 # elif defined(__hpux) 3200 f->__fileH = 0xff; 3201 f->__fileL = 0xff; 3202 return 1; 3203 /* Next one ->_file seems to be a reasonable fallback, i.e. if 3204 your platform does not have special entry try this one. 3205 [For OSF only have confirmation for Tru64 (alpha) 3206 but assume other OSFs will be similar.] 3207 */ 3208 # elif defined(_AIX) || defined(__osf__) || defined(__irix__) 3209 f->_file = -1; 3210 return 1; 3211 # elif defined(__FreeBSD__) 3212 /* There may be a better way on FreeBSD: 3213 - we could insert a dummy func in the _close function entry 3214 f->_close = (int (*)(void *)) dummy_close; 3215 */ 3216 f->_file = -1; 3217 return 1; 3218 # elif defined(__OpenBSD__) 3219 /* There may be a better way on OpenBSD: 3220 - we could insert a dummy func in the _close function entry 3221 f->_close = (int (*)(void *)) dummy_close; 3222 */ 3223 f->_file = -1; 3224 return 1; 3225 # elif defined(__EMX__) 3226 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */ 3227 f->_handle = -1; 3228 return 1; 3229 # elif defined(__CYGWIN__) 3230 /* There may be a better way on CYGWIN: 3231 - we could insert a dummy func in the _close function entry 3232 f->_close = (int (*)(void *)) dummy_close; 3233 */ 3234 f->_file = -1; 3235 return 1; 3236 # elif defined(WIN32) 3237 PERLIO_FILE_file(f) = -1; 3238 return 1; 3239 # else 3240 #if 0 3241 /* Sarathy's code did this - we fall back to a dup/dup2 hack 3242 (which isn't thread safe) instead 3243 */ 3244 # error "Don't know how to set FILE.fileno on your platform" 3245 #endif 3246 PERL_UNUSED_ARG(f); 3247 return 0; 3248 # endif 3249 } 3250 3251 IV 3252 PerlIOStdio_close(pTHX_ PerlIO *f) 3253 { 3254 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3255 if (!stdio) { 3256 errno = EBADF; 3257 return -1; 3258 } 3259 else { 3260 const int fd = fileno(stdio); 3261 int invalidate = 0; 3262 IV result = 0; 3263 int dupfd = -1; 3264 dSAVEDERRNO; 3265 #ifdef USE_ITHREADS 3266 dVAR; 3267 #endif 3268 #ifdef SOCKS5_VERSION_NAME 3269 /* Socks lib overrides close() but stdio isn't linked to 3270 that library (though we are) - so we must call close() 3271 on sockets on stdio's behalf. 3272 */ 3273 int optval; 3274 Sock_size_t optlen = sizeof(int); 3275 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) 3276 invalidate = 1; 3277 #endif 3278 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such 3279 that a subsequent fileno() on it returns -1. Don't want to croak() 3280 from within PerlIOUnix_refcnt_dec() if some buggy caller code is 3281 trying to close an already closed handle which somehow it still has 3282 a reference to. (via.xs, I'm looking at you). */ 3283 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { 3284 /* File descriptor still in use */ 3285 invalidate = 1; 3286 } 3287 if (invalidate) { 3288 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ 3289 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ 3290 return 0; 3291 if (stdio == stdout || stdio == stderr) 3292 return PerlIO_flush(f); 3293 } 3294 MUTEX_LOCK(&PL_perlio_mutex); 3295 /* Right. We need a mutex here because for a brief while we 3296 will have the situation that fd is actually closed. Hence if 3297 a second thread were to get into this block, its dup() would 3298 likely return our fd as its dupfd. (after all, it is closed) 3299 Then if we get to the dup2() first, we blat the fd back 3300 (messing up its temporary as a side effect) only for it to 3301 then close its dupfd (== our fd) in its close(dupfd) */ 3302 3303 /* There is, of course, a race condition, that any other thread 3304 trying to input/output/whatever on this fd will be stuffed 3305 for the duration of this little manoeuvrer. Perhaps we 3306 should hold an IO mutex for the duration of every IO 3307 operation if we know that invalidate doesn't work on this 3308 platform, but that would suck, and could kill performance. 3309 3310 Except that correctness trumps speed. 3311 Advice from klortho #11912. */ 3312 if (invalidate) { 3313 /* Tricky - must fclose(stdio) to free memory but not close(fd) 3314 Use Sarathy's trick from maint-5.6 to invalidate the 3315 fileno slot of the FILE * 3316 */ 3317 result = PerlIO_flush(f); 3318 SAVE_ERRNO; 3319 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); 3320 if (!invalidate) { 3321 dupfd = PerlLIO_dup_cloexec(fd); 3322 #ifdef USE_ITHREADS 3323 if (dupfd < 0) { 3324 /* Oh cXap. This isn't going to go well. Not sure if we can 3325 recover from here, or if closing this particular FILE * 3326 is a good idea now. */ 3327 } 3328 #endif 3329 } 3330 } else { 3331 SAVE_ERRNO; /* This is here only to silence compiler warnings */ 3332 } 3333 result = PerlSIO_fclose(stdio); 3334 /* We treat error from stdio as success if we invalidated 3335 errno may NOT be expected EBADF 3336 */ 3337 if (invalidate && result != 0) { 3338 RESTORE_ERRNO; 3339 result = 0; 3340 } 3341 #ifdef SOCKS5_VERSION_NAME 3342 /* in SOCKS' case, let close() determine return value */ 3343 result = close(fd); 3344 #endif 3345 if (dupfd >= 0) { 3346 PerlLIO_dup2_cloexec(dupfd, fd); 3347 setfd_inhexec_for_sysfd(fd); 3348 PerlLIO_close(dupfd); 3349 } 3350 MUTEX_UNLOCK(&PL_perlio_mutex); 3351 return result; 3352 } 3353 } 3354 3355 SSize_t 3356 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 3357 { 3358 FILE * s; 3359 SSize_t got = 0; 3360 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 3361 return -1; 3362 s = PerlIOSelf(f, PerlIOStdio)->stdio; 3363 for (;;) { 3364 if (count == 1) { 3365 STDCHAR *buf = (STDCHAR *) vbuf; 3366 /* 3367 * Perl is expecting PerlIO_getc() to fill the buffer Linux's 3368 * stdio does not do that for fread() 3369 */ 3370 const int ch = PerlSIO_fgetc(s); 3371 if (ch != EOF) { 3372 *buf = ch; 3373 got = 1; 3374 } 3375 } 3376 else 3377 got = PerlSIO_fread(vbuf, 1, count, s); 3378 if (got == 0 && PerlSIO_ferror(s)) 3379 got = -1; 3380 if (got >= 0 || errno != EINTR) 3381 break; 3382 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 3383 return -1; 3384 SETERRNO(0,0); /* just in case */ 3385 } 3386 #ifdef __sgi 3387 /* Under some circumstances IRIX stdio fgetc() and fread() 3388 * set the errno to ENOENT, which makes no sense according 3389 * to either IRIX or POSIX. [rt.perl.org #123977] */ 3390 if (errno == ENOENT) SETERRNO(0,0); 3391 #endif 3392 return got; 3393 } 3394 3395 SSize_t 3396 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3397 { 3398 SSize_t unread = 0; 3399 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; 3400 3401 #ifdef STDIO_BUFFER_WRITABLE 3402 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 3403 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 3404 STDCHAR *base = PerlIO_get_base(f); 3405 SSize_t cnt = PerlIO_get_cnt(f); 3406 STDCHAR *ptr = PerlIO_get_ptr(f); 3407 SSize_t avail = ptr - base; 3408 if (avail > 0) { 3409 if (avail > count) { 3410 avail = count; 3411 } 3412 ptr -= avail; 3413 Move(buf-avail,ptr,avail,STDCHAR); 3414 count -= avail; 3415 unread += avail; 3416 PerlIO_set_ptrcnt(f,ptr,cnt+avail); 3417 if (PerlSIO_feof(s) && unread >= 0) 3418 PerlSIO_clearerr(s); 3419 } 3420 } 3421 else 3422 #endif 3423 if (PerlIO_has_cntptr(f)) { 3424 /* We can get pointer to buffer but not its base 3425 Do ungetc() but check chars are ending up in the 3426 buffer 3427 */ 3428 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); 3429 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 3430 while (count > 0) { 3431 const int ch = *--buf & 0xFF; 3432 if (ungetc(ch,s) != ch) { 3433 /* ungetc did not work */ 3434 break; 3435 } 3436 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { 3437 /* Did not change pointer as expected */ 3438 if (fgetc(s) != EOF) /* get char back again */ 3439 break; 3440 } 3441 /* It worked ! */ 3442 count--; 3443 unread++; 3444 } 3445 } 3446 3447 if (count > 0) { 3448 unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 3449 } 3450 return unread; 3451 } 3452 3453 SSize_t 3454 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3455 { 3456 SSize_t got; 3457 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 3458 return -1; 3459 for (;;) { 3460 got = PerlSIO_fwrite(vbuf, 1, count, 3461 PerlIOSelf(f, PerlIOStdio)->stdio); 3462 if (got >= 0 || errno != EINTR) 3463 break; 3464 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 3465 return -1; 3466 SETERRNO(0,0); /* just in case */ 3467 } 3468 return got; 3469 } 3470 3471 IV 3472 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 3473 { 3474 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3475 PERL_UNUSED_CONTEXT; 3476 3477 return PerlSIO_fseek(stdio, offset, whence); 3478 } 3479 3480 Off_t 3481 PerlIOStdio_tell(pTHX_ PerlIO *f) 3482 { 3483 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3484 PERL_UNUSED_CONTEXT; 3485 3486 return PerlSIO_ftell(stdio); 3487 } 3488 3489 IV 3490 PerlIOStdio_flush(pTHX_ PerlIO *f) 3491 { 3492 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3493 PERL_UNUSED_CONTEXT; 3494 3495 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 3496 return PerlSIO_fflush(stdio); 3497 } 3498 else { 3499 NOOP; 3500 #if 0 3501 /* 3502 * FIXME: This discards ungetc() and pre-read stuff which is not 3503 * right if this is just a "sync" from a layer above Suspect right 3504 * design is to do _this_ but not have layer above flush this 3505 * layer read-to-read 3506 */ 3507 /* 3508 * Not writeable - sync by attempting a seek 3509 */ 3510 dSAVE_ERRNO; 3511 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) 3512 RESTORE_ERRNO; 3513 #endif 3514 } 3515 return 0; 3516 } 3517 3518 IV 3519 PerlIOStdio_eof(pTHX_ PerlIO *f) 3520 { 3521 PERL_UNUSED_CONTEXT; 3522 3523 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio); 3524 } 3525 3526 IV 3527 PerlIOStdio_error(pTHX_ PerlIO *f) 3528 { 3529 PERL_UNUSED_CONTEXT; 3530 3531 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio); 3532 } 3533 3534 void 3535 PerlIOStdio_clearerr(pTHX_ PerlIO *f) 3536 { 3537 PERL_UNUSED_CONTEXT; 3538 3539 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio); 3540 } 3541 3542 void 3543 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f) 3544 { 3545 PERL_UNUSED_CONTEXT; 3546 3547 #ifdef HAS_SETLINEBUF 3548 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio); 3549 #else 3550 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0); 3551 #endif 3552 } 3553 3554 #ifdef FILE_base 3555 STDCHAR * 3556 PerlIOStdio_get_base(pTHX_ PerlIO *f) 3557 { 3558 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3559 PERL_UNUSED_CONTEXT; 3560 return (STDCHAR*)PerlSIO_get_base(stdio); 3561 } 3562 3563 Size_t 3564 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f) 3565 { 3566 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3567 PERL_UNUSED_CONTEXT; 3568 return PerlSIO_get_bufsiz(stdio); 3569 } 3570 #endif 3571 3572 #ifdef USE_STDIO_PTR 3573 STDCHAR * 3574 PerlIOStdio_get_ptr(pTHX_ PerlIO *f) 3575 { 3576 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3577 PERL_UNUSED_CONTEXT; 3578 return (STDCHAR*)PerlSIO_get_ptr(stdio); 3579 } 3580 3581 SSize_t 3582 PerlIOStdio_get_cnt(pTHX_ PerlIO *f) 3583 { 3584 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3585 PERL_UNUSED_CONTEXT; 3586 return PerlSIO_get_cnt(stdio); 3587 } 3588 3589 void 3590 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 3591 { 3592 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3593 PERL_UNUSED_CONTEXT; 3594 if (ptr != NULL) { 3595 #ifdef STDIO_PTR_LVALUE 3596 /* This is a long-standing infamous mess. The root of the 3597 * problem is that one cannot know the signedness of char, and 3598 * more precisely the signedness of FILE._ptr. The following 3599 * things have been tried, and they have all failed (across 3600 * different compilers (remember that core needs to to build 3601 * also with c++) and compiler options: 3602 * 3603 * - casting the RHS to (void*) -- works in *some* places 3604 * - casting the LHS to (void*) -- totally unportable 3605 * 3606 * So let's try silencing the warning at least for gcc. */ 3607 GCC_DIAG_IGNORE_STMT(-Wpointer-sign); 3608 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ 3609 GCC_DIAG_RESTORE_STMT; 3610 #ifdef STDIO_PTR_LVAL_SETS_CNT 3611 assert(PerlSIO_get_cnt(stdio) == (cnt)); 3612 #endif 3613 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) 3614 /* 3615 * Setting ptr _does_ change cnt - we are done 3616 */ 3617 return; 3618 #endif 3619 #else /* STDIO_PTR_LVALUE */ 3620 PerlProc_abort(); 3621 #endif /* STDIO_PTR_LVALUE */ 3622 } 3623 /* 3624 * Now (or only) set cnt 3625 */ 3626 #ifdef STDIO_CNT_LVALUE 3627 PerlSIO_set_cnt(stdio, cnt); 3628 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) 3629 PerlSIO_set_ptr(stdio, 3630 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - 3631 cnt)); 3632 #else /* STDIO_PTR_LVAL_SETS_CNT */ 3633 PerlProc_abort(); 3634 #endif /* STDIO_CNT_LVALUE */ 3635 } 3636 3637 3638 #endif 3639 3640 IV 3641 PerlIOStdio_fill(pTHX_ PerlIO *f) 3642 { 3643 FILE * stdio; 3644 int c; 3645 PERL_UNUSED_CONTEXT; 3646 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 3647 return -1; 3648 stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3649 3650 /* 3651 * fflush()ing read-only streams can cause trouble on some stdio-s 3652 */ 3653 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { 3654 if (PerlSIO_fflush(stdio) != 0) 3655 return EOF; 3656 } 3657 for (;;) { 3658 c = PerlSIO_fgetc(stdio); 3659 if (c != EOF) 3660 break; 3661 if (! PerlSIO_ferror(stdio) || errno != EINTR) 3662 return EOF; 3663 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 3664 return -1; 3665 SETERRNO(0,0); 3666 } 3667 3668 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) 3669 3670 #ifdef STDIO_BUFFER_WRITABLE 3671 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 3672 /* Fake ungetc() to the real buffer in case system's ungetc 3673 goes elsewhere 3674 */ 3675 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); 3676 SSize_t cnt = PerlSIO_get_cnt(stdio); 3677 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); 3678 if (ptr == base+1) { 3679 *--ptr = (STDCHAR) c; 3680 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); 3681 if (PerlSIO_feof(stdio)) 3682 PerlSIO_clearerr(stdio); 3683 return 0; 3684 } 3685 } 3686 else 3687 #endif 3688 if (PerlIO_has_cntptr(f)) { 3689 STDCHAR ch = c; 3690 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { 3691 return 0; 3692 } 3693 } 3694 #endif 3695 3696 /* If buffer snoop scheme above fails fall back to 3697 using ungetc(). 3698 */ 3699 if (PerlSIO_ungetc(c, stdio) != c) 3700 return EOF; 3701 3702 return 0; 3703 } 3704 3705 3706 3707 PERLIO_FUNCS_DECL(PerlIO_stdio) = { 3708 sizeof(PerlIO_funcs), 3709 "stdio", 3710 sizeof(PerlIOStdio), 3711 PERLIO_K_BUFFERED|PERLIO_K_RAW, 3712 PerlIOStdio_pushed, 3713 PerlIOBase_popped, 3714 PerlIOStdio_open, 3715 PerlIOBase_binmode, /* binmode */ 3716 NULL, 3717 PerlIOStdio_fileno, 3718 PerlIOStdio_dup, 3719 PerlIOStdio_read, 3720 PerlIOStdio_unread, 3721 PerlIOStdio_write, 3722 PerlIOStdio_seek, 3723 PerlIOStdio_tell, 3724 PerlIOStdio_close, 3725 PerlIOStdio_flush, 3726 PerlIOStdio_fill, 3727 PerlIOStdio_eof, 3728 PerlIOStdio_error, 3729 PerlIOStdio_clearerr, 3730 PerlIOStdio_setlinebuf, 3731 #ifdef FILE_base 3732 PerlIOStdio_get_base, 3733 PerlIOStdio_get_bufsiz, 3734 #else 3735 NULL, 3736 NULL, 3737 #endif 3738 #ifdef USE_STDIO_PTR 3739 PerlIOStdio_get_ptr, 3740 PerlIOStdio_get_cnt, 3741 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO) 3742 PerlIOStdio_set_ptrcnt, 3743 # else 3744 NULL, 3745 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */ 3746 #else 3747 NULL, 3748 NULL, 3749 NULL, 3750 #endif /* USE_STDIO_PTR */ 3751 }; 3752 3753 /* Note that calls to PerlIO_exportFILE() are reversed using 3754 * PerlIO_releaseFILE(), not importFILE. */ 3755 FILE * 3756 PerlIO_exportFILE(PerlIO * f, const char *mode) 3757 { 3758 dTHX; 3759 FILE *stdio = NULL; 3760 if (PerlIOValid(f)) { 3761 char buf[8]; 3762 int fd = PerlIO_fileno(f); 3763 if (fd < 0) { 3764 return NULL; 3765 } 3766 PerlIO_flush(f); 3767 if (!mode || !*mode) { 3768 mode = PerlIO_modestr(f, buf); 3769 } 3770 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); 3771 if (stdio) { 3772 PerlIOl *l = *f; 3773 PerlIO *f2; 3774 /* De-link any lower layers so new :stdio sticks */ 3775 *f = NULL; 3776 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { 3777 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); 3778 s->stdio = stdio; 3779 PerlIOUnix_refcnt_inc(fileno(stdio)); 3780 /* Link previous lower layers under new one */ 3781 *PerlIONext(f) = l; 3782 } 3783 else { 3784 /* restore layers list */ 3785 *f = l; 3786 } 3787 } 3788 } 3789 return stdio; 3790 } 3791 3792 3793 FILE * 3794 PerlIO_findFILE(PerlIO *f) 3795 { 3796 PerlIOl *l = *f; 3797 FILE *stdio; 3798 while (l) { 3799 if (l->tab == &PerlIO_stdio) { 3800 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3801 return s->stdio; 3802 } 3803 l = *PerlIONext(&l); 3804 } 3805 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ 3806 /* However, we're not really exporting a FILE * to someone else (who 3807 becomes responsible for closing it, or calling PerlIO_releaseFILE()) 3808 So we need to undo its reference count increase on the underlying file 3809 descriptor. We have to do this, because if the loop above returns you 3810 the FILE *, then *it* didn't increase any reference count. So there's 3811 only one way to be consistent. */ 3812 stdio = PerlIO_exportFILE(f, NULL); 3813 if (stdio) { 3814 const int fd = fileno(stdio); 3815 if (fd >= 0) 3816 PerlIOUnix_refcnt_dec(fd); 3817 } 3818 return stdio; 3819 } 3820 3821 /* Use this to reverse PerlIO_exportFILE calls. */ 3822 void 3823 PerlIO_releaseFILE(PerlIO *p, FILE *f) 3824 { 3825 PerlIOl *l; 3826 while ((l = *p)) { 3827 if (l->tab == &PerlIO_stdio) { 3828 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3829 if (s->stdio == f) { /* not in a loop */ 3830 const int fd = fileno(f); 3831 if (fd >= 0) 3832 PerlIOUnix_refcnt_dec(fd); 3833 { 3834 dTHX; 3835 PerlIO_pop(aTHX_ p); 3836 } 3837 return; 3838 } 3839 } 3840 p = PerlIONext(p); 3841 } 3842 return; 3843 } 3844 3845 /*--------------------------------------------------------------------------------------*/ 3846 /* 3847 * perlio buffer layer 3848 */ 3849 3850 IV 3851 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 3852 { 3853 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3854 const int fd = PerlIO_fileno(f); 3855 if (fd >= 0 && PerlLIO_isatty(fd)) { 3856 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; 3857 } 3858 if (*PerlIONext(f)) { 3859 const Off_t posn = PerlIO_tell(PerlIONext(f)); 3860 if (posn != (Off_t) - 1) { 3861 b->posn = posn; 3862 } 3863 } 3864 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 3865 } 3866 3867 PerlIO * 3868 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 3869 IV n, const char *mode, int fd, int imode, int perm, 3870 PerlIO *f, int narg, SV **args) 3871 { 3872 if (PerlIOValid(f)) { 3873 PerlIO *next = PerlIONext(f); 3874 PerlIO_funcs *tab = 3875 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); 3876 if (tab && tab->Open) 3877 next = 3878 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3879 next, narg, args); 3880 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { 3881 return NULL; 3882 } 3883 } 3884 else { 3885 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); 3886 int init = 0; 3887 if (*mode == IoTYPE_IMPLICIT) { 3888 init = 1; 3889 /* 3890 * mode++; 3891 */ 3892 } 3893 if (tab && tab->Open) 3894 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3895 f, narg, args); 3896 else 3897 SETERRNO(EINVAL, LIB_INVARG); 3898 if (f) { 3899 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { 3900 /* 3901 * if push fails during open, open fails. close will pop us. 3902 */ 3903 PerlIO_close (f); 3904 return NULL; 3905 } else { 3906 fd = PerlIO_fileno(f); 3907 if (init && fd == 2) { 3908 /* 3909 * Initial stderr is unbuffered 3910 */ 3911 PerlIOBase(f)->flags |= PERLIO_F_UNBUF; 3912 } 3913 #ifdef PERLIO_USING_CRLF 3914 # ifdef PERLIO_IS_BINMODE_FD 3915 if (PERLIO_IS_BINMODE_FD(fd)) 3916 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL); 3917 else 3918 # endif 3919 /* 3920 * do something about failing setmode()? --jhi 3921 */ 3922 PerlLIO_setmode(fd, O_BINARY); 3923 #endif 3924 #ifdef VMS 3925 /* Enable line buffering with record-oriented regular files 3926 * so we don't introduce an extraneous record boundary when 3927 * the buffer fills up. 3928 */ 3929 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 3930 Stat_t st; 3931 if (PerlLIO_fstat(fd, &st) == 0 3932 && S_ISREG(st.st_mode) 3933 && (st.st_fab_rfm == FAB$C_VAR 3934 || st.st_fab_rfm == FAB$C_VFC)) { 3935 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; 3936 } 3937 } 3938 #endif 3939 } 3940 } 3941 } 3942 return f; 3943 } 3944 3945 /* 3946 * This "flush" is akin to sfio's sync in that it handles files in either 3947 * read or write state. For write state, we put the postponed data through 3948 * the next layers. For read state, we seek() the next layers to the 3949 * offset given by current position in the buffer, and discard the buffer 3950 * state (XXXX supposed to be for seek()able buffers only, but now it is done 3951 * in any case?). Then the pass the stick further in chain. 3952 */ 3953 IV 3954 PerlIOBuf_flush(pTHX_ PerlIO *f) 3955 { 3956 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 3957 int code = 0; 3958 PerlIO *n = PerlIONext(f); 3959 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { 3960 /* 3961 * write() the buffer 3962 */ 3963 const STDCHAR *buf = b->buf; 3964 const STDCHAR *p = buf; 3965 while (p < b->ptr) { 3966 SSize_t count = PerlIO_write(n, p, b->ptr - p); 3967 if (count > 0) { 3968 p += count; 3969 } 3970 else if (count < 0 || PerlIO_error(n)) { 3971 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 3972 PerlIO_save_errno(f); 3973 code = -1; 3974 break; 3975 } 3976 } 3977 b->posn += (p - buf); 3978 } 3979 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 3980 STDCHAR *buf = PerlIO_get_base(f); 3981 /* 3982 * Note position change 3983 */ 3984 b->posn += (b->ptr - buf); 3985 if (b->ptr < b->end) { 3986 /* We did not consume all of it - try and seek downstream to 3987 our logical position 3988 */ 3989 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { 3990 /* Reload n as some layers may pop themselves on seek */ 3991 b->posn = PerlIO_tell(n = PerlIONext(f)); 3992 } 3993 else { 3994 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read 3995 data is lost for good - so return saying "ok" having undone 3996 the position adjust 3997 */ 3998 b->posn -= (b->ptr - buf); 3999 return code; 4000 } 4001 } 4002 } 4003 b->ptr = b->end = b->buf; 4004 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4005 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */ 4006 if (PerlIOValid(n) && PerlIO_flush(n) != 0) 4007 code = -1; 4008 return code; 4009 } 4010 4011 /* This discards the content of the buffer after b->ptr, and rereads 4012 * the buffer from the position off in the layer downstream; here off 4013 * is at offset corresponding to b->ptr - b->buf. 4014 */ 4015 IV 4016 PerlIOBuf_fill(pTHX_ PerlIO *f) 4017 { 4018 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4019 PerlIO *n = PerlIONext(f); 4020 SSize_t avail; 4021 /* 4022 * Down-stream flush is defined not to loose read data so is harmless. 4023 * we would not normally be fill'ing if there was data left in anycase. 4024 */ 4025 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */ 4026 return -1; 4027 if (PerlIOBase(f)->flags & PERLIO_F_TTY) 4028 PerlIOBase_flush_linebuf(aTHX); 4029 4030 if (!b->buf) 4031 PerlIO_get_base(f); /* allocate via vtable */ 4032 4033 assert(b->buf); /* The b->buf does get allocated via the vtable system. */ 4034 4035 b->ptr = b->end = b->buf; 4036 4037 if (!PerlIOValid(n)) { 4038 PerlIOBase(f)->flags |= PERLIO_F_EOF; 4039 return -1; 4040 } 4041 4042 if (PerlIO_fast_gets(n)) { 4043 /* 4044 * Layer below is also buffered. We do _NOT_ want to call its 4045 * ->Read() because that will loop till it gets what we asked for 4046 * which may hang on a pipe etc. Instead take anything it has to 4047 * hand, or ask it to fill _once_. 4048 */ 4049 avail = PerlIO_get_cnt(n); 4050 if (avail <= 0) { 4051 avail = PerlIO_fill(n); 4052 if (avail == 0) 4053 avail = PerlIO_get_cnt(n); 4054 else { 4055 if (!PerlIO_error(n) && PerlIO_eof(n)) 4056 avail = 0; 4057 } 4058 } 4059 if (avail > 0) { 4060 STDCHAR *ptr = PerlIO_get_ptr(n); 4061 const SSize_t cnt = avail; 4062 if (avail > (SSize_t)b->bufsiz) 4063 avail = b->bufsiz; 4064 Copy(ptr, b->buf, avail, STDCHAR); 4065 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); 4066 } 4067 } 4068 else { 4069 avail = PerlIO_read(n, b->ptr, b->bufsiz); 4070 } 4071 if (avail <= 0) { 4072 if (avail == 0) 4073 PerlIOBase(f)->flags |= PERLIO_F_EOF; 4074 else 4075 { 4076 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 4077 PerlIO_save_errno(f); 4078 } 4079 return -1; 4080 } 4081 b->end = b->buf + avail; 4082 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4083 return 0; 4084 } 4085 4086 SSize_t 4087 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 4088 { 4089 if (PerlIOValid(f)) { 4090 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4091 if (!b->ptr) 4092 PerlIO_get_base(f); 4093 return PerlIOBase_read(aTHX_ f, vbuf, count); 4094 } 4095 return 0; 4096 } 4097 4098 SSize_t 4099 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4100 { 4101 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 4102 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4103 SSize_t unread = 0; 4104 SSize_t avail; 4105 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 4106 PerlIO_flush(f); 4107 if (!b->buf) 4108 PerlIO_get_base(f); 4109 if (b->buf) { 4110 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 4111 /* 4112 * Buffer is already a read buffer, we can overwrite any chars 4113 * which have been read back to buffer start 4114 */ 4115 avail = (b->ptr - b->buf); 4116 } 4117 else { 4118 /* 4119 * Buffer is idle, set it up so whole buffer is available for 4120 * unread 4121 */ 4122 avail = b->bufsiz; 4123 b->end = b->buf + avail; 4124 b->ptr = b->end; 4125 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4126 /* 4127 * Buffer extends _back_ from where we are now 4128 */ 4129 b->posn -= b->bufsiz; 4130 } 4131 if ((SSize_t) count >= 0 && avail > (SSize_t) count) { 4132 /* 4133 * If we have space for more than count, just move count 4134 */ 4135 avail = count; 4136 } 4137 if (avail > 0) { 4138 b->ptr -= avail; 4139 buf -= avail; 4140 /* 4141 * In simple stdio-like ungetc() case chars will be already 4142 * there 4143 */ 4144 if (buf != b->ptr) { 4145 Copy(buf, b->ptr, avail, STDCHAR); 4146 } 4147 count -= avail; 4148 unread += avail; 4149 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 4150 } 4151 } 4152 if (count > 0) { 4153 unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 4154 } 4155 return unread; 4156 } 4157 4158 SSize_t 4159 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4160 { 4161 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4162 const STDCHAR *buf = (const STDCHAR *) vbuf; 4163 const STDCHAR *flushptr = buf; 4164 Size_t written = 0; 4165 if (!b->buf) 4166 PerlIO_get_base(f); 4167 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) 4168 return 0; 4169 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 4170 if (PerlIO_flush(f) != 0) { 4171 return 0; 4172 } 4173 } 4174 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 4175 flushptr = buf + count; 4176 while (flushptr > buf && *(flushptr - 1) != '\n') 4177 --flushptr; 4178 } 4179 while (count > 0) { 4180 SSize_t avail = b->bufsiz - (b->ptr - b->buf); 4181 if ((SSize_t) count >= 0 && (SSize_t) count < avail) 4182 avail = count; 4183 if (flushptr > buf && flushptr <= buf + avail) 4184 avail = flushptr - buf; 4185 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 4186 if (avail) { 4187 Copy(buf, b->ptr, avail, STDCHAR); 4188 count -= avail; 4189 buf += avail; 4190 written += avail; 4191 b->ptr += avail; 4192 if (buf == flushptr) 4193 PerlIO_flush(f); 4194 } 4195 if (b->ptr >= (b->buf + b->bufsiz)) 4196 if (PerlIO_flush(f) == -1) 4197 return -1; 4198 } 4199 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 4200 PerlIO_flush(f); 4201 return written; 4202 } 4203 4204 IV 4205 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 4206 { 4207 IV code; 4208 if ((code = PerlIO_flush(f)) == 0) { 4209 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 4210 code = PerlIO_seek(PerlIONext(f), offset, whence); 4211 if (code == 0) { 4212 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 4213 b->posn = PerlIO_tell(PerlIONext(f)); 4214 } 4215 } 4216 return code; 4217 } 4218 4219 Off_t 4220 PerlIOBuf_tell(pTHX_ PerlIO *f) 4221 { 4222 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4223 /* 4224 * b->posn is file position where b->buf was read, or will be written 4225 */ 4226 Off_t posn = b->posn; 4227 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && 4228 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { 4229 #if 1 4230 /* As O_APPEND files are normally shared in some sense it is better 4231 to flush : 4232 */ 4233 PerlIO_flush(f); 4234 #else 4235 /* when file is NOT shared then this is sufficient */ 4236 PerlIO_seek(PerlIONext(f),0, SEEK_END); 4237 #endif 4238 posn = b->posn = PerlIO_tell(PerlIONext(f)); 4239 } 4240 if (b->buf) { 4241 /* 4242 * If buffer is valid adjust position by amount in buffer 4243 */ 4244 posn += (b->ptr - b->buf); 4245 } 4246 return posn; 4247 } 4248 4249 IV 4250 PerlIOBuf_popped(pTHX_ PerlIO *f) 4251 { 4252 const IV code = PerlIOBase_popped(aTHX_ f); 4253 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4254 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 4255 Safefree(b->buf); 4256 } 4257 b->ptr = b->end = b->buf = NULL; 4258 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4259 return code; 4260 } 4261 4262 IV 4263 PerlIOBuf_close(pTHX_ PerlIO *f) 4264 { 4265 const IV code = PerlIOBase_close(aTHX_ f); 4266 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4267 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 4268 Safefree(b->buf); 4269 } 4270 b->ptr = b->end = b->buf = NULL; 4271 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4272 return code; 4273 } 4274 4275 STDCHAR * 4276 PerlIOBuf_get_ptr(pTHX_ PerlIO *f) 4277 { 4278 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4279 if (!b->buf) 4280 PerlIO_get_base(f); 4281 return b->ptr; 4282 } 4283 4284 SSize_t 4285 PerlIOBuf_get_cnt(pTHX_ PerlIO *f) 4286 { 4287 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4288 if (!b->buf) 4289 PerlIO_get_base(f); 4290 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) 4291 return (b->end - b->ptr); 4292 return 0; 4293 } 4294 4295 STDCHAR * 4296 PerlIOBuf_get_base(pTHX_ PerlIO *f) 4297 { 4298 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4299 PERL_UNUSED_CONTEXT; 4300 4301 if (!b->buf) { 4302 if (!b->bufsiz) 4303 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; 4304 Newx(b->buf,b->bufsiz, STDCHAR); 4305 if (!b->buf) { 4306 b->buf = (STDCHAR *) & b->oneword; 4307 b->bufsiz = sizeof(b->oneword); 4308 } 4309 b->end = b->ptr = b->buf; 4310 } 4311 return b->buf; 4312 } 4313 4314 Size_t 4315 PerlIOBuf_bufsiz(pTHX_ PerlIO *f) 4316 { 4317 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4318 if (!b->buf) 4319 PerlIO_get_base(f); 4320 return (b->end - b->buf); 4321 } 4322 4323 void 4324 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 4325 { 4326 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4327 #ifndef DEBUGGING 4328 PERL_UNUSED_ARG(cnt); 4329 #endif 4330 if (!b->buf) 4331 PerlIO_get_base(f); 4332 b->ptr = ptr; 4333 assert(PerlIO_get_cnt(f) == cnt); 4334 assert(b->ptr >= b->buf); 4335 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4336 } 4337 4338 PerlIO * 4339 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 4340 { 4341 return PerlIOBase_dup(aTHX_ f, o, param, flags); 4342 } 4343 4344 4345 4346 PERLIO_FUNCS_DECL(PerlIO_perlio) = { 4347 sizeof(PerlIO_funcs), 4348 "perlio", 4349 sizeof(PerlIOBuf), 4350 PERLIO_K_BUFFERED|PERLIO_K_RAW, 4351 PerlIOBuf_pushed, 4352 PerlIOBuf_popped, 4353 PerlIOBuf_open, 4354 PerlIOBase_binmode, /* binmode */ 4355 NULL, 4356 PerlIOBase_fileno, 4357 PerlIOBuf_dup, 4358 PerlIOBuf_read, 4359 PerlIOBuf_unread, 4360 PerlIOBuf_write, 4361 PerlIOBuf_seek, 4362 PerlIOBuf_tell, 4363 PerlIOBuf_close, 4364 PerlIOBuf_flush, 4365 PerlIOBuf_fill, 4366 PerlIOBase_eof, 4367 PerlIOBase_error, 4368 PerlIOBase_clearerr, 4369 PerlIOBase_setlinebuf, 4370 PerlIOBuf_get_base, 4371 PerlIOBuf_bufsiz, 4372 PerlIOBuf_get_ptr, 4373 PerlIOBuf_get_cnt, 4374 PerlIOBuf_set_ptrcnt, 4375 }; 4376 4377 /*--------------------------------------------------------------------------------------*/ 4378 /* 4379 * Temp layer to hold unread chars when cannot do it any other way 4380 */ 4381 4382 IV 4383 PerlIOPending_fill(pTHX_ PerlIO *f) 4384 { 4385 /* 4386 * Should never happen 4387 */ 4388 PerlIO_flush(f); 4389 return 0; 4390 } 4391 4392 IV 4393 PerlIOPending_close(pTHX_ PerlIO *f) 4394 { 4395 /* 4396 * A tad tricky - flush pops us, then we close new top 4397 */ 4398 PerlIO_flush(f); 4399 return PerlIO_close(f); 4400 } 4401 4402 IV 4403 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 4404 { 4405 /* 4406 * A tad tricky - flush pops us, then we seek new top 4407 */ 4408 PerlIO_flush(f); 4409 return PerlIO_seek(f, offset, whence); 4410 } 4411 4412 4413 IV 4414 PerlIOPending_flush(pTHX_ PerlIO *f) 4415 { 4416 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4417 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 4418 Safefree(b->buf); 4419 b->buf = NULL; 4420 } 4421 PerlIO_pop(aTHX_ f); 4422 return 0; 4423 } 4424 4425 void 4426 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 4427 { 4428 if (cnt <= 0) { 4429 PerlIO_flush(f); 4430 } 4431 else { 4432 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); 4433 } 4434 } 4435 4436 IV 4437 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 4438 { 4439 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 4440 PerlIOl * const l = PerlIOBase(f); 4441 /* 4442 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets() 4443 * etc. get muddled when it changes mid-string when we auto-pop. 4444 */ 4445 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) | 4446 (PerlIOBase(PerlIONext(f))-> 4447 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); 4448 return code; 4449 } 4450 4451 SSize_t 4452 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 4453 { 4454 SSize_t avail = PerlIO_get_cnt(f); 4455 SSize_t got = 0; 4456 if ((SSize_t) count >= 0 && (SSize_t)count < avail) 4457 avail = count; 4458 if (avail > 0) 4459 got = PerlIOBuf_read(aTHX_ f, vbuf, avail); 4460 if (got >= 0 && got < (SSize_t)count) { 4461 const SSize_t more = 4462 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); 4463 if (more >= 0 || got == 0) 4464 got += more; 4465 } 4466 return got; 4467 } 4468 4469 PERLIO_FUNCS_DECL(PerlIO_pending) = { 4470 sizeof(PerlIO_funcs), 4471 "pending", 4472 sizeof(PerlIOBuf), 4473 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */ 4474 PerlIOPending_pushed, 4475 PerlIOBuf_popped, 4476 NULL, 4477 PerlIOBase_binmode, /* binmode */ 4478 NULL, 4479 PerlIOBase_fileno, 4480 PerlIOBuf_dup, 4481 PerlIOPending_read, 4482 PerlIOBuf_unread, 4483 PerlIOBuf_write, 4484 PerlIOPending_seek, 4485 PerlIOBuf_tell, 4486 PerlIOPending_close, 4487 PerlIOPending_flush, 4488 PerlIOPending_fill, 4489 PerlIOBase_eof, 4490 PerlIOBase_error, 4491 PerlIOBase_clearerr, 4492 PerlIOBase_setlinebuf, 4493 PerlIOBuf_get_base, 4494 PerlIOBuf_bufsiz, 4495 PerlIOBuf_get_ptr, 4496 PerlIOBuf_get_cnt, 4497 PerlIOPending_set_ptrcnt, 4498 }; 4499 4500 4501 4502 /*--------------------------------------------------------------------------------------*/ 4503 /* 4504 * crlf - translation On read translate CR,LF to "\n" we do this by 4505 * overriding ptr/cnt entries to hand back a line at a time and keeping a 4506 * record of which nl we "lied" about. On write translate "\n" to CR,LF 4507 * 4508 * c->nl points on the first byte of CR LF pair when it is temporarily 4509 * replaced by LF, or to the last CR of the buffer. In the former case 4510 * the caller thinks that the buffer ends at c->nl + 1, in the latter 4511 * that it ends at c->nl; these two cases can be distinguished by 4512 * *c->nl. c->nl is set during _getcnt() call, and unset during 4513 * _unread() and _flush() calls. 4514 * It only matters for read operations. 4515 */ 4516 4517 typedef struct { 4518 PerlIOBuf base; /* PerlIOBuf stuff */ 4519 STDCHAR *nl; /* Position of crlf we "lied" about in the 4520 * buffer */ 4521 } PerlIOCrlf; 4522 4523 /* Inherit the PERLIO_F_UTF8 flag from previous layer. 4524 * Otherwise the :crlf layer would always revert back to 4525 * raw mode. 4526 */ 4527 static void 4528 S_inherit_utf8_flag(PerlIO *f) 4529 { 4530 PerlIO *g = PerlIONext(f); 4531 if (PerlIOValid(g)) { 4532 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { 4533 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 4534 } 4535 } 4536 } 4537 4538 IV 4539 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 4540 { 4541 IV code; 4542 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 4543 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab); 4544 #if 0 4545 DEBUG_i( 4546 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", 4547 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", 4548 PerlIOBase(f)->flags); 4549 ); 4550 #endif 4551 { 4552 /* If the old top layer is a CRLF layer, reactivate it (if 4553 * necessary) and remove this new layer from the stack */ 4554 PerlIO *g = PerlIONext(f); 4555 if (PerlIOValid(g)) { 4556 PerlIOl *b = PerlIOBase(g); 4557 if (b && b->tab == &PerlIO_crlf) { 4558 if (!(b->flags & PERLIO_F_CRLF)) 4559 b->flags |= PERLIO_F_CRLF; 4560 S_inherit_utf8_flag(g); 4561 PerlIO_pop(aTHX_ f); 4562 return code; 4563 } 4564 } 4565 } 4566 S_inherit_utf8_flag(f); 4567 return code; 4568 } 4569 4570 4571 SSize_t 4572 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4573 { 4574 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4575 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */ 4576 *(c->nl) = NATIVE_0xd; 4577 c->nl = NULL; 4578 } 4579 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) 4580 return PerlIOBuf_unread(aTHX_ f, vbuf, count); 4581 else { 4582 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 4583 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 4584 SSize_t unread = 0; 4585 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 4586 PerlIO_flush(f); 4587 if (!b->buf) 4588 PerlIO_get_base(f); 4589 if (b->buf) { 4590 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { 4591 b->end = b->ptr = b->buf + b->bufsiz; 4592 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4593 b->posn -= b->bufsiz; 4594 } 4595 while (count > 0 && b->ptr > b->buf) { 4596 const int ch = *--buf; 4597 if (ch == '\n') { 4598 if (b->ptr - 2 >= b->buf) { 4599 *--(b->ptr) = NATIVE_0xa; 4600 *--(b->ptr) = NATIVE_0xd; 4601 unread++; 4602 count--; 4603 } 4604 else { 4605 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ 4606 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa == 4607 '\r' */ 4608 unread++; 4609 count--; 4610 } 4611 } 4612 else { 4613 *--(b->ptr) = ch; 4614 unread++; 4615 count--; 4616 } 4617 } 4618 } 4619 if (count > 0) 4620 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count); 4621 return unread; 4622 } 4623 } 4624 4625 /* XXXX This code assumes that buffer size >=2, but does not check it... */ 4626 SSize_t 4627 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) 4628 { 4629 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4630 if (!b->buf) 4631 PerlIO_get_base(f); 4632 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 4633 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4634 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { 4635 STDCHAR *nl = (c->nl) ? c->nl : b->ptr; 4636 scan: 4637 while (nl < b->end && *nl != NATIVE_0xd) 4638 nl++; 4639 if (nl < b->end && *nl == NATIVE_0xd) { 4640 test: 4641 if (nl + 1 < b->end) { 4642 if (nl[1] == NATIVE_0xa) { 4643 *nl = '\n'; 4644 c->nl = nl; 4645 } 4646 else { 4647 /* 4648 * Not CR,LF but just CR 4649 */ 4650 nl++; 4651 goto scan; 4652 } 4653 } 4654 else { 4655 /* 4656 * Blast - found CR as last char in buffer 4657 */ 4658 4659 if (b->ptr < nl) { 4660 /* 4661 * They may not care, defer work as long as 4662 * possible 4663 */ 4664 c->nl = nl; 4665 return (nl - b->ptr); 4666 } 4667 else { 4668 int code; 4669 b->ptr++; /* say we have read it as far as 4670 * flush() is concerned */ 4671 b->buf++; /* Leave space in front of buffer */ 4672 /* Note as we have moved buf up flush's 4673 posn += ptr-buf 4674 will naturally make posn point at CR 4675 */ 4676 b->bufsiz--; /* Buffer is thus smaller */ 4677 code = PerlIO_fill(f); /* Fetch some more */ 4678 b->bufsiz++; /* Restore size for next time */ 4679 b->buf--; /* Point at space */ 4680 b->ptr = nl = b->buf; /* Which is what we hand 4681 * off */ 4682 *nl = NATIVE_0xd; /* Fill in the CR */ 4683 if (code == 0) 4684 goto test; /* fill() call worked */ 4685 /* 4686 * CR at EOF - just fall through 4687 */ 4688 /* Should we clear EOF though ??? */ 4689 } 4690 } 4691 } 4692 } 4693 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); 4694 } 4695 return 0; 4696 } 4697 4698 void 4699 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 4700 { 4701 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4702 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4703 if (!b->buf) 4704 PerlIO_get_base(f); 4705 if (!ptr) { 4706 if (c->nl) { 4707 ptr = c->nl + 1; 4708 if (ptr == b->end && *c->nl == NATIVE_0xd) { 4709 /* Deferred CR at end of buffer case - we lied about count */ 4710 ptr--; 4711 } 4712 } 4713 else { 4714 ptr = b->end; 4715 } 4716 ptr -= cnt; 4717 } 4718 else { 4719 NOOP; 4720 #if 0 4721 /* 4722 * Test code - delete when it works ... 4723 */ 4724 IV flags = PerlIOBase(f)->flags; 4725 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; 4726 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { 4727 /* Deferred CR at end of buffer case - we lied about count */ 4728 chk--; 4729 } 4730 chk -= cnt; 4731 4732 if (ptr != chk ) { 4733 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf 4734 " nl=%p e=%p for %d", (void*)ptr, (void*)chk, 4735 flags, c->nl, b->end, cnt); 4736 } 4737 #endif 4738 } 4739 if (c->nl) { 4740 if (ptr > c->nl) { 4741 /* 4742 * They have taken what we lied about 4743 */ 4744 *(c->nl) = NATIVE_0xd; 4745 c->nl = NULL; 4746 ptr++; 4747 } 4748 } 4749 b->ptr = ptr; 4750 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4751 } 4752 4753 SSize_t 4754 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4755 { 4756 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) 4757 return PerlIOBuf_write(aTHX_ f, vbuf, count); 4758 else { 4759 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4760 const STDCHAR *buf = (const STDCHAR *) vbuf; 4761 const STDCHAR * const ebuf = buf + count; 4762 if (!b->buf) 4763 PerlIO_get_base(f); 4764 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) 4765 return 0; 4766 while (buf < ebuf) { 4767 const STDCHAR * const eptr = b->buf + b->bufsiz; 4768 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 4769 while (buf < ebuf && b->ptr < eptr) { 4770 if (*buf == '\n') { 4771 if ((b->ptr + 2) > eptr) { 4772 /* 4773 * Not room for both 4774 */ 4775 PerlIO_flush(f); 4776 break; 4777 } 4778 else { 4779 *(b->ptr)++ = NATIVE_0xd; /* CR */ 4780 *(b->ptr)++ = NATIVE_0xa; /* LF */ 4781 buf++; 4782 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 4783 PerlIO_flush(f); 4784 break; 4785 } 4786 } 4787 } 4788 else { 4789 *(b->ptr)++ = *buf++; 4790 } 4791 if (b->ptr >= eptr) { 4792 PerlIO_flush(f); 4793 break; 4794 } 4795 } 4796 } 4797 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 4798 PerlIO_flush(f); 4799 return (buf - (STDCHAR *) vbuf); 4800 } 4801 } 4802 4803 IV 4804 PerlIOCrlf_flush(pTHX_ PerlIO *f) 4805 { 4806 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4807 if (c->nl) { 4808 *(c->nl) = NATIVE_0xd; 4809 c->nl = NULL; 4810 } 4811 return PerlIOBuf_flush(aTHX_ f); 4812 } 4813 4814 IV 4815 PerlIOCrlf_binmode(pTHX_ PerlIO *f) 4816 { 4817 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { 4818 /* In text mode - flush any pending stuff and flip it */ 4819 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; 4820 #ifndef PERLIO_USING_CRLF 4821 /* CRLF is unusual case - if this is just the :crlf layer pop it */ 4822 PerlIO_pop(aTHX_ f); 4823 #endif 4824 } 4825 return PerlIOBase_binmode(aTHX_ f); 4826 } 4827 4828 PERLIO_FUNCS_DECL(PerlIO_crlf) = { 4829 sizeof(PerlIO_funcs), 4830 "crlf", 4831 sizeof(PerlIOCrlf), 4832 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW, 4833 PerlIOCrlf_pushed, 4834 PerlIOBuf_popped, /* popped */ 4835 PerlIOBuf_open, 4836 PerlIOCrlf_binmode, /* binmode */ 4837 NULL, 4838 PerlIOBase_fileno, 4839 PerlIOBuf_dup, 4840 PerlIOBuf_read, /* generic read works with ptr/cnt lies */ 4841 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ 4842 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ 4843 PerlIOBuf_seek, 4844 PerlIOBuf_tell, 4845 PerlIOBuf_close, 4846 PerlIOCrlf_flush, 4847 PerlIOBuf_fill, 4848 PerlIOBase_eof, 4849 PerlIOBase_error, 4850 PerlIOBase_clearerr, 4851 PerlIOBase_setlinebuf, 4852 PerlIOBuf_get_base, 4853 PerlIOBuf_bufsiz, 4854 PerlIOBuf_get_ptr, 4855 PerlIOCrlf_get_cnt, 4856 PerlIOCrlf_set_ptrcnt, 4857 }; 4858 4859 PerlIO * 4860 Perl_PerlIO_stdin(pTHX) 4861 { 4862 if (!PL_perlio) { 4863 PerlIO_stdstreams(aTHX); 4864 } 4865 return (PerlIO*)&PL_perlio[1]; 4866 } 4867 4868 PerlIO * 4869 Perl_PerlIO_stdout(pTHX) 4870 { 4871 if (!PL_perlio) { 4872 PerlIO_stdstreams(aTHX); 4873 } 4874 return (PerlIO*)&PL_perlio[2]; 4875 } 4876 4877 PerlIO * 4878 Perl_PerlIO_stderr(pTHX) 4879 { 4880 if (!PL_perlio) { 4881 PerlIO_stdstreams(aTHX); 4882 } 4883 return (PerlIO*)&PL_perlio[3]; 4884 } 4885 4886 /*--------------------------------------------------------------------------------------*/ 4887 4888 char * 4889 PerlIO_getname(PerlIO *f, char *buf) 4890 { 4891 #ifdef VMS 4892 dTHX; 4893 char *name = NULL; 4894 bool exported = FALSE; 4895 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 4896 if (!stdio) { 4897 stdio = PerlIO_exportFILE(f,0); 4898 exported = TRUE; 4899 } 4900 if (stdio) { 4901 name = fgetname(stdio, buf); 4902 if (exported) PerlIO_releaseFILE(f,stdio); 4903 } 4904 return name; 4905 #else 4906 PERL_UNUSED_ARG(f); 4907 PERL_UNUSED_ARG(buf); 4908 Perl_croak_nocontext("Don't know how to get file name"); 4909 return NULL; 4910 #endif 4911 } 4912 4913 4914 /*--------------------------------------------------------------------------------------*/ 4915 /* 4916 * Functions which can be called on any kind of PerlIO implemented in 4917 * terms of above 4918 */ 4919 4920 #undef PerlIO_fdopen 4921 PerlIO * 4922 PerlIO_fdopen(int fd, const char *mode) 4923 { 4924 dTHX; 4925 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL); 4926 } 4927 4928 #undef PerlIO_open 4929 PerlIO * 4930 PerlIO_open(const char *path, const char *mode) 4931 { 4932 dTHX; 4933 SV *name = sv_2mortal(newSVpv(path, 0)); 4934 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name); 4935 } 4936 4937 #undef Perlio_reopen 4938 PerlIO * 4939 PerlIO_reopen(const char *path, const char *mode, PerlIO *f) 4940 { 4941 dTHX; 4942 SV *name = sv_2mortal(newSVpv(path,0)); 4943 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name); 4944 } 4945 4946 #undef PerlIO_getc 4947 int 4948 PerlIO_getc(PerlIO *f) 4949 { 4950 dTHX; 4951 STDCHAR buf[1]; 4952 if ( 1 == PerlIO_read(f, buf, 1) ) { 4953 return (unsigned char) buf[0]; 4954 } 4955 return EOF; 4956 } 4957 4958 #undef PerlIO_ungetc 4959 int 4960 PerlIO_ungetc(PerlIO *f, int ch) 4961 { 4962 dTHX; 4963 if (ch != EOF) { 4964 STDCHAR buf = ch; 4965 if (PerlIO_unread(f, &buf, 1) == 1) 4966 return ch; 4967 } 4968 return EOF; 4969 } 4970 4971 #undef PerlIO_putc 4972 int 4973 PerlIO_putc(PerlIO *f, int ch) 4974 { 4975 dTHX; 4976 STDCHAR buf = ch; 4977 return PerlIO_write(f, &buf, 1); 4978 } 4979 4980 #undef PerlIO_puts 4981 int 4982 PerlIO_puts(PerlIO *f, const char *s) 4983 { 4984 dTHX; 4985 return PerlIO_write(f, s, strlen(s)); 4986 } 4987 4988 #undef PerlIO_rewind 4989 void 4990 PerlIO_rewind(PerlIO *f) 4991 { 4992 dTHX; 4993 PerlIO_seek(f, (Off_t) 0, SEEK_SET); 4994 PerlIO_clearerr(f); 4995 } 4996 4997 #undef PerlIO_vprintf 4998 int 4999 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) 5000 { 5001 dTHX; 5002 SV * sv; 5003 const char *s; 5004 STRLEN len; 5005 SSize_t wrote; 5006 #ifdef NEED_VA_COPY 5007 va_list apc; 5008 Perl_va_copy(ap, apc); 5009 sv = vnewSVpvf(fmt, &apc); 5010 va_end(apc); 5011 #else 5012 sv = vnewSVpvf(fmt, &ap); 5013 #endif 5014 s = SvPV_const(sv, len); 5015 wrote = PerlIO_write(f, s, len); 5016 SvREFCNT_dec(sv); 5017 return wrote; 5018 } 5019 5020 #undef PerlIO_printf 5021 int 5022 PerlIO_printf(PerlIO *f, const char *fmt, ...) 5023 { 5024 va_list ap; 5025 int result; 5026 va_start(ap, fmt); 5027 result = PerlIO_vprintf(f, fmt, ap); 5028 va_end(ap); 5029 return result; 5030 } 5031 5032 #undef PerlIO_stdoutf 5033 int 5034 PerlIO_stdoutf(const char *fmt, ...) 5035 { 5036 dTHX; 5037 va_list ap; 5038 int result; 5039 va_start(ap, fmt); 5040 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap); 5041 va_end(ap); 5042 return result; 5043 } 5044 5045 #undef PerlIO_tmpfile 5046 PerlIO * 5047 PerlIO_tmpfile(void) 5048 { 5049 return PerlIO_tmpfile_flags(0); 5050 } 5051 5052 #define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL ) 5053 #define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC ) 5054 5055 PerlIO * 5056 PerlIO_tmpfile_flags(int imode) 5057 { 5058 #ifndef WIN32 5059 dTHX; 5060 #endif 5061 PerlIO *f = NULL; 5062 #ifdef WIN32 5063 const int fd = win32_tmpfd_mode(imode); 5064 if (fd >= 0) 5065 f = PerlIO_fdopen(fd, "w+b"); 5066 #elif ! defined(OS2) 5067 int fd = -1; 5068 char tempname[] = "/tmp/PerlIO_XXXXXX"; 5069 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR"); 5070 SV * sv = NULL; 5071 int old_umask = umask(0177); 5072 imode &= ~MKOSTEMP_MODE_MASK; 5073 if (tmpdir && *tmpdir) { 5074 /* if TMPDIR is set and not empty, we try that first */ 5075 sv = newSVpv(tmpdir, 0); 5076 sv_catpv(sv, tempname + 4); 5077 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); 5078 } 5079 if (fd < 0) { 5080 SvREFCNT_dec(sv); 5081 sv = NULL; 5082 /* else we try /tmp */ 5083 fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE); 5084 } 5085 if (fd < 0) { 5086 /* Try cwd */ 5087 sv = newSVpvs("."); 5088 sv_catpv(sv, tempname + 4); 5089 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); 5090 } 5091 umask(old_umask); 5092 if (fd >= 0) { 5093 /* fdopen() with a numeric mode */ 5094 char mode[8]; 5095 int writing = 1; 5096 (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing); 5097 f = PerlIO_fdopen(fd, mode); 5098 if (f) 5099 PerlIOBase(f)->flags |= PERLIO_F_TEMP; 5100 # ifndef VMS 5101 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); 5102 # endif 5103 } 5104 SvREFCNT_dec(sv); 5105 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ 5106 FILE * const stdio = PerlSIO_tmpfile(); 5107 5108 if (stdio) 5109 f = PerlIO_fdopen(fileno(stdio), "w+"); 5110 5111 #endif /* else WIN32 */ 5112 return f; 5113 } 5114 5115 void 5116 Perl_PerlIO_save_errno(pTHX_ PerlIO *f) 5117 { 5118 PERL_UNUSED_CONTEXT; 5119 if (!PerlIOValid(f)) 5120 return; 5121 PerlIOBase(f)->err = errno; 5122 #ifdef VMS 5123 PerlIOBase(f)->os_err = vaxc$errno; 5124 #elif defined(OS2) 5125 PerlIOBase(f)->os_err = Perl_rc; 5126 #elif defined(WIN32) 5127 PerlIOBase(f)->os_err = GetLastError(); 5128 #endif 5129 } 5130 5131 void 5132 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f) 5133 { 5134 PERL_UNUSED_CONTEXT; 5135 if (!PerlIOValid(f)) 5136 return; 5137 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err); 5138 #ifdef OS2 5139 Perl_rc = PerlIOBase(f)->os_err); 5140 #elif defined(WIN32) 5141 SetLastError(PerlIOBase(f)->os_err); 5142 #endif 5143 } 5144 5145 #undef HAS_FSETPOS 5146 #undef HAS_FGETPOS 5147 5148 5149 /*======================================================================================*/ 5150 /* 5151 * Now some functions in terms of above which may be needed even if we are 5152 * not in true PerlIO mode 5153 */ 5154 const char * 5155 Perl_PerlIO_context_layers(pTHX_ const char *mode) 5156 { 5157 const char *direction = NULL; 5158 SV *layers; 5159 /* 5160 * Need to supply default layer info from open.pm 5161 */ 5162 5163 if (!PL_curcop) 5164 return NULL; 5165 5166 if (mode && mode[0] != 'r') { 5167 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) 5168 direction = "open>"; 5169 } else { 5170 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) 5171 direction = "open<"; 5172 } 5173 if (!direction) 5174 return NULL; 5175 5176 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); 5177 5178 assert(layers); 5179 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL; 5180 } 5181 5182 5183 #ifndef HAS_FSETPOS 5184 #undef PerlIO_setpos 5185 int 5186 PerlIO_setpos(PerlIO *f, SV *pos) 5187 { 5188 if (SvOK(pos)) { 5189 if (f) { 5190 dTHX; 5191 STRLEN len; 5192 const Off_t * const posn = (Off_t *) SvPV(pos, len); 5193 if(len == sizeof(Off_t)) 5194 return PerlIO_seek(f, *posn, SEEK_SET); 5195 } 5196 } 5197 SETERRNO(EINVAL, SS_IVCHAN); 5198 return -1; 5199 } 5200 #else 5201 #undef PerlIO_setpos 5202 int 5203 PerlIO_setpos(PerlIO *f, SV *pos) 5204 { 5205 if (SvOK(pos)) { 5206 if (f) { 5207 dTHX; 5208 STRLEN len; 5209 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); 5210 if(len == sizeof(Fpos_t)) 5211 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 5212 return fsetpos64(f, fpos); 5213 #else 5214 return fsetpos(f, fpos); 5215 #endif 5216 } 5217 } 5218 SETERRNO(EINVAL, SS_IVCHAN); 5219 return -1; 5220 } 5221 #endif 5222 5223 #ifndef HAS_FGETPOS 5224 #undef PerlIO_getpos 5225 int 5226 PerlIO_getpos(PerlIO *f, SV *pos) 5227 { 5228 dTHX; 5229 Off_t posn = PerlIO_tell(f); 5230 sv_setpvn(pos, (char *) &posn, sizeof(posn)); 5231 return (posn == (Off_t) - 1) ? -1 : 0; 5232 } 5233 #else 5234 #undef PerlIO_getpos 5235 int 5236 PerlIO_getpos(PerlIO *f, SV *pos) 5237 { 5238 dTHX; 5239 Fpos_t fpos; 5240 int code; 5241 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 5242 code = fgetpos64(f, &fpos); 5243 #else 5244 code = fgetpos(f, &fpos); 5245 #endif 5246 sv_setpvn(pos, (char *) &fpos, sizeof(fpos)); 5247 return code; 5248 } 5249 #endif 5250 5251 /* print a failure format string message to stderr and fail exit the process 5252 using only libc without depending on any perl data structures being 5253 initialized. 5254 */ 5255 5256 void 5257 Perl_noperl_die(const char* pat, ...) 5258 { 5259 va_list arglist; 5260 PERL_ARGS_ASSERT_NOPERL_DIE; 5261 va_start(arglist, pat); 5262 vfprintf(stderr, pat, arglist); 5263 va_end(arglist); 5264 exit(1); 5265 } 5266 5267 /* 5268 * ex: set ts=8 sts=4 sw=4 et: 5269 */ 5270