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 if ((f = PerlIO_tmpfile())) { 1494 if (!layers || !*layers) 1495 layers = Perl_PerlIO_context_layers(aTHX_ mode); 1496 if (layers && *layers) 1497 PerlIO_apply_layers(aTHX_ f, mode, layers); 1498 } 1499 } 1500 else { 1501 PerlIO_list_t *layera; 1502 IV n; 1503 PerlIO_funcs *tab = NULL; 1504 if (PerlIOValid(f)) { 1505 /* 1506 * This is "reopen" - it is not tested as perl does not use it 1507 * yet 1508 */ 1509 PerlIOl *l = *f; 1510 layera = PerlIO_list_alloc(aTHX); 1511 while (l) { 1512 SV *arg = NULL; 1513 if (l->tab && l->tab->Getarg) 1514 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); 1515 PerlIO_list_push(aTHX_ layera, l->tab, 1516 (arg) ? arg : &PL_sv_undef); 1517 SvREFCNT_dec(arg); 1518 l = *PerlIONext(&l); 1519 } 1520 } 1521 else { 1522 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); 1523 if (!layera) { 1524 return NULL; 1525 } 1526 } 1527 /* 1528 * Start at "top" of layer stack 1529 */ 1530 n = layera->cur - 1; 1531 while (n >= 0) { 1532 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); 1533 if (t && t->Open) { 1534 tab = t; 1535 break; 1536 } 1537 n--; 1538 } 1539 if (tab) { 1540 /* 1541 * Found that layer 'n' can do opens - call it 1542 */ 1543 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { 1544 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); 1545 } 1546 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", 1547 tab->name, layers ? layers : "(Null)", mode, fd, 1548 imode, perm, (void*)f, narg, (void*)args) ); 1549 if (tab->Open) 1550 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, 1551 f, narg, args); 1552 else { 1553 SETERRNO(EINVAL, LIB_INVARG); 1554 f = NULL; 1555 } 1556 if (f) { 1557 if (n + 1 < layera->cur) { 1558 /* 1559 * More layers above the one that we used to open - 1560 * apply them now 1561 */ 1562 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { 1563 /* If pushing layers fails close the file */ 1564 PerlIO_close(f); 1565 f = NULL; 1566 } 1567 } 1568 } 1569 } 1570 PerlIO_list_free(aTHX_ layera); 1571 } 1572 return f; 1573 } 1574 1575 1576 SSize_t 1577 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 1578 { 1579 PERL_ARGS_ASSERT_PERLIO_READ; 1580 1581 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count)); 1582 } 1583 1584 SSize_t 1585 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1586 { 1587 PERL_ARGS_ASSERT_PERLIO_UNREAD; 1588 1589 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count)); 1590 } 1591 1592 SSize_t 1593 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1594 { 1595 PERL_ARGS_ASSERT_PERLIO_WRITE; 1596 1597 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count)); 1598 } 1599 1600 int 1601 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 1602 { 1603 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence)); 1604 } 1605 1606 Off_t 1607 Perl_PerlIO_tell(pTHX_ PerlIO *f) 1608 { 1609 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f)); 1610 } 1611 1612 int 1613 Perl_PerlIO_flush(pTHX_ PerlIO *f) 1614 { 1615 if (f) { 1616 if (*f) { 1617 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1618 1619 if (tab && tab->Flush) 1620 return (*tab->Flush) (aTHX_ f); 1621 else 1622 return 0; /* If no Flush defined, silently succeed. */ 1623 } 1624 else { 1625 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); 1626 SETERRNO(EBADF, SS_IVCHAN); 1627 return -1; 1628 } 1629 } 1630 else { 1631 /* 1632 * Is it good API design to do flush-all on NULL, a potentially 1633 * erroneous input? Maybe some magical value (PerlIO* 1634 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar 1635 * things on fflush(NULL), but should we be bound by their design 1636 * decisions? --jhi 1637 */ 1638 PerlIOl **table = &PL_perlio; 1639 PerlIOl *ff; 1640 int code = 0; 1641 while ((ff = *table)) { 1642 int i; 1643 table = (PerlIOl **) (ff++); 1644 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1645 if (ff->next && PerlIO_flush(&(ff->next)) != 0) 1646 code = -1; 1647 ff++; 1648 } 1649 } 1650 return code; 1651 } 1652 } 1653 1654 void 1655 PerlIOBase_flush_linebuf(pTHX) 1656 { 1657 PerlIOl **table = &PL_perlio; 1658 PerlIOl *f; 1659 while ((f = *table)) { 1660 int i; 1661 table = (PerlIOl **) (f++); 1662 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1663 if (f->next 1664 && (PerlIOBase(&(f->next))-> 1665 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1666 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1667 PerlIO_flush(&(f->next)); 1668 f++; 1669 } 1670 } 1671 } 1672 1673 int 1674 Perl_PerlIO_fill(pTHX_ PerlIO *f) 1675 { 1676 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f)); 1677 } 1678 1679 int 1680 PerlIO_isutf8(PerlIO *f) 1681 { 1682 if (PerlIOValid(f)) 1683 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; 1684 else 1685 SETERRNO(EBADF, SS_IVCHAN); 1686 1687 return -1; 1688 } 1689 1690 int 1691 Perl_PerlIO_eof(pTHX_ PerlIO *f) 1692 { 1693 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f)); 1694 } 1695 1696 int 1697 Perl_PerlIO_error(pTHX_ PerlIO *f) 1698 { 1699 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f)); 1700 } 1701 1702 void 1703 Perl_PerlIO_clearerr(pTHX_ PerlIO *f) 1704 { 1705 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f)); 1706 } 1707 1708 void 1709 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f) 1710 { 1711 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f)); 1712 } 1713 1714 int 1715 PerlIO_has_base(PerlIO *f) 1716 { 1717 if (PerlIOValid(f)) { 1718 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1719 1720 if (tab) 1721 return (tab->Get_base != NULL); 1722 } 1723 1724 return 0; 1725 } 1726 1727 int 1728 PerlIO_fast_gets(PerlIO *f) 1729 { 1730 if (PerlIOValid(f)) { 1731 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { 1732 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1733 1734 if (tab) 1735 return (tab->Set_ptrcnt != NULL); 1736 } 1737 } 1738 1739 return 0; 1740 } 1741 1742 int 1743 PerlIO_has_cntptr(PerlIO *f) 1744 { 1745 if (PerlIOValid(f)) { 1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1747 1748 if (tab) 1749 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); 1750 } 1751 1752 return 0; 1753 } 1754 1755 int 1756 PerlIO_canset_cnt(PerlIO *f) 1757 { 1758 if (PerlIOValid(f)) { 1759 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 1760 1761 if (tab) 1762 return (tab->Set_ptrcnt != NULL); 1763 } 1764 1765 return 0; 1766 } 1767 1768 STDCHAR * 1769 Perl_PerlIO_get_base(pTHX_ PerlIO *f) 1770 { 1771 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f)); 1772 } 1773 1774 SSize_t 1775 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) 1776 { 1777 /* Note that Get_bufsiz returns a Size_t */ 1778 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f)); 1779 } 1780 1781 STDCHAR * 1782 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f) 1783 { 1784 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f)); 1785 } 1786 1787 SSize_t 1788 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) 1789 { 1790 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f)); 1791 } 1792 1793 void 1794 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt) 1795 { 1796 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt)); 1797 } 1798 1799 void 1800 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 1801 { 1802 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt)); 1803 } 1804 1805 1806 /*--------------------------------------------------------------------------------------*/ 1807 /* 1808 * utf8 and raw dummy layers 1809 */ 1810 1811 IV 1812 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1813 { 1814 PERL_UNUSED_CONTEXT; 1815 PERL_UNUSED_ARG(mode); 1816 PERL_UNUSED_ARG(arg); 1817 if (PerlIOValid(f)) { 1818 if (tab && tab->kind & PERLIO_K_UTF8) 1819 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 1820 else 1821 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1822 return 0; 1823 } 1824 return -1; 1825 } 1826 1827 PERLIO_FUNCS_DECL(PerlIO_utf8) = { 1828 sizeof(PerlIO_funcs), 1829 "utf8", 1830 0, 1831 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG, 1832 PerlIOUtf8_pushed, 1833 NULL, 1834 PerlIOBase_open, 1835 NULL, 1836 NULL, 1837 NULL, 1838 NULL, 1839 NULL, 1840 NULL, 1841 NULL, 1842 NULL, 1843 NULL, 1844 NULL, 1845 NULL, /* flush */ 1846 NULL, /* fill */ 1847 NULL, 1848 NULL, 1849 NULL, 1850 NULL, 1851 NULL, /* get_base */ 1852 NULL, /* get_bufsiz */ 1853 NULL, /* get_ptr */ 1854 NULL, /* get_cnt */ 1855 NULL, /* set_ptrcnt */ 1856 }; 1857 1858 PERLIO_FUNCS_DECL(PerlIO_byte) = { 1859 sizeof(PerlIO_funcs), 1860 "bytes", 1861 0, 1862 PERLIO_K_DUMMY | PERLIO_K_MULTIARG, 1863 PerlIOUtf8_pushed, 1864 NULL, 1865 PerlIOBase_open, 1866 NULL, 1867 NULL, 1868 NULL, 1869 NULL, 1870 NULL, 1871 NULL, 1872 NULL, 1873 NULL, 1874 NULL, 1875 NULL, 1876 NULL, /* flush */ 1877 NULL, /* fill */ 1878 NULL, 1879 NULL, 1880 NULL, 1881 NULL, 1882 NULL, /* get_base */ 1883 NULL, /* get_bufsiz */ 1884 NULL, /* get_ptr */ 1885 NULL, /* get_cnt */ 1886 NULL, /* set_ptrcnt */ 1887 }; 1888 1889 PERLIO_FUNCS_DECL(PerlIO_raw) = { 1890 sizeof(PerlIO_funcs), 1891 "raw", 1892 0, 1893 PERLIO_K_DUMMY, 1894 PerlIORaw_pushed, 1895 PerlIOBase_popped, 1896 PerlIOBase_open, 1897 NULL, 1898 NULL, 1899 NULL, 1900 NULL, 1901 NULL, 1902 NULL, 1903 NULL, 1904 NULL, 1905 NULL, 1906 NULL, 1907 NULL, /* flush */ 1908 NULL, /* fill */ 1909 NULL, 1910 NULL, 1911 NULL, 1912 NULL, 1913 NULL, /* get_base */ 1914 NULL, /* get_bufsiz */ 1915 NULL, /* get_ptr */ 1916 NULL, /* get_cnt */ 1917 NULL, /* set_ptrcnt */ 1918 }; 1919 /*--------------------------------------------------------------------------------------*/ 1920 /*--------------------------------------------------------------------------------------*/ 1921 /* 1922 * "Methods" of the "base class" 1923 */ 1924 1925 IV 1926 PerlIOBase_fileno(pTHX_ PerlIO *f) 1927 { 1928 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1; 1929 } 1930 1931 char * 1932 PerlIO_modestr(PerlIO * f, char *buf) 1933 { 1934 char *s = buf; 1935 if (PerlIOValid(f)) { 1936 const IV flags = PerlIOBase(f)->flags; 1937 if (flags & PERLIO_F_APPEND) { 1938 *s++ = 'a'; 1939 if (flags & PERLIO_F_CANREAD) { 1940 *s++ = '+'; 1941 } 1942 } 1943 else if (flags & PERLIO_F_CANREAD) { 1944 *s++ = 'r'; 1945 if (flags & PERLIO_F_CANWRITE) 1946 *s++ = '+'; 1947 } 1948 else if (flags & PERLIO_F_CANWRITE) { 1949 *s++ = 'w'; 1950 if (flags & PERLIO_F_CANREAD) { 1951 *s++ = '+'; 1952 } 1953 } 1954 #ifdef PERLIO_USING_CRLF 1955 if (!(flags & PERLIO_F_CRLF)) 1956 *s++ = 'b'; 1957 #endif 1958 } 1959 *s = '\0'; 1960 return buf; 1961 } 1962 1963 1964 IV 1965 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1966 { 1967 PerlIOl * const l = PerlIOBase(f); 1968 PERL_UNUSED_CONTEXT; 1969 PERL_UNUSED_ARG(arg); 1970 1971 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | 1972 PERLIO_F_TRUNCATE | PERLIO_F_APPEND); 1973 if (tab && tab->Set_ptrcnt != NULL) 1974 l->flags |= PERLIO_F_FASTGETS; 1975 if (mode) { 1976 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) 1977 mode++; 1978 switch (*mode++) { 1979 case 'r': 1980 l->flags |= PERLIO_F_CANREAD; 1981 break; 1982 case 'a': 1983 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; 1984 break; 1985 case 'w': 1986 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; 1987 break; 1988 default: 1989 SETERRNO(EINVAL, LIB_INVARG); 1990 return -1; 1991 } 1992 #ifdef EBCDIC 1993 { 1994 /* The mode variable contains one positional parameter followed by 1995 * optional keyword parameters. The positional parameters must be 1996 * passed as lowercase characters. The keyword parameters can be 1997 * passed in mixed case. They must be separated by commas. Only one 1998 * instance of a keyword can be specified. */ 1999 int comma = 0; 2000 while (*mode) { 2001 switch (*mode++) { 2002 case '+': 2003 if(!comma) 2004 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 2005 break; 2006 case 'b': 2007 if(!comma) 2008 l->flags &= ~PERLIO_F_CRLF; 2009 break; 2010 case 't': 2011 if(!comma) 2012 l->flags |= PERLIO_F_CRLF; 2013 break; 2014 case ',': 2015 comma = 1; 2016 break; 2017 default: 2018 break; 2019 } 2020 } 2021 } 2022 #else 2023 while (*mode) { 2024 switch (*mode++) { 2025 case '+': 2026 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 2027 break; 2028 case 'b': 2029 l->flags &= ~PERLIO_F_CRLF; 2030 break; 2031 case 't': 2032 l->flags |= PERLIO_F_CRLF; 2033 break; 2034 default: 2035 SETERRNO(EINVAL, LIB_INVARG); 2036 return -1; 2037 } 2038 } 2039 #endif 2040 } 2041 else { 2042 if (l->next) { 2043 l->flags |= l->next->flags & 2044 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | 2045 PERLIO_F_APPEND); 2046 } 2047 } 2048 #if 0 2049 DEBUG_i( 2050 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", 2051 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", 2052 l->flags, PerlIO_modestr(f, temp)); 2053 ); 2054 #endif 2055 return 0; 2056 } 2057 2058 IV 2059 PerlIOBase_popped(pTHX_ PerlIO *f) 2060 { 2061 PERL_UNUSED_CONTEXT; 2062 PERL_UNUSED_ARG(f); 2063 return 0; 2064 } 2065 2066 SSize_t 2067 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2068 { 2069 /* 2070 * Save the position as current head considers it 2071 */ 2072 const Off_t old = PerlIO_tell(f); 2073 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL); 2074 PerlIOSelf(f, PerlIOBuf)->posn = old; 2075 return PerlIOBuf_unread(aTHX_ f, vbuf, count); 2076 } 2077 2078 SSize_t 2079 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2080 { 2081 STDCHAR *buf = (STDCHAR *) vbuf; 2082 if (f) { 2083 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { 2084 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2085 SETERRNO(EBADF, SS_IVCHAN); 2086 PerlIO_save_errno(f); 2087 return 0; 2088 } 2089 while (count > 0) { 2090 get_cnt: 2091 { 2092 SSize_t avail = PerlIO_get_cnt(f); 2093 SSize_t take = 0; 2094 if (avail > 0) 2095 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; 2096 if (take > 0) { 2097 STDCHAR *ptr = PerlIO_get_ptr(f); 2098 Copy(ptr, buf, take, STDCHAR); 2099 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); 2100 count -= take; 2101 buf += take; 2102 if (avail == 0) /* set_ptrcnt could have reset avail */ 2103 goto get_cnt; 2104 } 2105 if (count > 0 && avail <= 0) { 2106 if (PerlIO_fill(f) != 0) 2107 break; 2108 } 2109 } 2110 } 2111 return (buf - (STDCHAR *) vbuf); 2112 } 2113 return 0; 2114 } 2115 2116 IV 2117 PerlIOBase_noop_ok(pTHX_ PerlIO *f) 2118 { 2119 PERL_UNUSED_CONTEXT; 2120 PERL_UNUSED_ARG(f); 2121 return 0; 2122 } 2123 2124 IV 2125 PerlIOBase_noop_fail(pTHX_ PerlIO *f) 2126 { 2127 PERL_UNUSED_CONTEXT; 2128 PERL_UNUSED_ARG(f); 2129 return -1; 2130 } 2131 2132 IV 2133 PerlIOBase_close(pTHX_ PerlIO *f) 2134 { 2135 IV code = -1; 2136 if (PerlIOValid(f)) { 2137 PerlIO *n = PerlIONext(f); 2138 code = PerlIO_flush(f); 2139 PerlIOBase(f)->flags &= 2140 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2141 while (PerlIOValid(n)) { 2142 const PerlIO_funcs * const tab = PerlIOBase(n)->tab; 2143 if (tab && tab->Close) { 2144 if ((*tab->Close)(aTHX_ n) != 0) 2145 code = -1; 2146 break; 2147 } 2148 else { 2149 PerlIOBase(n)->flags &= 2150 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2151 } 2152 n = PerlIONext(n); 2153 } 2154 } 2155 else { 2156 SETERRNO(EBADF, SS_IVCHAN); 2157 } 2158 return code; 2159 } 2160 2161 IV 2162 PerlIOBase_eof(pTHX_ PerlIO *f) 2163 { 2164 PERL_UNUSED_CONTEXT; 2165 if (PerlIOValid(f)) { 2166 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; 2167 } 2168 return 1; 2169 } 2170 2171 IV 2172 PerlIOBase_error(pTHX_ PerlIO *f) 2173 { 2174 PERL_UNUSED_CONTEXT; 2175 if (PerlIOValid(f)) { 2176 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; 2177 } 2178 return 1; 2179 } 2180 2181 void 2182 PerlIOBase_clearerr(pTHX_ PerlIO *f) 2183 { 2184 if (PerlIOValid(f)) { 2185 PerlIO * const n = PerlIONext(f); 2186 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); 2187 if (PerlIOValid(n)) 2188 PerlIO_clearerr(n); 2189 } 2190 } 2191 2192 void 2193 PerlIOBase_setlinebuf(pTHX_ PerlIO *f) 2194 { 2195 PERL_UNUSED_CONTEXT; 2196 if (PerlIOValid(f)) { 2197 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; 2198 } 2199 } 2200 2201 SV * 2202 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) 2203 { 2204 if (!arg) 2205 return NULL; 2206 #ifdef USE_ITHREADS 2207 if (param) { 2208 arg = sv_dup(arg, param); 2209 SvREFCNT_inc_simple_void_NN(arg); 2210 return arg; 2211 } 2212 else { 2213 return newSVsv(arg); 2214 } 2215 #else 2216 PERL_UNUSED_ARG(param); 2217 return newSVsv(arg); 2218 #endif 2219 } 2220 2221 PerlIO * 2222 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2223 { 2224 PerlIO * const nexto = PerlIONext(o); 2225 if (PerlIOValid(nexto)) { 2226 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; 2227 if (tab && tab->Dup) 2228 f = (*tab->Dup)(aTHX_ f, nexto, param, flags); 2229 else 2230 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); 2231 } 2232 if (f) { 2233 PerlIO_funcs * const self = PerlIOBase(o)->tab; 2234 SV *arg = NULL; 2235 char buf[8]; 2236 assert(self); 2237 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", 2238 self->name, 2239 (void*)f, (void*)o, (void*)param) ); 2240 if (self->Getarg) 2241 arg = (*self->Getarg)(aTHX_ o, param, flags); 2242 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); 2243 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) 2244 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 2245 SvREFCNT_dec(arg); 2246 } 2247 return f; 2248 } 2249 2250 /* PL_perlio_fd_refcnt[] is in intrpvar.h */ 2251 2252 /* Must be called with PL_perlio_mutex locked. */ 2253 static void 2254 S_more_refcounted_fds(pTHX_ const int new_fd) 2255 PERL_TSA_REQUIRES(PL_perlio_mutex) 2256 { 2257 dVAR; 2258 const int old_max = PL_perlio_fd_refcnt_size; 2259 const int new_max = 16 + (new_fd & ~15); 2260 int *new_array; 2261 2262 #ifndef PERL_IMPLICIT_SYS 2263 PERL_UNUSED_CONTEXT; 2264 #endif 2265 2266 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n", 2267 old_max, new_fd, new_max) ); 2268 2269 if (new_fd < old_max) { 2270 return; 2271 } 2272 2273 assert (new_max > new_fd); 2274 2275 /* Use plain realloc() since we need this memory to be really 2276 * global and visible to all the interpreters and/or threads. */ 2277 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); 2278 2279 if (!new_array) { 2280 MUTEX_UNLOCK(&PL_perlio_mutex); 2281 croak_no_mem(); 2282 } 2283 2284 PL_perlio_fd_refcnt_size = new_max; 2285 PL_perlio_fd_refcnt = new_array; 2286 2287 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n", 2288 (void*)(new_array + old_max), 2289 new_max - old_max) ); 2290 2291 Zero(new_array + old_max, new_max - old_max, int); 2292 } 2293 2294 2295 void 2296 PerlIO_init(pTHX) 2297 { 2298 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */ 2299 PERL_UNUSED_CONTEXT; 2300 } 2301 2302 void 2303 PerlIOUnix_refcnt_inc(int fd) 2304 { 2305 dTHX; 2306 if (fd >= 0) { 2307 dVAR; 2308 2309 MUTEX_LOCK(&PL_perlio_mutex); 2310 if (fd >= PL_perlio_fd_refcnt_size) 2311 S_more_refcounted_fds(aTHX_ fd); 2312 2313 PL_perlio_fd_refcnt[fd]++; 2314 if (PL_perlio_fd_refcnt[fd] <= 0) { 2315 /* diag_listed_as: refcnt_inc: fd %d%s */ 2316 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", 2317 fd, PL_perlio_fd_refcnt[fd]); 2318 } 2319 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", 2320 fd, PL_perlio_fd_refcnt[fd]) ); 2321 2322 MUTEX_UNLOCK(&PL_perlio_mutex); 2323 } else { 2324 /* diag_listed_as: refcnt_inc: fd %d%s */ 2325 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); 2326 } 2327 } 2328 2329 int 2330 PerlIOUnix_refcnt_dec(int fd) 2331 { 2332 int cnt = 0; 2333 if (fd >= 0) { 2334 #ifdef DEBUGGING 2335 dTHX; 2336 #else 2337 dVAR; 2338 #endif 2339 MUTEX_LOCK(&PL_perlio_mutex); 2340 if (fd >= PL_perlio_fd_refcnt_size) { 2341 /* diag_listed_as: refcnt_dec: fd %d%s */ 2342 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", 2343 fd, PL_perlio_fd_refcnt_size); 2344 } 2345 if (PL_perlio_fd_refcnt[fd] <= 0) { 2346 /* diag_listed_as: refcnt_dec: fd %d%s */ 2347 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", 2348 fd, PL_perlio_fd_refcnt[fd]); 2349 } 2350 cnt = --PL_perlio_fd_refcnt[fd]; 2351 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); 2352 MUTEX_UNLOCK(&PL_perlio_mutex); 2353 } else { 2354 /* diag_listed_as: refcnt_dec: fd %d%s */ 2355 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); 2356 } 2357 return cnt; 2358 } 2359 2360 int 2361 PerlIOUnix_refcnt(int fd) 2362 { 2363 dTHX; 2364 int cnt = 0; 2365 if (fd >= 0) { 2366 dVAR; 2367 MUTEX_LOCK(&PL_perlio_mutex); 2368 if (fd >= PL_perlio_fd_refcnt_size) { 2369 /* diag_listed_as: refcnt: fd %d%s */ 2370 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", 2371 fd, PL_perlio_fd_refcnt_size); 2372 } 2373 if (PL_perlio_fd_refcnt[fd] <= 0) { 2374 /* diag_listed_as: refcnt: fd %d%s */ 2375 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", 2376 fd, PL_perlio_fd_refcnt[fd]); 2377 } 2378 cnt = PL_perlio_fd_refcnt[fd]; 2379 MUTEX_UNLOCK(&PL_perlio_mutex); 2380 } else { 2381 /* diag_listed_as: refcnt: fd %d%s */ 2382 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); 2383 } 2384 return cnt; 2385 } 2386 2387 void 2388 PerlIO_cleanup(pTHX) 2389 { 2390 int i; 2391 #ifdef USE_ITHREADS 2392 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) ); 2393 #else 2394 DEBUG_i( PerlIO_debug("Cleanup layers\n") ); 2395 #endif 2396 2397 /* Raise STDIN..STDERR refcount so we don't close them */ 2398 for (i=0; i < 3; i++) 2399 PerlIOUnix_refcnt_inc(i); 2400 PerlIO_cleantable(aTHX_ &PL_perlio); 2401 /* Restore STDIN..STDERR refcount */ 2402 for (i=0; i < 3; i++) 2403 PerlIOUnix_refcnt_dec(i); 2404 2405 if (PL_known_layers) { 2406 PerlIO_list_free(aTHX_ PL_known_layers); 2407 PL_known_layers = NULL; 2408 } 2409 if (PL_def_layerlist) { 2410 PerlIO_list_free(aTHX_ PL_def_layerlist); 2411 PL_def_layerlist = NULL; 2412 } 2413 } 2414 2415 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ 2416 { 2417 dVAR; 2418 #if 0 2419 /* XXX we can't rely on an interpreter being present at this late stage, 2420 XXX so we can't use a function like PerlLIO_write that relies on one 2421 being present (at least in win32) :-(. 2422 Disable for now. 2423 */ 2424 #ifdef DEBUGGING 2425 { 2426 /* By now all filehandles should have been closed, so any 2427 * stray (non-STD-)filehandles indicate *possible* (PerlIO) 2428 * errors. */ 2429 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64 2430 #define PERLIO_TEARDOWN_MESSAGE_FD 2 2431 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; 2432 int i; 2433 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { 2434 if (PL_perlio_fd_refcnt[i]) { 2435 const STRLEN len = 2436 my_snprintf(buf, sizeof(buf), 2437 "PerlIO_teardown: fd %d refcnt=%d\n", 2438 i, PL_perlio_fd_refcnt[i]); 2439 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); 2440 } 2441 } 2442 } 2443 #endif 2444 #endif 2445 /* Not bothering with PL_perlio_mutex since by now 2446 * all the interpreters are gone. */ 2447 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */ 2448 && PL_perlio_fd_refcnt) { 2449 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ 2450 PL_perlio_fd_refcnt = NULL; 2451 PL_perlio_fd_refcnt_size = 0; 2452 } 2453 } 2454 2455 /*--------------------------------------------------------------------------------------*/ 2456 /* 2457 * Bottom-most level for UNIX-like case 2458 */ 2459 2460 typedef struct { 2461 struct _PerlIO base; /* The generic part */ 2462 int fd; /* UNIX like file descriptor */ 2463 int oflags; /* open/fcntl flags */ 2464 } PerlIOUnix; 2465 2466 static void 2467 S_lockcnt_dec(pTHX_ const void* f) 2468 { 2469 #ifndef PERL_IMPLICIT_SYS 2470 PERL_UNUSED_CONTEXT; 2471 #endif 2472 PerlIO_lockcnt((PerlIO*)f)--; 2473 } 2474 2475 2476 /* call the signal handler, and if that handler happens to clear 2477 * this handle, free what we can and return true */ 2478 2479 static bool 2480 S_perlio_async_run(pTHX_ PerlIO* f) { 2481 ENTER; 2482 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f); 2483 PerlIO_lockcnt(f)++; 2484 PERL_ASYNC_CHECK(); 2485 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) { 2486 LEAVE; 2487 return 0; 2488 } 2489 /* we've just run some perl-level code that could have done 2490 * anything, including closing the file or clearing this layer. 2491 * If so, free any lower layers that have already been 2492 * cleared, then return an error. */ 2493 while (PerlIOValid(f) && 2494 (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) 2495 { 2496 const PerlIOl *l = *f; 2497 *f = l->next; 2498 Safefree(l); 2499 } 2500 LEAVE; 2501 return 1; 2502 } 2503 2504 int 2505 PerlIOUnix_oflags(const char *mode) 2506 { 2507 int oflags = -1; 2508 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) 2509 mode++; 2510 switch (*mode) { 2511 case 'r': 2512 oflags = O_RDONLY; 2513 if (*++mode == '+') { 2514 oflags = O_RDWR; 2515 mode++; 2516 } 2517 break; 2518 2519 case 'w': 2520 oflags = O_CREAT | O_TRUNC; 2521 if (*++mode == '+') { 2522 oflags |= O_RDWR; 2523 mode++; 2524 } 2525 else 2526 oflags |= O_WRONLY; 2527 break; 2528 2529 case 'a': 2530 oflags = O_CREAT | O_APPEND; 2531 if (*++mode == '+') { 2532 oflags |= O_RDWR; 2533 mode++; 2534 } 2535 else 2536 oflags |= O_WRONLY; 2537 break; 2538 } 2539 2540 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */ 2541 2542 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one 2543 * of them in, and then bit-and-masking the other them away, won't 2544 * have much of an effect. */ 2545 switch (*mode) { 2546 case 'b': 2547 #if O_TEXT != O_BINARY 2548 oflags |= O_BINARY; 2549 oflags &= ~O_TEXT; 2550 #endif 2551 mode++; 2552 break; 2553 case 't': 2554 #if O_TEXT != O_BINARY 2555 oflags |= O_TEXT; 2556 oflags &= ~O_BINARY; 2557 #endif 2558 mode++; 2559 break; 2560 default: 2561 # if O_BINARY != 0 2562 /* bit-or:ing with zero O_BINARY would be useless. */ 2563 /* 2564 * If neither "t" nor "b" was specified, open the file 2565 * in O_BINARY mode. 2566 * 2567 * Note that if something else than the zero byte was seen 2568 * here (e.g. bogus mode "rx"), just few lines later we will 2569 * set the errno and invalidate the flags. 2570 */ 2571 oflags |= O_BINARY; 2572 # endif 2573 break; 2574 } 2575 if (*mode || oflags == -1) { 2576 SETERRNO(EINVAL, LIB_INVARG); 2577 oflags = -1; 2578 } 2579 return oflags; 2580 } 2581 2582 IV 2583 PerlIOUnix_fileno(pTHX_ PerlIO *f) 2584 { 2585 PERL_UNUSED_CONTEXT; 2586 return PerlIOSelf(f, PerlIOUnix)->fd; 2587 } 2588 2589 static void 2590 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) 2591 { 2592 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix); 2593 #if defined(WIN32) 2594 Stat_t st; 2595 if (PerlLIO_fstat(fd, &st) == 0) { 2596 if (!S_ISREG(st.st_mode)) { 2597 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); 2598 PerlIOBase(f)->flags |= PERLIO_F_NOTREG; 2599 } 2600 else { 2601 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); 2602 } 2603 } 2604 #endif 2605 s->fd = fd; 2606 s->oflags = imode; 2607 PerlIOUnix_refcnt_inc(fd); 2608 PERL_UNUSED_CONTEXT; 2609 } 2610 2611 IV 2612 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2613 { 2614 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2615 if (*PerlIONext(f)) { 2616 /* We never call down so do any pending stuff now */ 2617 PerlIO_flush(PerlIONext(f)); 2618 /* 2619 * XXX could (or should) we retrieve the oflags from the open file 2620 * handle rather than believing the "mode" we are passed in? XXX 2621 * Should the value on NULL mode be 0 or -1? 2622 */ 2623 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), 2624 mode ? PerlIOUnix_oflags(mode) : -1); 2625 } 2626 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2627 2628 return code; 2629 } 2630 2631 IV 2632 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 2633 { 2634 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2635 Off_t new_loc; 2636 PERL_UNUSED_CONTEXT; 2637 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { 2638 #ifdef ESPIPE 2639 SETERRNO(ESPIPE, LIB_INVARG); 2640 #else 2641 SETERRNO(EINVAL, LIB_INVARG); 2642 #endif 2643 return -1; 2644 } 2645 new_loc = PerlLIO_lseek(fd, offset, whence); 2646 if (new_loc == (Off_t) - 1) 2647 return -1; 2648 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 2649 return 0; 2650 } 2651 2652 PerlIO * 2653 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 2654 IV n, const char *mode, int fd, int imode, 2655 int perm, PerlIO *f, int narg, SV **args) 2656 { 2657 bool known_cloexec = 0; 2658 if (PerlIOValid(f)) { 2659 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) 2660 (*PerlIOBase(f)->tab->Close)(aTHX_ f); 2661 } 2662 if (narg > 0) { 2663 if (*mode == IoTYPE_NUMERIC) 2664 mode++; 2665 else { 2666 imode = PerlIOUnix_oflags(mode); 2667 #ifdef VMS 2668 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ 2669 #else 2670 perm = 0666; 2671 #endif 2672 } 2673 if (imode != -1) { 2674 STRLEN len; 2675 const char *path = SvPV_const(*args, len); 2676 if (!IS_SAFE_PATHNAME(path, len, "open")) 2677 return NULL; 2678 fd = PerlLIO_open3_cloexec(path, imode, perm); 2679 known_cloexec = 1; 2680 } 2681 } 2682 if (fd >= 0) { 2683 if (known_cloexec) 2684 setfd_inhexec_for_sysfd(fd); 2685 else 2686 setfd_cloexec_or_inhexec_by_sysfdness(fd); 2687 if (*mode == IoTYPE_IMPLICIT) 2688 mode++; 2689 if (!f) { 2690 f = PerlIO_allocate(aTHX); 2691 } 2692 if (!PerlIOValid(f)) { 2693 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 2694 PerlLIO_close(fd); 2695 return NULL; 2696 } 2697 } 2698 PerlIOUnix_setfd(aTHX_ f, fd, imode); 2699 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2700 if (*mode == IoTYPE_APPEND) 2701 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); 2702 return f; 2703 } 2704 else { 2705 if (f) { 2706 NOOP; 2707 /* 2708 * FIXME: pop layers ??? 2709 */ 2710 } 2711 return NULL; 2712 } 2713 } 2714 2715 PerlIO * 2716 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2717 { 2718 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix); 2719 int fd = os->fd; 2720 if (flags & PERLIO_DUP_FD) { 2721 fd = PerlLIO_dup_cloexec(fd); 2722 if (fd >= 0) 2723 setfd_inhexec_for_sysfd(fd); 2724 } 2725 if (fd >= 0) { 2726 f = PerlIOBase_dup(aTHX_ f, o, param, flags); 2727 if (f) { 2728 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ 2729 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); 2730 return f; 2731 } 2732 PerlLIO_close(fd); 2733 } 2734 return NULL; 2735 } 2736 2737 2738 SSize_t 2739 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2740 { 2741 int fd; 2742 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 2743 return -1; 2744 fd = PerlIOSelf(f, PerlIOUnix)->fd; 2745 #ifdef PERLIO_STD_SPECIAL 2746 if (fd == 0) 2747 return PERLIO_STD_IN(fd, vbuf, count); 2748 #endif 2749 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || 2750 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { 2751 return 0; 2752 } 2753 while (1) { 2754 const SSize_t len = PerlLIO_read(fd, vbuf, count); 2755 if (len >= 0 || errno != EINTR) { 2756 if (len < 0) { 2757 if (errno != EAGAIN) { 2758 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2759 PerlIO_save_errno(f); 2760 } 2761 } 2762 else if (len == 0 && count != 0) { 2763 PerlIOBase(f)->flags |= PERLIO_F_EOF; 2764 SETERRNO(0,0); 2765 } 2766 return len; 2767 } 2768 /* EINTR */ 2769 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 2770 return -1; 2771 } 2772 NOT_REACHED; /*NOTREACHED*/ 2773 } 2774 2775 SSize_t 2776 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2777 { 2778 int fd; 2779 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 2780 return -1; 2781 fd = PerlIOSelf(f, PerlIOUnix)->fd; 2782 #ifdef PERLIO_STD_SPECIAL 2783 if (fd == 1 || fd == 2) 2784 return PERLIO_STD_OUT(fd, vbuf, count); 2785 #endif 2786 while (1) { 2787 const SSize_t len = PerlLIO_write(fd, vbuf, count); 2788 if (len >= 0 || errno != EINTR) { 2789 if (len < 0) { 2790 if (errno != EAGAIN) { 2791 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2792 PerlIO_save_errno(f); 2793 } 2794 } 2795 return len; 2796 } 2797 /* EINTR */ 2798 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 2799 return -1; 2800 } 2801 NOT_REACHED; /*NOTREACHED*/ 2802 } 2803 2804 Off_t 2805 PerlIOUnix_tell(pTHX_ PerlIO *f) 2806 { 2807 PERL_UNUSED_CONTEXT; 2808 2809 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR); 2810 } 2811 2812 2813 IV 2814 PerlIOUnix_close(pTHX_ PerlIO *f) 2815 { 2816 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2817 int code = 0; 2818 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { 2819 if (PerlIOUnix_refcnt_dec(fd) > 0) { 2820 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2821 return 0; 2822 } 2823 } 2824 else { 2825 SETERRNO(EBADF,SS_IVCHAN); 2826 return -1; 2827 } 2828 while (PerlLIO_close(fd) != 0) { 2829 if (errno != EINTR) { 2830 code = -1; 2831 break; 2832 } 2833 /* EINTR */ 2834 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 2835 return -1; 2836 } 2837 if (code == 0) { 2838 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2839 } 2840 return code; 2841 } 2842 2843 PERLIO_FUNCS_DECL(PerlIO_unix) = { 2844 sizeof(PerlIO_funcs), 2845 "unix", 2846 sizeof(PerlIOUnix), 2847 PERLIO_K_RAW, 2848 PerlIOUnix_pushed, 2849 PerlIOBase_popped, 2850 PerlIOUnix_open, 2851 PerlIOBase_binmode, /* binmode */ 2852 NULL, 2853 PerlIOUnix_fileno, 2854 PerlIOUnix_dup, 2855 PerlIOUnix_read, 2856 PerlIOBase_unread, 2857 PerlIOUnix_write, 2858 PerlIOUnix_seek, 2859 PerlIOUnix_tell, 2860 PerlIOUnix_close, 2861 PerlIOBase_noop_ok, /* flush */ 2862 PerlIOBase_noop_fail, /* fill */ 2863 PerlIOBase_eof, 2864 PerlIOBase_error, 2865 PerlIOBase_clearerr, 2866 PerlIOBase_setlinebuf, 2867 NULL, /* get_base */ 2868 NULL, /* get_bufsiz */ 2869 NULL, /* get_ptr */ 2870 NULL, /* get_cnt */ 2871 NULL, /* set_ptrcnt */ 2872 }; 2873 2874 /*--------------------------------------------------------------------------------------*/ 2875 /* 2876 * stdio as a layer 2877 */ 2878 2879 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE) 2880 /* perl5.8 - This ensures the last minute VMS ungetc fix is not 2881 broken by the last second glibc 2.3 fix 2882 */ 2883 #define STDIO_BUFFER_WRITABLE 2884 #endif 2885 2886 2887 typedef struct { 2888 struct _PerlIO base; 2889 FILE *stdio; /* The stream */ 2890 } PerlIOStdio; 2891 2892 IV 2893 PerlIOStdio_fileno(pTHX_ PerlIO *f) 2894 { 2895 PERL_UNUSED_CONTEXT; 2896 2897 if (PerlIOValid(f)) { 2898 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; 2899 if (s) 2900 return PerlSIO_fileno(s); 2901 } 2902 errno = EBADF; 2903 return -1; 2904 } 2905 2906 char * 2907 PerlIOStdio_mode(const char *mode, char *tmode) 2908 { 2909 char * const ret = tmode; 2910 if (mode) { 2911 while (*mode) { 2912 *tmode++ = *mode++; 2913 } 2914 } 2915 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) 2916 *tmode++ = 'b'; 2917 #endif 2918 *tmode = '\0'; 2919 return ret; 2920 } 2921 2922 IV 2923 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2924 { 2925 PerlIO *n; 2926 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { 2927 PerlIO_funcs * const toptab = PerlIOBase(n)->tab; 2928 if (toptab == tab) { 2929 /* Top is already stdio - pop self (duplicate) and use original */ 2930 PerlIO_pop(aTHX_ f); 2931 return 0; 2932 } else { 2933 const int fd = PerlIO_fileno(n); 2934 char tmode[8]; 2935 FILE *stdio; 2936 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, 2937 mode = PerlIOStdio_mode(mode, tmode)))) { 2938 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 2939 /* We never call down so do any pending stuff now */ 2940 PerlIO_flush(PerlIONext(f)); 2941 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2942 } 2943 else { 2944 return -1; 2945 } 2946 } 2947 } 2948 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2949 } 2950 2951 2952 PerlIO * 2953 PerlIO_importFILE(FILE *stdio, const char *mode) 2954 { 2955 dTHX; 2956 PerlIO *f = NULL; 2957 #ifdef EBCDIC 2958 int rc; 2959 char filename[FILENAME_MAX]; 2960 fldata_t fileinfo; 2961 #endif 2962 if (stdio) { 2963 PerlIOStdio *s; 2964 int fd0 = fileno(stdio); 2965 if (fd0 < 0) { 2966 #ifdef EBCDIC 2967 rc = fldata(stdio,filename,&fileinfo); 2968 if(rc != 0){ 2969 return NULL; 2970 } 2971 if(fileinfo.__dsorgHFS){ 2972 return NULL; 2973 } 2974 /*This MVS dataset , OK!*/ 2975 #else 2976 return NULL; 2977 #endif 2978 } 2979 if (!mode || !*mode) { 2980 /* We need to probe to see how we can open the stream 2981 so start with read/write and then try write and read 2982 we dup() so that we can fclose without loosing the fd. 2983 2984 Note that the errno value set by a failing fdopen 2985 varies between stdio implementations. 2986 */ 2987 const int fd = PerlLIO_dup_cloexec(fd0); 2988 FILE *f2; 2989 if (fd < 0) { 2990 return f; 2991 } 2992 f2 = PerlSIO_fdopen(fd, (mode = "r+")); 2993 if (!f2) { 2994 f2 = PerlSIO_fdopen(fd, (mode = "w")); 2995 } 2996 if (!f2) { 2997 f2 = PerlSIO_fdopen(fd, (mode = "r")); 2998 } 2999 if (!f2) { 3000 /* Don't seem to be able to open */ 3001 PerlLIO_close(fd); 3002 return f; 3003 } 3004 fclose(f2); 3005 } 3006 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { 3007 s = PerlIOSelf(f, PerlIOStdio); 3008 s->stdio = stdio; 3009 fd0 = fileno(stdio); 3010 if(fd0 != -1){ 3011 PerlIOUnix_refcnt_inc(fd0); 3012 setfd_cloexec_or_inhexec_by_sysfdness(fd0); 3013 } 3014 #ifdef EBCDIC 3015 else{ 3016 rc = fldata(stdio,filename,&fileinfo); 3017 if(rc != 0){ 3018 PerlIOUnix_refcnt_inc(fd0); 3019 } 3020 if(fileinfo.__dsorgHFS){ 3021 PerlIOUnix_refcnt_inc(fd0); 3022 } 3023 /*This MVS dataset , OK!*/ 3024 } 3025 #endif 3026 } 3027 } 3028 return f; 3029 } 3030 3031 PerlIO * 3032 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 3033 IV n, const char *mode, int fd, int imode, 3034 int perm, PerlIO *f, int narg, SV **args) 3035 { 3036 char tmode[8]; 3037 if (PerlIOValid(f)) { 3038 STRLEN len; 3039 const char * const path = SvPV_const(*args, len); 3040 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); 3041 FILE *stdio; 3042 if (!IS_SAFE_PATHNAME(path, len, "open")) 3043 return NULL; 3044 PerlIOUnix_refcnt_dec(fileno(s->stdio)); 3045 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), 3046 s->stdio); 3047 if (!s->stdio) 3048 return NULL; 3049 s->stdio = stdio; 3050 fd = fileno(stdio); 3051 PerlIOUnix_refcnt_inc(fd); 3052 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3053 return f; 3054 } 3055 else { 3056 if (narg > 0) { 3057 STRLEN len; 3058 const char * const path = SvPV_const(*args, len); 3059 if (!IS_SAFE_PATHNAME(path, len, "open")) 3060 return NULL; 3061 if (*mode == IoTYPE_NUMERIC) { 3062 mode++; 3063 fd = PerlLIO_open3_cloexec(path, imode, perm); 3064 } 3065 else { 3066 FILE *stdio; 3067 bool appended = FALSE; 3068 #ifdef __CYGWIN__ 3069 /* Cygwin wants its 'b' early. */ 3070 appended = TRUE; 3071 mode = PerlIOStdio_mode(mode, tmode); 3072 #endif 3073 stdio = PerlSIO_fopen(path, mode); 3074 if (stdio) { 3075 if (!f) { 3076 f = PerlIO_allocate(aTHX); 3077 } 3078 if (!appended) 3079 mode = PerlIOStdio_mode(mode, tmode); 3080 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); 3081 if (f) { 3082 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 3083 fd = fileno(stdio); 3084 PerlIOUnix_refcnt_inc(fd); 3085 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3086 } else { 3087 PerlSIO_fclose(stdio); 3088 } 3089 return f; 3090 } 3091 else { 3092 return NULL; 3093 } 3094 } 3095 } 3096 if (fd >= 0) { 3097 FILE *stdio = NULL; 3098 int init = 0; 3099 if (*mode == IoTYPE_IMPLICIT) { 3100 init = 1; 3101 mode++; 3102 } 3103 if (init) { 3104 switch (fd) { 3105 case 0: 3106 stdio = PerlSIO_stdin; 3107 break; 3108 case 1: 3109 stdio = PerlSIO_stdout; 3110 break; 3111 case 2: 3112 stdio = PerlSIO_stderr; 3113 break; 3114 } 3115 } 3116 else { 3117 stdio = PerlSIO_fdopen(fd, mode = 3118 PerlIOStdio_mode(mode, tmode)); 3119 } 3120 if (stdio) { 3121 if (!f) { 3122 f = PerlIO_allocate(aTHX); 3123 } 3124 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 3125 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 3126 fd = fileno(stdio); 3127 PerlIOUnix_refcnt_inc(fd); 3128 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3129 } 3130 return f; 3131 } 3132 PerlLIO_close(fd); 3133 } 3134 } 3135 return NULL; 3136 } 3137 3138 PerlIO * 3139 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 3140 { 3141 /* This assumes no layers underneath - which is what 3142 happens, but is not how I remember it. NI-S 2001/10/16 3143 */ 3144 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { 3145 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; 3146 const int fd = fileno(stdio); 3147 char mode[8]; 3148 if (flags & PERLIO_DUP_FD) { 3149 const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); 3150 if (dfd >= 0) { 3151 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); 3152 goto set_this; 3153 } 3154 else { 3155 NOOP; 3156 /* FIXME: To avoid messy error recovery if dup fails 3157 re-use the existing stdio as though flag was not set 3158 */ 3159 } 3160 } 3161 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); 3162 set_this: 3163 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 3164 if(stdio) { 3165 int fd = fileno(stdio); 3166 PerlIOUnix_refcnt_inc(fd); 3167 setfd_cloexec_or_inhexec_by_sysfdness(fd); 3168 } 3169 } 3170 return f; 3171 } 3172 3173 static int 3174 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) 3175 { 3176 PERL_UNUSED_CONTEXT; 3177 3178 /* XXX this could use PerlIO_canset_fileno() and 3179 * PerlIO_set_fileno() support from Configure 3180 */ 3181 # if defined(HAS_FDCLOSE) 3182 return fdclose(f, NULL) == 0 ? 1 : 0; 3183 # elif defined(__UCLIBC__) 3184 /* uClibc must come before glibc because it defines __GLIBC__ as well. */ 3185 f->__filedes = -1; 3186 return 1; 3187 # elif defined(__GLIBC__) 3188 /* There may be a better way for GLIBC: 3189 - libio.h defines a flag to not close() on cleanup 3190 */ 3191 f->_fileno = -1; 3192 return 1; 3193 # elif defined(__sun) 3194 PERL_UNUSED_ARG(f); 3195 return 0; 3196 # elif defined(__hpux) 3197 f->__fileH = 0xff; 3198 f->__fileL = 0xff; 3199 return 1; 3200 /* Next one ->_file seems to be a reasonable fallback, i.e. if 3201 your platform does not have special entry try this one. 3202 [For OSF only have confirmation for Tru64 (alpha) 3203 but assume other OSFs will be similar.] 3204 */ 3205 # elif defined(_AIX) || defined(__osf__) || defined(__irix__) 3206 f->_file = -1; 3207 return 1; 3208 # elif defined(__FreeBSD__) 3209 /* There may be a better way on FreeBSD: 3210 - we could insert a dummy func in the _close function entry 3211 f->_close = (int (*)(void *)) dummy_close; 3212 */ 3213 f->_file = -1; 3214 return 1; 3215 # elif defined(__OpenBSD__) 3216 /* There may be a better way on OpenBSD: 3217 - we could insert a dummy func in the _close function entry 3218 f->_close = (int (*)(void *)) dummy_close; 3219 */ 3220 f->_file = -1; 3221 return 1; 3222 # elif defined(__EMX__) 3223 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */ 3224 f->_handle = -1; 3225 return 1; 3226 # elif defined(__CYGWIN__) 3227 /* There may be a better way on CYGWIN: 3228 - we could insert a dummy func in the _close function entry 3229 f->_close = (int (*)(void *)) dummy_close; 3230 */ 3231 f->_file = -1; 3232 return 1; 3233 # elif defined(WIN32) 3234 # if defined(UNDER_CE) 3235 /* WIN_CE does not have access to FILE internals, it hardly has FILE 3236 structure at all 3237 */ 3238 # else 3239 PERLIO_FILE_file(f) = -1; 3240 # endif 3241 return 1; 3242 # else 3243 #if 0 3244 /* Sarathy's code did this - we fall back to a dup/dup2 hack 3245 (which isn't thread safe) instead 3246 */ 3247 # error "Don't know how to set FILE.fileno on your platform" 3248 #endif 3249 PERL_UNUSED_ARG(f); 3250 return 0; 3251 # endif 3252 } 3253 3254 IV 3255 PerlIOStdio_close(pTHX_ PerlIO *f) 3256 { 3257 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3258 if (!stdio) { 3259 errno = EBADF; 3260 return -1; 3261 } 3262 else { 3263 const int fd = fileno(stdio); 3264 int invalidate = 0; 3265 IV result = 0; 3266 int dupfd = -1; 3267 dSAVEDERRNO; 3268 #ifdef USE_ITHREADS 3269 dVAR; 3270 #endif 3271 #ifdef SOCKS5_VERSION_NAME 3272 /* Socks lib overrides close() but stdio isn't linked to 3273 that library (though we are) - so we must call close() 3274 on sockets on stdio's behalf. 3275 */ 3276 int optval; 3277 Sock_size_t optlen = sizeof(int); 3278 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) 3279 invalidate = 1; 3280 #endif 3281 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such 3282 that a subsequent fileno() on it returns -1. Don't want to croak() 3283 from within PerlIOUnix_refcnt_dec() if some buggy caller code is 3284 trying to close an already closed handle which somehow it still has 3285 a reference to. (via.xs, I'm looking at you). */ 3286 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { 3287 /* File descriptor still in use */ 3288 invalidate = 1; 3289 } 3290 if (invalidate) { 3291 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ 3292 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ 3293 return 0; 3294 if (stdio == stdout || stdio == stderr) 3295 return PerlIO_flush(f); 3296 } 3297 MUTEX_LOCK(&PL_perlio_mutex); 3298 /* Right. We need a mutex here because for a brief while we 3299 will have the situation that fd is actually closed. Hence if 3300 a second thread were to get into this block, its dup() would 3301 likely return our fd as its dupfd. (after all, it is closed) 3302 Then if we get to the dup2() first, we blat the fd back 3303 (messing up its temporary as a side effect) only for it to 3304 then close its dupfd (== our fd) in its close(dupfd) */ 3305 3306 /* There is, of course, a race condition, that any other thread 3307 trying to input/output/whatever on this fd will be stuffed 3308 for the duration of this little manoeuvrer. Perhaps we 3309 should hold an IO mutex for the duration of every IO 3310 operation if we know that invalidate doesn't work on this 3311 platform, but that would suck, and could kill performance. 3312 3313 Except that correctness trumps speed. 3314 Advice from klortho #11912. */ 3315 if (invalidate) { 3316 /* Tricky - must fclose(stdio) to free memory but not close(fd) 3317 Use Sarathy's trick from maint-5.6 to invalidate the 3318 fileno slot of the FILE * 3319 */ 3320 result = PerlIO_flush(f); 3321 SAVE_ERRNO; 3322 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); 3323 if (!invalidate) { 3324 dupfd = PerlLIO_dup_cloexec(fd); 3325 #ifdef USE_ITHREADS 3326 if (dupfd < 0) { 3327 /* Oh cXap. This isn't going to go well. Not sure if we can 3328 recover from here, or if closing this particular FILE * 3329 is a good idea now. */ 3330 } 3331 #endif 3332 } 3333 } else { 3334 SAVE_ERRNO; /* This is here only to silence compiler warnings */ 3335 } 3336 result = PerlSIO_fclose(stdio); 3337 /* We treat error from stdio as success if we invalidated 3338 errno may NOT be expected EBADF 3339 */ 3340 if (invalidate && result != 0) { 3341 RESTORE_ERRNO; 3342 result = 0; 3343 } 3344 #ifdef SOCKS5_VERSION_NAME 3345 /* in SOCKS' case, let close() determine return value */ 3346 result = close(fd); 3347 #endif 3348 if (dupfd >= 0) { 3349 PerlLIO_dup2_cloexec(dupfd, fd); 3350 setfd_inhexec_for_sysfd(fd); 3351 PerlLIO_close(dupfd); 3352 } 3353 MUTEX_UNLOCK(&PL_perlio_mutex); 3354 return result; 3355 } 3356 } 3357 3358 SSize_t 3359 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 3360 { 3361 FILE * s; 3362 SSize_t got = 0; 3363 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 3364 return -1; 3365 s = PerlIOSelf(f, PerlIOStdio)->stdio; 3366 for (;;) { 3367 if (count == 1) { 3368 STDCHAR *buf = (STDCHAR *) vbuf; 3369 /* 3370 * Perl is expecting PerlIO_getc() to fill the buffer Linux's 3371 * stdio does not do that for fread() 3372 */ 3373 const int ch = PerlSIO_fgetc(s); 3374 if (ch != EOF) { 3375 *buf = ch; 3376 got = 1; 3377 } 3378 } 3379 else 3380 got = PerlSIO_fread(vbuf, 1, count, s); 3381 if (got == 0 && PerlSIO_ferror(s)) 3382 got = -1; 3383 if (got >= 0 || errno != EINTR) 3384 break; 3385 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 3386 return -1; 3387 SETERRNO(0,0); /* just in case */ 3388 } 3389 #ifdef __sgi 3390 /* Under some circumstances IRIX stdio fgetc() and fread() 3391 * set the errno to ENOENT, which makes no sense according 3392 * to either IRIX or POSIX. [rt.perl.org #123977] */ 3393 if (errno == ENOENT) SETERRNO(0,0); 3394 #endif 3395 return got; 3396 } 3397 3398 SSize_t 3399 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3400 { 3401 SSize_t unread = 0; 3402 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; 3403 3404 #ifdef STDIO_BUFFER_WRITABLE 3405 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 3406 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 3407 STDCHAR *base = PerlIO_get_base(f); 3408 SSize_t cnt = PerlIO_get_cnt(f); 3409 STDCHAR *ptr = PerlIO_get_ptr(f); 3410 SSize_t avail = ptr - base; 3411 if (avail > 0) { 3412 if (avail > count) { 3413 avail = count; 3414 } 3415 ptr -= avail; 3416 Move(buf-avail,ptr,avail,STDCHAR); 3417 count -= avail; 3418 unread += avail; 3419 PerlIO_set_ptrcnt(f,ptr,cnt+avail); 3420 if (PerlSIO_feof(s) && unread >= 0) 3421 PerlSIO_clearerr(s); 3422 } 3423 } 3424 else 3425 #endif 3426 if (PerlIO_has_cntptr(f)) { 3427 /* We can get pointer to buffer but not its base 3428 Do ungetc() but check chars are ending up in the 3429 buffer 3430 */ 3431 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); 3432 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 3433 while (count > 0) { 3434 const int ch = *--buf & 0xFF; 3435 if (ungetc(ch,s) != ch) { 3436 /* ungetc did not work */ 3437 break; 3438 } 3439 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { 3440 /* Did not change pointer as expected */ 3441 if (fgetc(s) != EOF) /* get char back again */ 3442 break; 3443 } 3444 /* It worked ! */ 3445 count--; 3446 unread++; 3447 } 3448 } 3449 3450 if (count > 0) { 3451 unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 3452 } 3453 return unread; 3454 } 3455 3456 SSize_t 3457 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3458 { 3459 SSize_t got; 3460 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 3461 return -1; 3462 for (;;) { 3463 got = PerlSIO_fwrite(vbuf, 1, count, 3464 PerlIOSelf(f, PerlIOStdio)->stdio); 3465 if (got >= 0 || errno != EINTR) 3466 break; 3467 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 3468 return -1; 3469 SETERRNO(0,0); /* just in case */ 3470 } 3471 return got; 3472 } 3473 3474 IV 3475 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 3476 { 3477 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3478 PERL_UNUSED_CONTEXT; 3479 3480 return PerlSIO_fseek(stdio, offset, whence); 3481 } 3482 3483 Off_t 3484 PerlIOStdio_tell(pTHX_ PerlIO *f) 3485 { 3486 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3487 PERL_UNUSED_CONTEXT; 3488 3489 return PerlSIO_ftell(stdio); 3490 } 3491 3492 IV 3493 PerlIOStdio_flush(pTHX_ PerlIO *f) 3494 { 3495 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3496 PERL_UNUSED_CONTEXT; 3497 3498 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 3499 return PerlSIO_fflush(stdio); 3500 } 3501 else { 3502 NOOP; 3503 #if 0 3504 /* 3505 * FIXME: This discards ungetc() and pre-read stuff which is not 3506 * right if this is just a "sync" from a layer above Suspect right 3507 * design is to do _this_ but not have layer above flush this 3508 * layer read-to-read 3509 */ 3510 /* 3511 * Not writeable - sync by attempting a seek 3512 */ 3513 dSAVE_ERRNO; 3514 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) 3515 RESTORE_ERRNO; 3516 #endif 3517 } 3518 return 0; 3519 } 3520 3521 IV 3522 PerlIOStdio_eof(pTHX_ PerlIO *f) 3523 { 3524 PERL_UNUSED_CONTEXT; 3525 3526 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio); 3527 } 3528 3529 IV 3530 PerlIOStdio_error(pTHX_ PerlIO *f) 3531 { 3532 PERL_UNUSED_CONTEXT; 3533 3534 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio); 3535 } 3536 3537 void 3538 PerlIOStdio_clearerr(pTHX_ PerlIO *f) 3539 { 3540 PERL_UNUSED_CONTEXT; 3541 3542 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio); 3543 } 3544 3545 void 3546 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f) 3547 { 3548 PERL_UNUSED_CONTEXT; 3549 3550 #ifdef HAS_SETLINEBUF 3551 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio); 3552 #else 3553 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0); 3554 #endif 3555 } 3556 3557 #ifdef FILE_base 3558 STDCHAR * 3559 PerlIOStdio_get_base(pTHX_ PerlIO *f) 3560 { 3561 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3562 PERL_UNUSED_CONTEXT; 3563 return (STDCHAR*)PerlSIO_get_base(stdio); 3564 } 3565 3566 Size_t 3567 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f) 3568 { 3569 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3570 PERL_UNUSED_CONTEXT; 3571 return PerlSIO_get_bufsiz(stdio); 3572 } 3573 #endif 3574 3575 #ifdef USE_STDIO_PTR 3576 STDCHAR * 3577 PerlIOStdio_get_ptr(pTHX_ PerlIO *f) 3578 { 3579 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3580 PERL_UNUSED_CONTEXT; 3581 return (STDCHAR*)PerlSIO_get_ptr(stdio); 3582 } 3583 3584 SSize_t 3585 PerlIOStdio_get_cnt(pTHX_ PerlIO *f) 3586 { 3587 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3588 PERL_UNUSED_CONTEXT; 3589 return PerlSIO_get_cnt(stdio); 3590 } 3591 3592 void 3593 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 3594 { 3595 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3596 PERL_UNUSED_CONTEXT; 3597 if (ptr != NULL) { 3598 #ifdef STDIO_PTR_LVALUE 3599 /* This is a long-standing infamous mess. The root of the 3600 * problem is that one cannot know the signedness of char, and 3601 * more precisely the signedness of FILE._ptr. The following 3602 * things have been tried, and they have all failed (across 3603 * different compilers (remember that core needs to to build 3604 * also with c++) and compiler options: 3605 * 3606 * - casting the RHS to (void*) -- works in *some* places 3607 * - casting the LHS to (void*) -- totally unportable 3608 * 3609 * So let's try silencing the warning at least for gcc. */ 3610 GCC_DIAG_IGNORE_STMT(-Wpointer-sign); 3611 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ 3612 GCC_DIAG_RESTORE_STMT; 3613 #ifdef STDIO_PTR_LVAL_SETS_CNT 3614 assert(PerlSIO_get_cnt(stdio) == (cnt)); 3615 #endif 3616 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) 3617 /* 3618 * Setting ptr _does_ change cnt - we are done 3619 */ 3620 return; 3621 #endif 3622 #else /* STDIO_PTR_LVALUE */ 3623 PerlProc_abort(); 3624 #endif /* STDIO_PTR_LVALUE */ 3625 } 3626 /* 3627 * Now (or only) set cnt 3628 */ 3629 #ifdef STDIO_CNT_LVALUE 3630 PerlSIO_set_cnt(stdio, cnt); 3631 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) 3632 PerlSIO_set_ptr(stdio, 3633 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - 3634 cnt)); 3635 #else /* STDIO_PTR_LVAL_SETS_CNT */ 3636 PerlProc_abort(); 3637 #endif /* STDIO_CNT_LVALUE */ 3638 } 3639 3640 3641 #endif 3642 3643 IV 3644 PerlIOStdio_fill(pTHX_ PerlIO *f) 3645 { 3646 FILE * stdio; 3647 int c; 3648 PERL_UNUSED_CONTEXT; 3649 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ 3650 return -1; 3651 stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3652 3653 /* 3654 * fflush()ing read-only streams can cause trouble on some stdio-s 3655 */ 3656 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { 3657 if (PerlSIO_fflush(stdio) != 0) 3658 return EOF; 3659 } 3660 for (;;) { 3661 c = PerlSIO_fgetc(stdio); 3662 if (c != EOF) 3663 break; 3664 if (! PerlSIO_ferror(stdio) || errno != EINTR) 3665 return EOF; 3666 if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) 3667 return -1; 3668 SETERRNO(0,0); 3669 } 3670 3671 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) 3672 3673 #ifdef STDIO_BUFFER_WRITABLE 3674 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 3675 /* Fake ungetc() to the real buffer in case system's ungetc 3676 goes elsewhere 3677 */ 3678 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); 3679 SSize_t cnt = PerlSIO_get_cnt(stdio); 3680 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); 3681 if (ptr == base+1) { 3682 *--ptr = (STDCHAR) c; 3683 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); 3684 if (PerlSIO_feof(stdio)) 3685 PerlSIO_clearerr(stdio); 3686 return 0; 3687 } 3688 } 3689 else 3690 #endif 3691 if (PerlIO_has_cntptr(f)) { 3692 STDCHAR ch = c; 3693 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { 3694 return 0; 3695 } 3696 } 3697 #endif 3698 3699 /* If buffer snoop scheme above fails fall back to 3700 using ungetc(). 3701 */ 3702 if (PerlSIO_ungetc(c, stdio) != c) 3703 return EOF; 3704 3705 return 0; 3706 } 3707 3708 3709 3710 PERLIO_FUNCS_DECL(PerlIO_stdio) = { 3711 sizeof(PerlIO_funcs), 3712 "stdio", 3713 sizeof(PerlIOStdio), 3714 PERLIO_K_BUFFERED|PERLIO_K_RAW, 3715 PerlIOStdio_pushed, 3716 PerlIOBase_popped, 3717 PerlIOStdio_open, 3718 PerlIOBase_binmode, /* binmode */ 3719 NULL, 3720 PerlIOStdio_fileno, 3721 PerlIOStdio_dup, 3722 PerlIOStdio_read, 3723 PerlIOStdio_unread, 3724 PerlIOStdio_write, 3725 PerlIOStdio_seek, 3726 PerlIOStdio_tell, 3727 PerlIOStdio_close, 3728 PerlIOStdio_flush, 3729 PerlIOStdio_fill, 3730 PerlIOStdio_eof, 3731 PerlIOStdio_error, 3732 PerlIOStdio_clearerr, 3733 PerlIOStdio_setlinebuf, 3734 #ifdef FILE_base 3735 PerlIOStdio_get_base, 3736 PerlIOStdio_get_bufsiz, 3737 #else 3738 NULL, 3739 NULL, 3740 #endif 3741 #ifdef USE_STDIO_PTR 3742 PerlIOStdio_get_ptr, 3743 PerlIOStdio_get_cnt, 3744 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO) 3745 PerlIOStdio_set_ptrcnt, 3746 # else 3747 NULL, 3748 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */ 3749 #else 3750 NULL, 3751 NULL, 3752 NULL, 3753 #endif /* USE_STDIO_PTR */ 3754 }; 3755 3756 /* Note that calls to PerlIO_exportFILE() are reversed using 3757 * PerlIO_releaseFILE(), not importFILE. */ 3758 FILE * 3759 PerlIO_exportFILE(PerlIO * f, const char *mode) 3760 { 3761 dTHX; 3762 FILE *stdio = NULL; 3763 if (PerlIOValid(f)) { 3764 char buf[8]; 3765 int fd = PerlIO_fileno(f); 3766 if (fd < 0) { 3767 return NULL; 3768 } 3769 PerlIO_flush(f); 3770 if (!mode || !*mode) { 3771 mode = PerlIO_modestr(f, buf); 3772 } 3773 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); 3774 if (stdio) { 3775 PerlIOl *l = *f; 3776 PerlIO *f2; 3777 /* De-link any lower layers so new :stdio sticks */ 3778 *f = NULL; 3779 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { 3780 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); 3781 s->stdio = stdio; 3782 PerlIOUnix_refcnt_inc(fileno(stdio)); 3783 /* Link previous lower layers under new one */ 3784 *PerlIONext(f) = l; 3785 } 3786 else { 3787 /* restore layers list */ 3788 *f = l; 3789 } 3790 } 3791 } 3792 return stdio; 3793 } 3794 3795 3796 FILE * 3797 PerlIO_findFILE(PerlIO *f) 3798 { 3799 PerlIOl *l = *f; 3800 FILE *stdio; 3801 while (l) { 3802 if (l->tab == &PerlIO_stdio) { 3803 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3804 return s->stdio; 3805 } 3806 l = *PerlIONext(&l); 3807 } 3808 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ 3809 /* However, we're not really exporting a FILE * to someone else (who 3810 becomes responsible for closing it, or calling PerlIO_releaseFILE()) 3811 So we need to undo its reference count increase on the underlying file 3812 descriptor. We have to do this, because if the loop above returns you 3813 the FILE *, then *it* didn't increase any reference count. So there's 3814 only one way to be consistent. */ 3815 stdio = PerlIO_exportFILE(f, NULL); 3816 if (stdio) { 3817 const int fd = fileno(stdio); 3818 if (fd >= 0) 3819 PerlIOUnix_refcnt_dec(fd); 3820 } 3821 return stdio; 3822 } 3823 3824 /* Use this to reverse PerlIO_exportFILE calls. */ 3825 void 3826 PerlIO_releaseFILE(PerlIO *p, FILE *f) 3827 { 3828 PerlIOl *l; 3829 while ((l = *p)) { 3830 if (l->tab == &PerlIO_stdio) { 3831 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3832 if (s->stdio == f) { /* not in a loop */ 3833 const int fd = fileno(f); 3834 if (fd >= 0) 3835 PerlIOUnix_refcnt_dec(fd); 3836 { 3837 dTHX; 3838 PerlIO_pop(aTHX_ p); 3839 } 3840 return; 3841 } 3842 } 3843 p = PerlIONext(p); 3844 } 3845 return; 3846 } 3847 3848 /*--------------------------------------------------------------------------------------*/ 3849 /* 3850 * perlio buffer layer 3851 */ 3852 3853 IV 3854 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 3855 { 3856 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3857 const int fd = PerlIO_fileno(f); 3858 if (fd >= 0 && PerlLIO_isatty(fd)) { 3859 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; 3860 } 3861 if (*PerlIONext(f)) { 3862 const Off_t posn = PerlIO_tell(PerlIONext(f)); 3863 if (posn != (Off_t) - 1) { 3864 b->posn = posn; 3865 } 3866 } 3867 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 3868 } 3869 3870 PerlIO * 3871 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 3872 IV n, const char *mode, int fd, int imode, int perm, 3873 PerlIO *f, int narg, SV **args) 3874 { 3875 if (PerlIOValid(f)) { 3876 PerlIO *next = PerlIONext(f); 3877 PerlIO_funcs *tab = 3878 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); 3879 if (tab && tab->Open) 3880 next = 3881 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3882 next, narg, args); 3883 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { 3884 return NULL; 3885 } 3886 } 3887 else { 3888 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); 3889 int init = 0; 3890 if (*mode == IoTYPE_IMPLICIT) { 3891 init = 1; 3892 /* 3893 * mode++; 3894 */ 3895 } 3896 if (tab && tab->Open) 3897 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3898 f, narg, args); 3899 else 3900 SETERRNO(EINVAL, LIB_INVARG); 3901 if (f) { 3902 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { 3903 /* 3904 * if push fails during open, open fails. close will pop us. 3905 */ 3906 PerlIO_close (f); 3907 return NULL; 3908 } else { 3909 fd = PerlIO_fileno(f); 3910 if (init && fd == 2) { 3911 /* 3912 * Initial stderr is unbuffered 3913 */ 3914 PerlIOBase(f)->flags |= PERLIO_F_UNBUF; 3915 } 3916 #ifdef PERLIO_USING_CRLF 3917 # ifdef PERLIO_IS_BINMODE_FD 3918 if (PERLIO_IS_BINMODE_FD(fd)) 3919 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL); 3920 else 3921 # endif 3922 /* 3923 * do something about failing setmode()? --jhi 3924 */ 3925 PerlLIO_setmode(fd, O_BINARY); 3926 #endif 3927 #ifdef VMS 3928 /* Enable line buffering with record-oriented regular files 3929 * so we don't introduce an extraneous record boundary when 3930 * the buffer fills up. 3931 */ 3932 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 3933 Stat_t st; 3934 if (PerlLIO_fstat(fd, &st) == 0 3935 && S_ISREG(st.st_mode) 3936 && (st.st_fab_rfm == FAB$C_VAR 3937 || st.st_fab_rfm == FAB$C_VFC)) { 3938 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; 3939 } 3940 } 3941 #endif 3942 } 3943 } 3944 } 3945 return f; 3946 } 3947 3948 /* 3949 * This "flush" is akin to sfio's sync in that it handles files in either 3950 * read or write state. For write state, we put the postponed data through 3951 * the next layers. For read state, we seek() the next layers to the 3952 * offset given by current position in the buffer, and discard the buffer 3953 * state (XXXX supposed to be for seek()able buffers only, but now it is done 3954 * in any case?). Then the pass the stick further in chain. 3955 */ 3956 IV 3957 PerlIOBuf_flush(pTHX_ PerlIO *f) 3958 { 3959 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 3960 int code = 0; 3961 PerlIO *n = PerlIONext(f); 3962 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { 3963 /* 3964 * write() the buffer 3965 */ 3966 const STDCHAR *buf = b->buf; 3967 const STDCHAR *p = buf; 3968 while (p < b->ptr) { 3969 SSize_t count = PerlIO_write(n, p, b->ptr - p); 3970 if (count > 0) { 3971 p += count; 3972 } 3973 else if (count < 0 || PerlIO_error(n)) { 3974 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 3975 PerlIO_save_errno(f); 3976 code = -1; 3977 break; 3978 } 3979 } 3980 b->posn += (p - buf); 3981 } 3982 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 3983 STDCHAR *buf = PerlIO_get_base(f); 3984 /* 3985 * Note position change 3986 */ 3987 b->posn += (b->ptr - buf); 3988 if (b->ptr < b->end) { 3989 /* We did not consume all of it - try and seek downstream to 3990 our logical position 3991 */ 3992 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { 3993 /* Reload n as some layers may pop themselves on seek */ 3994 b->posn = PerlIO_tell(n = PerlIONext(f)); 3995 } 3996 else { 3997 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read 3998 data is lost for good - so return saying "ok" having undone 3999 the position adjust 4000 */ 4001 b->posn -= (b->ptr - buf); 4002 return code; 4003 } 4004 } 4005 } 4006 b->ptr = b->end = b->buf; 4007 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4008 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */ 4009 if (PerlIOValid(n) && PerlIO_flush(n) != 0) 4010 code = -1; 4011 return code; 4012 } 4013 4014 /* This discards the content of the buffer after b->ptr, and rereads 4015 * the buffer from the position off in the layer downstream; here off 4016 * is at offset corresponding to b->ptr - b->buf. 4017 */ 4018 IV 4019 PerlIOBuf_fill(pTHX_ PerlIO *f) 4020 { 4021 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4022 PerlIO *n = PerlIONext(f); 4023 SSize_t avail; 4024 /* 4025 * Down-stream flush is defined not to loose read data so is harmless. 4026 * we would not normally be fill'ing if there was data left in anycase. 4027 */ 4028 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */ 4029 return -1; 4030 if (PerlIOBase(f)->flags & PERLIO_F_TTY) 4031 PerlIOBase_flush_linebuf(aTHX); 4032 4033 if (!b->buf) 4034 PerlIO_get_base(f); /* allocate via vtable */ 4035 4036 assert(b->buf); /* The b->buf does get allocated via the vtable system. */ 4037 4038 b->ptr = b->end = b->buf; 4039 4040 if (!PerlIOValid(n)) { 4041 PerlIOBase(f)->flags |= PERLIO_F_EOF; 4042 return -1; 4043 } 4044 4045 if (PerlIO_fast_gets(n)) { 4046 /* 4047 * Layer below is also buffered. We do _NOT_ want to call its 4048 * ->Read() because that will loop till it gets what we asked for 4049 * which may hang on a pipe etc. Instead take anything it has to 4050 * hand, or ask it to fill _once_. 4051 */ 4052 avail = PerlIO_get_cnt(n); 4053 if (avail <= 0) { 4054 avail = PerlIO_fill(n); 4055 if (avail == 0) 4056 avail = PerlIO_get_cnt(n); 4057 else { 4058 if (!PerlIO_error(n) && PerlIO_eof(n)) 4059 avail = 0; 4060 } 4061 } 4062 if (avail > 0) { 4063 STDCHAR *ptr = PerlIO_get_ptr(n); 4064 const SSize_t cnt = avail; 4065 if (avail > (SSize_t)b->bufsiz) 4066 avail = b->bufsiz; 4067 Copy(ptr, b->buf, avail, STDCHAR); 4068 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); 4069 } 4070 } 4071 else { 4072 avail = PerlIO_read(n, b->ptr, b->bufsiz); 4073 } 4074 if (avail <= 0) { 4075 if (avail == 0) 4076 PerlIOBase(f)->flags |= PERLIO_F_EOF; 4077 else 4078 { 4079 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 4080 PerlIO_save_errno(f); 4081 } 4082 return -1; 4083 } 4084 b->end = b->buf + avail; 4085 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4086 return 0; 4087 } 4088 4089 SSize_t 4090 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 4091 { 4092 if (PerlIOValid(f)) { 4093 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4094 if (!b->ptr) 4095 PerlIO_get_base(f); 4096 return PerlIOBase_read(aTHX_ f, vbuf, count); 4097 } 4098 return 0; 4099 } 4100 4101 SSize_t 4102 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4103 { 4104 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 4105 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4106 SSize_t unread = 0; 4107 SSize_t avail; 4108 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 4109 PerlIO_flush(f); 4110 if (!b->buf) 4111 PerlIO_get_base(f); 4112 if (b->buf) { 4113 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 4114 /* 4115 * Buffer is already a read buffer, we can overwrite any chars 4116 * which have been read back to buffer start 4117 */ 4118 avail = (b->ptr - b->buf); 4119 } 4120 else { 4121 /* 4122 * Buffer is idle, set it up so whole buffer is available for 4123 * unread 4124 */ 4125 avail = b->bufsiz; 4126 b->end = b->buf + avail; 4127 b->ptr = b->end; 4128 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4129 /* 4130 * Buffer extends _back_ from where we are now 4131 */ 4132 b->posn -= b->bufsiz; 4133 } 4134 if ((SSize_t) count >= 0 && avail > (SSize_t) count) { 4135 /* 4136 * If we have space for more than count, just move count 4137 */ 4138 avail = count; 4139 } 4140 if (avail > 0) { 4141 b->ptr -= avail; 4142 buf -= avail; 4143 /* 4144 * In simple stdio-like ungetc() case chars will be already 4145 * there 4146 */ 4147 if (buf != b->ptr) { 4148 Copy(buf, b->ptr, avail, STDCHAR); 4149 } 4150 count -= avail; 4151 unread += avail; 4152 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 4153 } 4154 } 4155 if (count > 0) { 4156 unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 4157 } 4158 return unread; 4159 } 4160 4161 SSize_t 4162 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4163 { 4164 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4165 const STDCHAR *buf = (const STDCHAR *) vbuf; 4166 const STDCHAR *flushptr = buf; 4167 Size_t written = 0; 4168 if (!b->buf) 4169 PerlIO_get_base(f); 4170 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) 4171 return 0; 4172 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 4173 if (PerlIO_flush(f) != 0) { 4174 return 0; 4175 } 4176 } 4177 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 4178 flushptr = buf + count; 4179 while (flushptr > buf && *(flushptr - 1) != '\n') 4180 --flushptr; 4181 } 4182 while (count > 0) { 4183 SSize_t avail = b->bufsiz - (b->ptr - b->buf); 4184 if ((SSize_t) count >= 0 && (SSize_t) count < avail) 4185 avail = count; 4186 if (flushptr > buf && flushptr <= buf + avail) 4187 avail = flushptr - buf; 4188 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 4189 if (avail) { 4190 Copy(buf, b->ptr, avail, STDCHAR); 4191 count -= avail; 4192 buf += avail; 4193 written += avail; 4194 b->ptr += avail; 4195 if (buf == flushptr) 4196 PerlIO_flush(f); 4197 } 4198 if (b->ptr >= (b->buf + b->bufsiz)) 4199 if (PerlIO_flush(f) == -1) 4200 return -1; 4201 } 4202 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 4203 PerlIO_flush(f); 4204 return written; 4205 } 4206 4207 IV 4208 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 4209 { 4210 IV code; 4211 if ((code = PerlIO_flush(f)) == 0) { 4212 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 4213 code = PerlIO_seek(PerlIONext(f), offset, whence); 4214 if (code == 0) { 4215 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 4216 b->posn = PerlIO_tell(PerlIONext(f)); 4217 } 4218 } 4219 return code; 4220 } 4221 4222 Off_t 4223 PerlIOBuf_tell(pTHX_ PerlIO *f) 4224 { 4225 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4226 /* 4227 * b->posn is file position where b->buf was read, or will be written 4228 */ 4229 Off_t posn = b->posn; 4230 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && 4231 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { 4232 #if 1 4233 /* As O_APPEND files are normally shared in some sense it is better 4234 to flush : 4235 */ 4236 PerlIO_flush(f); 4237 #else 4238 /* when file is NOT shared then this is sufficient */ 4239 PerlIO_seek(PerlIONext(f),0, SEEK_END); 4240 #endif 4241 posn = b->posn = PerlIO_tell(PerlIONext(f)); 4242 } 4243 if (b->buf) { 4244 /* 4245 * If buffer is valid adjust position by amount in buffer 4246 */ 4247 posn += (b->ptr - b->buf); 4248 } 4249 return posn; 4250 } 4251 4252 IV 4253 PerlIOBuf_popped(pTHX_ PerlIO *f) 4254 { 4255 const IV code = PerlIOBase_popped(aTHX_ f); 4256 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4257 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 4258 Safefree(b->buf); 4259 } 4260 b->ptr = b->end = b->buf = NULL; 4261 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4262 return code; 4263 } 4264 4265 IV 4266 PerlIOBuf_close(pTHX_ PerlIO *f) 4267 { 4268 const IV code = PerlIOBase_close(aTHX_ f); 4269 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4270 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 4271 Safefree(b->buf); 4272 } 4273 b->ptr = b->end = b->buf = NULL; 4274 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4275 return code; 4276 } 4277 4278 STDCHAR * 4279 PerlIOBuf_get_ptr(pTHX_ PerlIO *f) 4280 { 4281 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4282 if (!b->buf) 4283 PerlIO_get_base(f); 4284 return b->ptr; 4285 } 4286 4287 SSize_t 4288 PerlIOBuf_get_cnt(pTHX_ PerlIO *f) 4289 { 4290 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4291 if (!b->buf) 4292 PerlIO_get_base(f); 4293 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) 4294 return (b->end - b->ptr); 4295 return 0; 4296 } 4297 4298 STDCHAR * 4299 PerlIOBuf_get_base(pTHX_ PerlIO *f) 4300 { 4301 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4302 PERL_UNUSED_CONTEXT; 4303 4304 if (!b->buf) { 4305 if (!b->bufsiz) 4306 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; 4307 Newx(b->buf,b->bufsiz, STDCHAR); 4308 if (!b->buf) { 4309 b->buf = (STDCHAR *) & b->oneword; 4310 b->bufsiz = sizeof(b->oneword); 4311 } 4312 b->end = b->ptr = b->buf; 4313 } 4314 return b->buf; 4315 } 4316 4317 Size_t 4318 PerlIOBuf_bufsiz(pTHX_ PerlIO *f) 4319 { 4320 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4321 if (!b->buf) 4322 PerlIO_get_base(f); 4323 return (b->end - b->buf); 4324 } 4325 4326 void 4327 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 4328 { 4329 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4330 #ifndef DEBUGGING 4331 PERL_UNUSED_ARG(cnt); 4332 #endif 4333 if (!b->buf) 4334 PerlIO_get_base(f); 4335 b->ptr = ptr; 4336 assert(PerlIO_get_cnt(f) == cnt); 4337 assert(b->ptr >= b->buf); 4338 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4339 } 4340 4341 PerlIO * 4342 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 4343 { 4344 return PerlIOBase_dup(aTHX_ f, o, param, flags); 4345 } 4346 4347 4348 4349 PERLIO_FUNCS_DECL(PerlIO_perlio) = { 4350 sizeof(PerlIO_funcs), 4351 "perlio", 4352 sizeof(PerlIOBuf), 4353 PERLIO_K_BUFFERED|PERLIO_K_RAW, 4354 PerlIOBuf_pushed, 4355 PerlIOBuf_popped, 4356 PerlIOBuf_open, 4357 PerlIOBase_binmode, /* binmode */ 4358 NULL, 4359 PerlIOBase_fileno, 4360 PerlIOBuf_dup, 4361 PerlIOBuf_read, 4362 PerlIOBuf_unread, 4363 PerlIOBuf_write, 4364 PerlIOBuf_seek, 4365 PerlIOBuf_tell, 4366 PerlIOBuf_close, 4367 PerlIOBuf_flush, 4368 PerlIOBuf_fill, 4369 PerlIOBase_eof, 4370 PerlIOBase_error, 4371 PerlIOBase_clearerr, 4372 PerlIOBase_setlinebuf, 4373 PerlIOBuf_get_base, 4374 PerlIOBuf_bufsiz, 4375 PerlIOBuf_get_ptr, 4376 PerlIOBuf_get_cnt, 4377 PerlIOBuf_set_ptrcnt, 4378 }; 4379 4380 /*--------------------------------------------------------------------------------------*/ 4381 /* 4382 * Temp layer to hold unread chars when cannot do it any other way 4383 */ 4384 4385 IV 4386 PerlIOPending_fill(pTHX_ PerlIO *f) 4387 { 4388 /* 4389 * Should never happen 4390 */ 4391 PerlIO_flush(f); 4392 return 0; 4393 } 4394 4395 IV 4396 PerlIOPending_close(pTHX_ PerlIO *f) 4397 { 4398 /* 4399 * A tad tricky - flush pops us, then we close new top 4400 */ 4401 PerlIO_flush(f); 4402 return PerlIO_close(f); 4403 } 4404 4405 IV 4406 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 4407 { 4408 /* 4409 * A tad tricky - flush pops us, then we seek new top 4410 */ 4411 PerlIO_flush(f); 4412 return PerlIO_seek(f, offset, whence); 4413 } 4414 4415 4416 IV 4417 PerlIOPending_flush(pTHX_ PerlIO *f) 4418 { 4419 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4420 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 4421 Safefree(b->buf); 4422 b->buf = NULL; 4423 } 4424 PerlIO_pop(aTHX_ f); 4425 return 0; 4426 } 4427 4428 void 4429 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 4430 { 4431 if (cnt <= 0) { 4432 PerlIO_flush(f); 4433 } 4434 else { 4435 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); 4436 } 4437 } 4438 4439 IV 4440 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 4441 { 4442 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 4443 PerlIOl * const l = PerlIOBase(f); 4444 /* 4445 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets() 4446 * etc. get muddled when it changes mid-string when we auto-pop. 4447 */ 4448 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) | 4449 (PerlIOBase(PerlIONext(f))-> 4450 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); 4451 return code; 4452 } 4453 4454 SSize_t 4455 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 4456 { 4457 SSize_t avail = PerlIO_get_cnt(f); 4458 SSize_t got = 0; 4459 if ((SSize_t) count >= 0 && (SSize_t)count < avail) 4460 avail = count; 4461 if (avail > 0) 4462 got = PerlIOBuf_read(aTHX_ f, vbuf, avail); 4463 if (got >= 0 && got < (SSize_t)count) { 4464 const SSize_t more = 4465 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); 4466 if (more >= 0 || got == 0) 4467 got += more; 4468 } 4469 return got; 4470 } 4471 4472 PERLIO_FUNCS_DECL(PerlIO_pending) = { 4473 sizeof(PerlIO_funcs), 4474 "pending", 4475 sizeof(PerlIOBuf), 4476 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */ 4477 PerlIOPending_pushed, 4478 PerlIOBuf_popped, 4479 NULL, 4480 PerlIOBase_binmode, /* binmode */ 4481 NULL, 4482 PerlIOBase_fileno, 4483 PerlIOBuf_dup, 4484 PerlIOPending_read, 4485 PerlIOBuf_unread, 4486 PerlIOBuf_write, 4487 PerlIOPending_seek, 4488 PerlIOBuf_tell, 4489 PerlIOPending_close, 4490 PerlIOPending_flush, 4491 PerlIOPending_fill, 4492 PerlIOBase_eof, 4493 PerlIOBase_error, 4494 PerlIOBase_clearerr, 4495 PerlIOBase_setlinebuf, 4496 PerlIOBuf_get_base, 4497 PerlIOBuf_bufsiz, 4498 PerlIOBuf_get_ptr, 4499 PerlIOBuf_get_cnt, 4500 PerlIOPending_set_ptrcnt, 4501 }; 4502 4503 4504 4505 /*--------------------------------------------------------------------------------------*/ 4506 /* 4507 * crlf - translation On read translate CR,LF to "\n" we do this by 4508 * overriding ptr/cnt entries to hand back a line at a time and keeping a 4509 * record of which nl we "lied" about. On write translate "\n" to CR,LF 4510 * 4511 * c->nl points on the first byte of CR LF pair when it is temporarily 4512 * replaced by LF, or to the last CR of the buffer. In the former case 4513 * the caller thinks that the buffer ends at c->nl + 1, in the latter 4514 * that it ends at c->nl; these two cases can be distinguished by 4515 * *c->nl. c->nl is set during _getcnt() call, and unset during 4516 * _unread() and _flush() calls. 4517 * It only matters for read operations. 4518 */ 4519 4520 typedef struct { 4521 PerlIOBuf base; /* PerlIOBuf stuff */ 4522 STDCHAR *nl; /* Position of crlf we "lied" about in the 4523 * buffer */ 4524 } PerlIOCrlf; 4525 4526 /* Inherit the PERLIO_F_UTF8 flag from previous layer. 4527 * Otherwise the :crlf layer would always revert back to 4528 * raw mode. 4529 */ 4530 static void 4531 S_inherit_utf8_flag(PerlIO *f) 4532 { 4533 PerlIO *g = PerlIONext(f); 4534 if (PerlIOValid(g)) { 4535 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { 4536 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 4537 } 4538 } 4539 } 4540 4541 IV 4542 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 4543 { 4544 IV code; 4545 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 4546 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab); 4547 #if 0 4548 DEBUG_i( 4549 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", 4550 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", 4551 PerlIOBase(f)->flags); 4552 ); 4553 #endif 4554 { 4555 /* If the old top layer is a CRLF layer, reactivate it (if 4556 * necessary) and remove this new layer from the stack */ 4557 PerlIO *g = PerlIONext(f); 4558 if (PerlIOValid(g)) { 4559 PerlIOl *b = PerlIOBase(g); 4560 if (b && b->tab == &PerlIO_crlf) { 4561 if (!(b->flags & PERLIO_F_CRLF)) 4562 b->flags |= PERLIO_F_CRLF; 4563 S_inherit_utf8_flag(g); 4564 PerlIO_pop(aTHX_ f); 4565 return code; 4566 } 4567 } 4568 } 4569 S_inherit_utf8_flag(f); 4570 return code; 4571 } 4572 4573 4574 SSize_t 4575 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4576 { 4577 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4578 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */ 4579 *(c->nl) = NATIVE_0xd; 4580 c->nl = NULL; 4581 } 4582 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) 4583 return PerlIOBuf_unread(aTHX_ f, vbuf, count); 4584 else { 4585 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 4586 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 4587 SSize_t unread = 0; 4588 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 4589 PerlIO_flush(f); 4590 if (!b->buf) 4591 PerlIO_get_base(f); 4592 if (b->buf) { 4593 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { 4594 b->end = b->ptr = b->buf + b->bufsiz; 4595 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4596 b->posn -= b->bufsiz; 4597 } 4598 while (count > 0 && b->ptr > b->buf) { 4599 const int ch = *--buf; 4600 if (ch == '\n') { 4601 if (b->ptr - 2 >= b->buf) { 4602 *--(b->ptr) = NATIVE_0xa; 4603 *--(b->ptr) = NATIVE_0xd; 4604 unread++; 4605 count--; 4606 } 4607 else { 4608 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ 4609 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa == 4610 '\r' */ 4611 unread++; 4612 count--; 4613 } 4614 } 4615 else { 4616 *--(b->ptr) = ch; 4617 unread++; 4618 count--; 4619 } 4620 } 4621 } 4622 if (count > 0) 4623 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count); 4624 return unread; 4625 } 4626 } 4627 4628 /* XXXX This code assumes that buffer size >=2, but does not check it... */ 4629 SSize_t 4630 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) 4631 { 4632 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4633 if (!b->buf) 4634 PerlIO_get_base(f); 4635 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 4636 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4637 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { 4638 STDCHAR *nl = (c->nl) ? c->nl : b->ptr; 4639 scan: 4640 while (nl < b->end && *nl != NATIVE_0xd) 4641 nl++; 4642 if (nl < b->end && *nl == NATIVE_0xd) { 4643 test: 4644 if (nl + 1 < b->end) { 4645 if (nl[1] == NATIVE_0xa) { 4646 *nl = '\n'; 4647 c->nl = nl; 4648 } 4649 else { 4650 /* 4651 * Not CR,LF but just CR 4652 */ 4653 nl++; 4654 goto scan; 4655 } 4656 } 4657 else { 4658 /* 4659 * Blast - found CR as last char in buffer 4660 */ 4661 4662 if (b->ptr < nl) { 4663 /* 4664 * They may not care, defer work as long as 4665 * possible 4666 */ 4667 c->nl = nl; 4668 return (nl - b->ptr); 4669 } 4670 else { 4671 int code; 4672 b->ptr++; /* say we have read it as far as 4673 * flush() is concerned */ 4674 b->buf++; /* Leave space in front of buffer */ 4675 /* Note as we have moved buf up flush's 4676 posn += ptr-buf 4677 will naturally make posn point at CR 4678 */ 4679 b->bufsiz--; /* Buffer is thus smaller */ 4680 code = PerlIO_fill(f); /* Fetch some more */ 4681 b->bufsiz++; /* Restore size for next time */ 4682 b->buf--; /* Point at space */ 4683 b->ptr = nl = b->buf; /* Which is what we hand 4684 * off */ 4685 *nl = NATIVE_0xd; /* Fill in the CR */ 4686 if (code == 0) 4687 goto test; /* fill() call worked */ 4688 /* 4689 * CR at EOF - just fall through 4690 */ 4691 /* Should we clear EOF though ??? */ 4692 } 4693 } 4694 } 4695 } 4696 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); 4697 } 4698 return 0; 4699 } 4700 4701 void 4702 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 4703 { 4704 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4705 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4706 if (!b->buf) 4707 PerlIO_get_base(f); 4708 if (!ptr) { 4709 if (c->nl) { 4710 ptr = c->nl + 1; 4711 if (ptr == b->end && *c->nl == NATIVE_0xd) { 4712 /* Deferred CR at end of buffer case - we lied about count */ 4713 ptr--; 4714 } 4715 } 4716 else { 4717 ptr = b->end; 4718 } 4719 ptr -= cnt; 4720 } 4721 else { 4722 NOOP; 4723 #if 0 4724 /* 4725 * Test code - delete when it works ... 4726 */ 4727 IV flags = PerlIOBase(f)->flags; 4728 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; 4729 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { 4730 /* Deferred CR at end of buffer case - we lied about count */ 4731 chk--; 4732 } 4733 chk -= cnt; 4734 4735 if (ptr != chk ) { 4736 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf 4737 " nl=%p e=%p for %d", (void*)ptr, (void*)chk, 4738 flags, c->nl, b->end, cnt); 4739 } 4740 #endif 4741 } 4742 if (c->nl) { 4743 if (ptr > c->nl) { 4744 /* 4745 * They have taken what we lied about 4746 */ 4747 *(c->nl) = NATIVE_0xd; 4748 c->nl = NULL; 4749 ptr++; 4750 } 4751 } 4752 b->ptr = ptr; 4753 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 4754 } 4755 4756 SSize_t 4757 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4758 { 4759 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) 4760 return PerlIOBuf_write(aTHX_ f, vbuf, count); 4761 else { 4762 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); 4763 const STDCHAR *buf = (const STDCHAR *) vbuf; 4764 const STDCHAR * const ebuf = buf + count; 4765 if (!b->buf) 4766 PerlIO_get_base(f); 4767 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) 4768 return 0; 4769 while (buf < ebuf) { 4770 const STDCHAR * const eptr = b->buf + b->bufsiz; 4771 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 4772 while (buf < ebuf && b->ptr < eptr) { 4773 if (*buf == '\n') { 4774 if ((b->ptr + 2) > eptr) { 4775 /* 4776 * Not room for both 4777 */ 4778 PerlIO_flush(f); 4779 break; 4780 } 4781 else { 4782 *(b->ptr)++ = NATIVE_0xd; /* CR */ 4783 *(b->ptr)++ = NATIVE_0xa; /* LF */ 4784 buf++; 4785 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 4786 PerlIO_flush(f); 4787 break; 4788 } 4789 } 4790 } 4791 else { 4792 *(b->ptr)++ = *buf++; 4793 } 4794 if (b->ptr >= eptr) { 4795 PerlIO_flush(f); 4796 break; 4797 } 4798 } 4799 } 4800 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 4801 PerlIO_flush(f); 4802 return (buf - (STDCHAR *) vbuf); 4803 } 4804 } 4805 4806 IV 4807 PerlIOCrlf_flush(pTHX_ PerlIO *f) 4808 { 4809 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); 4810 if (c->nl) { 4811 *(c->nl) = NATIVE_0xd; 4812 c->nl = NULL; 4813 } 4814 return PerlIOBuf_flush(aTHX_ f); 4815 } 4816 4817 IV 4818 PerlIOCrlf_binmode(pTHX_ PerlIO *f) 4819 { 4820 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { 4821 /* In text mode - flush any pending stuff and flip it */ 4822 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; 4823 #ifndef PERLIO_USING_CRLF 4824 /* CRLF is unusual case - if this is just the :crlf layer pop it */ 4825 PerlIO_pop(aTHX_ f); 4826 #endif 4827 } 4828 return PerlIOBase_binmode(aTHX_ f); 4829 } 4830 4831 PERLIO_FUNCS_DECL(PerlIO_crlf) = { 4832 sizeof(PerlIO_funcs), 4833 "crlf", 4834 sizeof(PerlIOCrlf), 4835 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW, 4836 PerlIOCrlf_pushed, 4837 PerlIOBuf_popped, /* popped */ 4838 PerlIOBuf_open, 4839 PerlIOCrlf_binmode, /* binmode */ 4840 NULL, 4841 PerlIOBase_fileno, 4842 PerlIOBuf_dup, 4843 PerlIOBuf_read, /* generic read works with ptr/cnt lies */ 4844 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ 4845 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ 4846 PerlIOBuf_seek, 4847 PerlIOBuf_tell, 4848 PerlIOBuf_close, 4849 PerlIOCrlf_flush, 4850 PerlIOBuf_fill, 4851 PerlIOBase_eof, 4852 PerlIOBase_error, 4853 PerlIOBase_clearerr, 4854 PerlIOBase_setlinebuf, 4855 PerlIOBuf_get_base, 4856 PerlIOBuf_bufsiz, 4857 PerlIOBuf_get_ptr, 4858 PerlIOCrlf_get_cnt, 4859 PerlIOCrlf_set_ptrcnt, 4860 }; 4861 4862 PerlIO * 4863 Perl_PerlIO_stdin(pTHX) 4864 { 4865 if (!PL_perlio) { 4866 PerlIO_stdstreams(aTHX); 4867 } 4868 return (PerlIO*)&PL_perlio[1]; 4869 } 4870 4871 PerlIO * 4872 Perl_PerlIO_stdout(pTHX) 4873 { 4874 if (!PL_perlio) { 4875 PerlIO_stdstreams(aTHX); 4876 } 4877 return (PerlIO*)&PL_perlio[2]; 4878 } 4879 4880 PerlIO * 4881 Perl_PerlIO_stderr(pTHX) 4882 { 4883 if (!PL_perlio) { 4884 PerlIO_stdstreams(aTHX); 4885 } 4886 return (PerlIO*)&PL_perlio[3]; 4887 } 4888 4889 /*--------------------------------------------------------------------------------------*/ 4890 4891 char * 4892 PerlIO_getname(PerlIO *f, char *buf) 4893 { 4894 #ifdef VMS 4895 dTHX; 4896 char *name = NULL; 4897 bool exported = FALSE; 4898 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 4899 if (!stdio) { 4900 stdio = PerlIO_exportFILE(f,0); 4901 exported = TRUE; 4902 } 4903 if (stdio) { 4904 name = fgetname(stdio, buf); 4905 if (exported) PerlIO_releaseFILE(f,stdio); 4906 } 4907 return name; 4908 #else 4909 PERL_UNUSED_ARG(f); 4910 PERL_UNUSED_ARG(buf); 4911 Perl_croak_nocontext("Don't know how to get file name"); 4912 return NULL; 4913 #endif 4914 } 4915 4916 4917 /*--------------------------------------------------------------------------------------*/ 4918 /* 4919 * Functions which can be called on any kind of PerlIO implemented in 4920 * terms of above 4921 */ 4922 4923 #undef PerlIO_fdopen 4924 PerlIO * 4925 PerlIO_fdopen(int fd, const char *mode) 4926 { 4927 dTHX; 4928 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL); 4929 } 4930 4931 #undef PerlIO_open 4932 PerlIO * 4933 PerlIO_open(const char *path, const char *mode) 4934 { 4935 dTHX; 4936 SV *name = sv_2mortal(newSVpv(path, 0)); 4937 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name); 4938 } 4939 4940 #undef Perlio_reopen 4941 PerlIO * 4942 PerlIO_reopen(const char *path, const char *mode, PerlIO *f) 4943 { 4944 dTHX; 4945 SV *name = sv_2mortal(newSVpv(path,0)); 4946 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name); 4947 } 4948 4949 #undef PerlIO_getc 4950 int 4951 PerlIO_getc(PerlIO *f) 4952 { 4953 dTHX; 4954 STDCHAR buf[1]; 4955 if ( 1 == PerlIO_read(f, buf, 1) ) { 4956 return (unsigned char) buf[0]; 4957 } 4958 return EOF; 4959 } 4960 4961 #undef PerlIO_ungetc 4962 int 4963 PerlIO_ungetc(PerlIO *f, int ch) 4964 { 4965 dTHX; 4966 if (ch != EOF) { 4967 STDCHAR buf = ch; 4968 if (PerlIO_unread(f, &buf, 1) == 1) 4969 return ch; 4970 } 4971 return EOF; 4972 } 4973 4974 #undef PerlIO_putc 4975 int 4976 PerlIO_putc(PerlIO *f, int ch) 4977 { 4978 dTHX; 4979 STDCHAR buf = ch; 4980 return PerlIO_write(f, &buf, 1); 4981 } 4982 4983 #undef PerlIO_puts 4984 int 4985 PerlIO_puts(PerlIO *f, const char *s) 4986 { 4987 dTHX; 4988 return PerlIO_write(f, s, strlen(s)); 4989 } 4990 4991 #undef PerlIO_rewind 4992 void 4993 PerlIO_rewind(PerlIO *f) 4994 { 4995 dTHX; 4996 PerlIO_seek(f, (Off_t) 0, SEEK_SET); 4997 PerlIO_clearerr(f); 4998 } 4999 5000 #undef PerlIO_vprintf 5001 int 5002 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) 5003 { 5004 dTHX; 5005 SV * sv; 5006 const char *s; 5007 STRLEN len; 5008 SSize_t wrote; 5009 #ifdef NEED_VA_COPY 5010 va_list apc; 5011 Perl_va_copy(ap, apc); 5012 sv = vnewSVpvf(fmt, &apc); 5013 va_end(apc); 5014 #else 5015 sv = vnewSVpvf(fmt, &ap); 5016 #endif 5017 s = SvPV_const(sv, len); 5018 wrote = PerlIO_write(f, s, len); 5019 SvREFCNT_dec(sv); 5020 return wrote; 5021 } 5022 5023 #undef PerlIO_printf 5024 int 5025 PerlIO_printf(PerlIO *f, const char *fmt, ...) 5026 { 5027 va_list ap; 5028 int result; 5029 va_start(ap, fmt); 5030 result = PerlIO_vprintf(f, fmt, ap); 5031 va_end(ap); 5032 return result; 5033 } 5034 5035 #undef PerlIO_stdoutf 5036 int 5037 PerlIO_stdoutf(const char *fmt, ...) 5038 { 5039 dTHX; 5040 va_list ap; 5041 int result; 5042 va_start(ap, fmt); 5043 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap); 5044 va_end(ap); 5045 return result; 5046 } 5047 5048 #undef PerlIO_tmpfile 5049 PerlIO * 5050 PerlIO_tmpfile(void) 5051 { 5052 #ifndef WIN32 5053 dTHX; 5054 #endif 5055 PerlIO *f = NULL; 5056 #ifdef WIN32 5057 const int fd = win32_tmpfd(); 5058 if (fd >= 0) 5059 f = PerlIO_fdopen(fd, "w+b"); 5060 #elif ! defined(VMS) && ! defined(OS2) 5061 int fd = -1; 5062 char tempname[] = "/tmp/PerlIO_XXXXXX"; 5063 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR"); 5064 SV * sv = NULL; 5065 int old_umask = umask(0177); 5066 if (tmpdir && *tmpdir) { 5067 /* if TMPDIR is set and not empty, we try that first */ 5068 sv = newSVpv(tmpdir, 0); 5069 sv_catpv(sv, tempname + 4); 5070 fd = Perl_my_mkstemp_cloexec(SvPVX(sv)); 5071 } 5072 if (fd < 0) { 5073 SvREFCNT_dec(sv); 5074 sv = NULL; 5075 /* else we try /tmp */ 5076 fd = Perl_my_mkstemp_cloexec(tempname); 5077 } 5078 if (fd < 0) { 5079 /* Try cwd */ 5080 sv = newSVpvs("."); 5081 sv_catpv(sv, tempname + 4); 5082 fd = Perl_my_mkstemp_cloexec(SvPVX(sv)); 5083 } 5084 umask(old_umask); 5085 if (fd >= 0) { 5086 f = PerlIO_fdopen(fd, "w+"); 5087 if (f) 5088 PerlIOBase(f)->flags |= PERLIO_F_TEMP; 5089 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); 5090 } 5091 SvREFCNT_dec(sv); 5092 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ 5093 FILE * const stdio = PerlSIO_tmpfile(); 5094 5095 if (stdio) 5096 f = PerlIO_fdopen(fileno(stdio), "w+"); 5097 5098 #endif /* else WIN32 */ 5099 return f; 5100 } 5101 5102 void 5103 Perl_PerlIO_save_errno(pTHX_ PerlIO *f) 5104 { 5105 PERL_UNUSED_CONTEXT; 5106 if (!PerlIOValid(f)) 5107 return; 5108 PerlIOBase(f)->err = errno; 5109 #ifdef VMS 5110 PerlIOBase(f)->os_err = vaxc$errno; 5111 #elif defined(OS2) 5112 PerlIOBase(f)->os_err = Perl_rc; 5113 #elif defined(WIN32) 5114 PerlIOBase(f)->os_err = GetLastError(); 5115 #endif 5116 } 5117 5118 void 5119 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f) 5120 { 5121 PERL_UNUSED_CONTEXT; 5122 if (!PerlIOValid(f)) 5123 return; 5124 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err); 5125 #ifdef OS2 5126 Perl_rc = PerlIOBase(f)->os_err); 5127 #elif defined(WIN32) 5128 SetLastError(PerlIOBase(f)->os_err); 5129 #endif 5130 } 5131 5132 #undef HAS_FSETPOS 5133 #undef HAS_FGETPOS 5134 5135 5136 /*======================================================================================*/ 5137 /* 5138 * Now some functions in terms of above which may be needed even if we are 5139 * not in true PerlIO mode 5140 */ 5141 const char * 5142 Perl_PerlIO_context_layers(pTHX_ const char *mode) 5143 { 5144 const char *direction = NULL; 5145 SV *layers; 5146 /* 5147 * Need to supply default layer info from open.pm 5148 */ 5149 5150 if (!PL_curcop) 5151 return NULL; 5152 5153 if (mode && mode[0] != 'r') { 5154 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) 5155 direction = "open>"; 5156 } else { 5157 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) 5158 direction = "open<"; 5159 } 5160 if (!direction) 5161 return NULL; 5162 5163 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); 5164 5165 assert(layers); 5166 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL; 5167 } 5168 5169 5170 #ifndef HAS_FSETPOS 5171 #undef PerlIO_setpos 5172 int 5173 PerlIO_setpos(PerlIO *f, SV *pos) 5174 { 5175 if (SvOK(pos)) { 5176 if (f) { 5177 dTHX; 5178 STRLEN len; 5179 const Off_t * const posn = (Off_t *) SvPV(pos, len); 5180 if(len == sizeof(Off_t)) 5181 return PerlIO_seek(f, *posn, SEEK_SET); 5182 } 5183 } 5184 SETERRNO(EINVAL, SS_IVCHAN); 5185 return -1; 5186 } 5187 #else 5188 #undef PerlIO_setpos 5189 int 5190 PerlIO_setpos(PerlIO *f, SV *pos) 5191 { 5192 if (SvOK(pos)) { 5193 if (f) { 5194 dTHX; 5195 STRLEN len; 5196 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); 5197 if(len == sizeof(Fpos_t)) 5198 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 5199 return fsetpos64(f, fpos); 5200 #else 5201 return fsetpos(f, fpos); 5202 #endif 5203 } 5204 } 5205 SETERRNO(EINVAL, SS_IVCHAN); 5206 return -1; 5207 } 5208 #endif 5209 5210 #ifndef HAS_FGETPOS 5211 #undef PerlIO_getpos 5212 int 5213 PerlIO_getpos(PerlIO *f, SV *pos) 5214 { 5215 dTHX; 5216 Off_t posn = PerlIO_tell(f); 5217 sv_setpvn(pos, (char *) &posn, sizeof(posn)); 5218 return (posn == (Off_t) - 1) ? -1 : 0; 5219 } 5220 #else 5221 #undef PerlIO_getpos 5222 int 5223 PerlIO_getpos(PerlIO *f, SV *pos) 5224 { 5225 dTHX; 5226 Fpos_t fpos; 5227 int code; 5228 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 5229 code = fgetpos64(f, &fpos); 5230 #else 5231 code = fgetpos(f, &fpos); 5232 #endif 5233 sv_setpvn(pos, (char *) &fpos, sizeof(fpos)); 5234 return code; 5235 } 5236 #endif 5237 5238 /* print a failure format string message to stderr and fail exit the process 5239 using only libc without depending on any perl data structures being 5240 initialized. 5241 */ 5242 5243 void 5244 Perl_noperl_die(const char* pat, ...) 5245 { 5246 va_list arglist; 5247 PERL_ARGS_ASSERT_NOPERL_DIE; 5248 va_start(arglist, pat); 5249 vfprintf(stderr, pat, arglist); 5250 va_end(arglist); 5251 exit(1); 5252 } 5253 5254 /* 5255 * ex: set ts=8 sts=4 sw=4 et: 5256 */ 5257