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