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