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