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