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