1 /* 2 * perlio.c Copyright (c) 1996-2005, Nick Ing-Simmons You may distribute 3 * under the terms of either the GNU General Public License or the 4 * Artistic License, as specified in the README file. 5 */ 6 7 /* 8 * Hour after hour for nearly three weary days he had jogged up and down, 9 * over passes, and through long dales, and across many streams. 10 */ 11 12 /* This file contains the functions needed to implement PerlIO, which 13 * is Perl's private replacement for the C stdio library. This is used 14 * by default unless you compile with -Uuseperlio or run with 15 * PERLIO=:stdio (but don't do this unless you know what you're doing) 16 */ 17 18 /* 19 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get 20 * at the dispatch tables, even when we do not need it for other reasons. 21 * Invent a dSYS macro to abstract this out 22 */ 23 #ifdef PERL_IMPLICIT_SYS 24 #define dSYS dTHX 25 #else 26 #define dSYS dNOOP 27 #endif 28 29 #define VOIDUSED 1 30 #ifdef PERL_MICRO 31 # include "uconfig.h" 32 #else 33 # include "config.h" 34 #endif 35 36 #define PERLIO_NOT_STDIO 0 37 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) 38 /* 39 * #define PerlIO FILE 40 */ 41 #endif 42 /* 43 * This file provides those parts of PerlIO abstraction 44 * which are not #defined in perlio.h. 45 * Which these are depends on various Configure #ifdef's 46 */ 47 48 #include "EXTERN.h" 49 #define PERL_IN_PERLIO_C 50 #include "perl.h" 51 52 #ifdef PERL_IMPLICIT_CONTEXT 53 #undef dSYS 54 #define dSYS dTHX 55 #endif 56 57 #include "XSUB.h" 58 59 #define PERLIO_MAX_REFCOUNTABLE_FD 2048 60 61 #ifdef __Lynx__ 62 /* Missing proto on LynxOS */ 63 int mkstemp(char*); 64 #endif 65 66 /* Call the callback or PerlIOBase, and return failure. */ 67 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ 68 if (PerlIOValid(f)) { \ 69 const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ 70 if (tab && tab->callback) \ 71 return (*tab->callback) args; \ 72 else \ 73 return PerlIOBase_ ## base args; \ 74 } \ 75 else \ 76 SETERRNO(EBADF, SS_IVCHAN); \ 77 return failure 78 79 /* Call the callback or fail, and return failure. */ 80 #define Perl_PerlIO_or_fail(f, callback, failure, args) \ 81 if (PerlIOValid(f)) { \ 82 const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ 83 if (tab && tab->callback) \ 84 return (*tab->callback) args; \ 85 SETERRNO(EINVAL, LIB_INVARG); \ 86 } \ 87 else \ 88 SETERRNO(EBADF, SS_IVCHAN); \ 89 return failure 90 91 /* Call the callback or PerlIOBase, and be void. */ 92 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \ 93 if (PerlIOValid(f)) { \ 94 const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ 95 if (tab && tab->callback) \ 96 (*tab->callback) args; \ 97 else \ 98 PerlIOBase_ ## base args; \ 99 } \ 100 else \ 101 SETERRNO(EBADF, SS_IVCHAN) 102 103 /* Call the callback or fail, and be void. */ 104 #define Perl_PerlIO_or_fail_void(f, callback, args) \ 105 if (PerlIOValid(f)) { \ 106 const PerlIO_funcs *tab = PerlIOBase(f)->tab; \ 107 if (tab && tab->callback) \ 108 (*tab->callback) args; \ 109 else \ 110 SETERRNO(EINVAL, LIB_INVARG); \ 111 } \ 112 else \ 113 SETERRNO(EBADF, SS_IVCHAN) 114 115 #ifndef USE_SFIO 116 int 117 perlsio_binmode(FILE *fp, int iotype, int mode) 118 ###### { 119 /* 120 * This used to be contents of do_binmode in doio.c 121 */ 122 #ifdef DOSISH 123 # if defined(atarist) || defined(__MINT__) 124 if (!fflush(fp)) { 125 if (mode & O_BINARY) 126 ((FILE *) fp)->_flag |= _IOBIN; 127 else 128 ((FILE *) fp)->_flag &= ~_IOBIN; 129 return 1; 130 } 131 return 0; 132 # else 133 dTHX; 134 #ifdef NETWARE 135 if (PerlLIO_setmode(fp, mode) != -1) { 136 #else 137 if (PerlLIO_setmode(fileno(fp), mode) != -1) { 138 #endif 139 # if defined(WIN32) && defined(__BORLANDC__) 140 /* 141 * The translation mode of the stream is maintained independent of 142 * the translation mode of the fd in the Borland RTL (heavy 143 * digging through their runtime sources reveal). User has to set 144 * the mode explicitly for the stream (though they don't document 145 * this anywhere). GSAR 97-5-24 146 */ 147 fseek(fp, 0L, 0); 148 if (mode & O_BINARY) 149 fp->flags |= _F_BIN; 150 else 151 fp->flags &= ~_F_BIN; 152 # endif 153 return 1; 154 } 155 else 156 return 0; 157 # endif 158 #else 159 # if defined(USEMYBINMODE) 160 dTHX; 161 if (my_binmode(fp, iotype, mode) != FALSE) 162 return 1; 163 else 164 return 0; 165 # else 166 ###### PERL_UNUSED_ARG(fp); 167 ###### PERL_UNUSED_ARG(iotype); 168 ###### PERL_UNUSED_ARG(mode); 169 ###### return 1; 170 # endif 171 #endif 172 } 173 #endif /* sfio */ 174 175 #ifndef O_ACCMODE 176 #define O_ACCMODE 3 /* Assume traditional implementation */ 177 #endif 178 179 int 180 PerlIO_intmode2str(int rawmode, char *mode, int *writing) 181 3053 { 182 3053 const int result = rawmode & O_ACCMODE; 183 3053 int ix = 0; 184 3053 int ptype; 185 3053 switch (result) { 186 case O_RDONLY: 187 28 ptype = IoTYPE_RDONLY; 188 28 break; 189 case O_WRONLY: 190 20 ptype = IoTYPE_WRONLY; 191 20 break; 192 case O_RDWR: 193 default: 194 3005 ptype = IoTYPE_RDWR; 195 3053 break; 196 } 197 3053 if (writing) 198 3053 *writing = (result != O_RDONLY); 199 200 3053 if (result == O_RDONLY) { 201 28 mode[ix++] = 'r'; 202 } 203 #ifdef O_APPEND 204 3025 else if (rawmode & O_APPEND) { 205 ###### mode[ix++] = 'a'; 206 ###### if (result != O_WRONLY) 207 ###### mode[ix++] = '+'; 208 } 209 #endif 210 else { 211 3025 if (result == O_WRONLY) 212 20 mode[ix++] = 'w'; 213 else { 214 3005 mode[ix++] = 'r'; 215 3005 mode[ix++] = '+'; 216 } 217 } 218 3053 if (rawmode & O_BINARY) 219 3053 mode[ix++] = 'b'; 220 3053 mode[ix] = '\0'; 221 3053 return ptype; 222 } 223 224 #ifndef PERLIO_LAYERS 225 int 226 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 227 { 228 if (!names || !*names 229 || strEQ(names, ":crlf") 230 || strEQ(names, ":raw") 231 || strEQ(names, ":bytes") 232 ) { 233 return 0; 234 } 235 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names); 236 /* 237 * NOTREACHED 238 */ 239 return -1; 240 } 241 242 void 243 PerlIO_destruct(pTHX) 244 { 245 } 246 247 int 248 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) 249 { 250 #ifdef USE_SFIO 251 PERL_UNUSED_ARG(iotype); 252 PERL_UNUSED_ARG(mode); 253 PERL_UNUSED_ARG(names); 254 return 1; 255 #else 256 return perlsio_binmode(fp, iotype, mode); 257 #endif 258 } 259 260 PerlIO * 261 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 262 { 263 #if defined(PERL_MICRO) || defined(SYMBIAN) 264 return NULL; 265 #else 266 #ifdef PERL_IMPLICIT_SYS 267 return PerlSIO_fdupopen(f); 268 #else 269 #ifdef WIN32 270 return win32_fdupopen(f); 271 #else 272 if (f) { 273 const int fd = PerlLIO_dup(PerlIO_fileno(f)); 274 if (fd >= 0) { 275 char mode[8]; 276 int omode = fcntl(fd, F_GETFL); 277 #ifdef DJGPP 278 omode = djgpp_get_stream_mode(f); 279 #endif 280 PerlIO_intmode2str(omode,mode,NULL); 281 /* the r+ is a hack */ 282 return PerlIO_fdopen(fd, mode); 283 } 284 return NULL; 285 } 286 else { 287 SETERRNO(EBADF, SS_IVCHAN); 288 } 289 #endif 290 return NULL; 291 #endif 292 #endif 293 } 294 295 296 /* 297 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries 298 */ 299 300 PerlIO * 301 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 302 int imode, int perm, PerlIO *old, int narg, SV **args) 303 { 304 if (narg) { 305 if (narg > 1) { 306 Perl_croak(aTHX_ "More than one argument to open"); 307 } 308 if (*args == &PL_sv_undef) 309 return PerlIO_tmpfile(); 310 else { 311 const char *name = SvPV_nolen_const(*args); 312 if (*mode == IoTYPE_NUMERIC) { 313 fd = PerlLIO_open3(name, imode, perm); 314 if (fd >= 0) 315 return PerlIO_fdopen(fd, mode + 1); 316 } 317 else if (old) { 318 return PerlIO_reopen(name, mode, old); 319 } 320 else { 321 return PerlIO_open(name, mode); 322 } 323 } 324 } 325 else { 326 return PerlIO_fdopen(fd, (char *) mode); 327 } 328 return NULL; 329 } 330 331 XS(XS_PerlIO__Layer__find) 332 { 333 dXSARGS; 334 if (items < 2) 335 Perl_croak(aTHX_ "Usage class->find(name[,load])"); 336 else { 337 const char *name = SvPV_nolen_const(ST(1)); 338 ST(0) = (strEQ(name, "crlf") 339 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; 340 XSRETURN(1); 341 } 342 } 343 344 345 void 346 Perl_boot_core_PerlIO(pTHX) 347 { 348 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 349 } 350 351 #endif 352 353 354 #ifdef PERLIO_IS_STDIO 355 356 void 357 PerlIO_init(pTHX) 358 { 359 /* 360 * Does nothing (yet) except force this file to be included in perl 361 * binary. That allows this file to force inclusion of other functions 362 * that may be required by loadable extensions e.g. for 363 * FileHandle::tmpfile 364 */ 365 } 366 367 #undef PerlIO_tmpfile 368 PerlIO * 369 PerlIO_tmpfile(void) 370 { 371 return tmpfile(); 372 } 373 374 #else /* PERLIO_IS_STDIO */ 375 376 #ifdef USE_SFIO 377 378 #undef HAS_FSETPOS 379 #undef HAS_FGETPOS 380 381 /* 382 * This section is just to make sure these functions get pulled in from 383 * libsfio.a 384 */ 385 386 #undef PerlIO_tmpfile 387 PerlIO * 388 PerlIO_tmpfile(void) 389 { 390 return sftmp(0); 391 } 392 393 void 394 PerlIO_init(pTHX) 395 { 396 /* 397 * Force this file to be included in perl binary. Which allows this 398 * file to force inclusion of other functions that may be required by 399 * loadable extensions e.g. for FileHandle::tmpfile 400 */ 401 402 /* 403 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush 404 * results in a lot of lseek()s to regular files and lot of small 405 * writes to pipes. 406 */ 407 sfset(sfstdout, SF_SHARE, 0); 408 } 409 410 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */ 411 PerlIO * 412 PerlIO_importFILE(FILE *stdio, const char *mode) 413 { 414 const int fd = fileno(stdio); 415 if (!mode || !*mode) { 416 mode = "r+"; 417 } 418 return PerlIO_fdopen(fd, mode); 419 } 420 421 FILE * 422 PerlIO_findFILE(PerlIO *pio) 423 { 424 const int fd = PerlIO_fileno(pio); 425 FILE * const f = fdopen(fd, "r+"); 426 PerlIO_flush(pio); 427 if (!f && errno == EINVAL) 428 f = fdopen(fd, "w"); 429 if (!f && errno == EINVAL) 430 f = fdopen(fd, "r"); 431 return f; 432 } 433 434 435 #else /* USE_SFIO */ 436 /*======================================================================================*/ 437 /* 438 * Implement all the PerlIO interface ourselves. 439 */ 440 441 #include "perliol.h" 442 443 /* 444 * We _MUST_ have if we are using lseek() and may have large 445 * files 446 */ 447 #ifdef I_UNISTD 448 #include 449 #endif 450 #ifdef HAS_MMAP 451 #include 452 #endif 453 454 void 455 PerlIO_debug(const char *fmt, ...) 456 931103 { 457 931103 va_list ap; 458 dSYS; 459 931103 va_start(ap, fmt); 460 931103 if (!PL_perlio_debug_fd && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { 461 4459 const char *s = PerlEnv_getenv("PERLIO_DEBUG"); 462 4459 if (s && *s) 463 ###### PL_perlio_debug_fd = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); 464 else 465 4459 PL_perlio_debug_fd = -1; 466 } 467 931103 if (PL_perlio_debug_fd > 0) { 468 dTHX; 469 ###### const char *s = CopFILE(PL_curcop); 470 ###### STRLEN len; 471 #ifdef USE_ITHREADS 472 /* Use fixed buffer as sv_catpvf etc. needs SVs */ 473 char buffer[1024]; 474 if (!s) 475 s = "(none)"; 476 len = sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); 477 vsprintf(buffer+len, fmt, ap); 478 PerlLIO_write(PL_perlio_debug_fd, buffer, strlen(buffer)); 479 #else 480 ###### SV *sv = newSVpvn("", 0); 481 ###### if (!s) 482 ###### s = "(none)"; 483 ###### Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s, 484 (IV) CopLINE(PL_curcop)); 485 ###### Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); 486 487 ###### s = SvPV_const(sv, len); 488 ###### PerlLIO_write(PL_perlio_debug_fd, s, len); 489 ###### SvREFCNT_dec(sv); 490 #endif 491 } 492 931103 va_end(ap); 493 } 494 495 /*--------------------------------------------------------------------------------------*/ 496 497 /* 498 * Inner level routines 499 */ 500 501 /* 502 * Table of pointers to the PerlIO structs (malloc'ed) 503 */ 504 #define PERLIO_TABLE_SIZE 64 505 506 PerlIO * 507 PerlIO_allocate(pTHX) 508 83232 { 509 /* 510 * Find a free slot in the table, allocating new table as necessary 511 */ 512 83232 PerlIO **last; 513 83232 PerlIO *f; 514 83232 last = &PL_perlio; 515 83232 while ((f = *last)) { 516 78729 int i; 517 78729 last = (PerlIO **) (f); 518 363193 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 519 363193 if (!*++f) { 520 78729 return f; 521 } 522 } 523 } 524 4503 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO); 525 4503 if (!f) { 526 ###### return NULL; 527 } 528 4503 *last = f; 529 4503 return f + 1; 530 } 531 532 #undef PerlIO_fdupopen 533 PerlIO * 534 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 535 1483 { 536 1483 if (PerlIOValid(f)) { 537 1483 const PerlIO_funcs * const tab = PerlIOBase(f)->tab; 538 1483 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param); 539 1483 if (tab && tab->Dup) 540 1483 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); 541 else { 542 ###### return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); 543 } 544 } 545 else 546 ###### SETERRNO(EBADF, SS_IVCHAN); 547 548 ###### return NULL; 549 } 550 551 void 552 PerlIO_cleantable(pTHX_ PerlIO **tablep) 553 9098 { 554 9098 PerlIO *table = *tablep; 555 9098 if (table) { 556 4549 int i; 557 4549 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0])); 558 291136 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { 559 286587 PerlIO *f = table + i; 560 286587 if (*f) { 561 13671 PerlIO_close(f); 562 } 563 } 564 4549 Safefree(table); 565 4549 *tablep = NULL; 566 } 567 } 568 569 570 PerlIO_list_t * 571 PerlIO_list_alloc(pTHX) 572 11077 { 573 11077 PerlIO_list_t *list; 574 11077 Newz('L', list, 1, PerlIO_list_t); 575 11077 list->refcnt = 1; 576 11077 return list; 577 } 578 579 void 580 PerlIO_list_free(pTHX_ PerlIO_list_t *list) 581 94277 { 582 94277 if (list) { 583 94277 if (--list->refcnt == 0) { 584 11169 if (list->array) { 585 11166 IV i; 586 63628 for (i = 0; i < list->cur; i++) { 587 52462 if (list->array[i].arg) 588 11486 SvREFCNT_dec(list->array[i].arg); 589 } 590 11166 Safefree(list->array); 591 } 592 11169 Safefree(list); 593 } 594 } 595 } 596 597 void 598 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) 599 51956 { 600 51956 PerlIO_pair_t *p; 601 51956 if (list->cur >= list->len) { 602 15577 list->len += 8; 603 15577 if (list->array) 604 4503 Renew(list->array, list->len, PerlIO_pair_t); 605 else 606 11074 New('l', list->array, list->len, PerlIO_pair_t); 607 } 608 51956 p = &(list->array[list->cur++]); 609 51956 p->funcs = funcs; 610 51956 if ((p->arg = arg)) { 611 11394 (void)SvREFCNT_inc(arg); 612 } 613 } 614 615 PerlIO_list_t * 616 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) 617 ###### { 618 ###### PerlIO_list_t *list = (PerlIO_list_t *) NULL; 619 ###### if (proto) { 620 ###### int i; 621 ###### list = PerlIO_list_alloc(aTHX); 622 ###### for (i=0; i < proto->cur; i++) { 623 ###### SV *arg = Nullsv; 624 ###### if (proto->array[i].arg) 625 ###### arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param); 626 ###### PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); 627 } 628 } 629 ###### return list; 630 } 631 632 void 633 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) 634 ###### { 635 #ifdef USE_ITHREADS 636 PerlIO **table = &proto->Iperlio; 637 PerlIO *f; 638 PL_perlio = NULL; 639 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); 640 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); 641 PerlIO_allocate(aTHX); /* root slot is never used */ 642 PerlIO_debug("Clone %p from %p\n",aTHX,proto); 643 while ((f = *table)) { 644 int i; 645 table = (PerlIO **) (f++); 646 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 647 if (*f) { 648 (void) fp_dup(f, 0, param); 649 } 650 f++; 651 } 652 } 653 #else 654 ###### PERL_UNUSED_ARG(proto); 655 ###### PERL_UNUSED_ARG(param); 656 #endif 657 } 658 659 void 660 PerlIO_destruct(pTHX) 661 4549 { 662 4549 PerlIO **table = &PL_perlio; 663 9098 PerlIO *f; 664 #ifdef USE_ITHREADS 665 PerlIO_debug("Destruct %p\n",aTHX); 666 #endif 667 9098 while ((f = *table)) { 668 4549 int i; 669 4549 table = (PerlIO **) (f++); 670 291136 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 671 286587 PerlIO *x = f; 672 316748 PerlIOl *l; 673 316748 while ((l = *x)) { 674 30161 if (l->tab->kind & PERLIO_K_DESTRUCT) { 675 27 PerlIO_debug("Destruct popping %s\n", l->tab->name); 676 27 PerlIO_flush(x); 677 27 PerlIO_pop(aTHX_ x); 678 } 679 else { 680 30134 x = PerlIONext(x); 681 } 682 } 683 286587 f++; 684 } 685 } 686 } 687 688 void 689 PerlIO_pop(pTHX_ PerlIO *f) 690 157094 { 691 157094 PerlIOl *l = *f; 692 157094 if (l) { 693 157094 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name); 694 157094 if (l->tab->Popped) { 695 /* 696 * If popped returns non-zero do not free its layer structure 697 * it has either done so itself, or it is shared and still in 698 * use 699 */ 700 157094 if ((*l->tab->Popped) (aTHX_ f) != 0) 701 ###### return; 702 } 703 157094 *f = l->next; 704 157094 Safefree(l); 705 } 706 } 707 708 /* Return as an array the stack of layers on a filehandle. Note that 709 * the stack is returned top-first in the array, and there are three 710 * times as many array elements as there are layers in the stack: the 711 * first element of a layer triplet is the name, the second one is the 712 * arguments, and the third one is the flags. */ 713 714 AV * 715 PerlIO_get_layers(pTHX_ PerlIO *f) 716 13 { 717 13 AV *av = newAV(); 718 719 13 if (PerlIOValid(f)) { 720 13 PerlIOl *l = PerlIOBase(f); 721 722 47 while (l) { 723 34 SV *name = l->tab && l->tab->name ? 724 34 newSVpv(l->tab->name, 0) : &PL_sv_undef; 725 34 SV *arg = l->tab && l->tab->Getarg ? 726 34 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; 727 34 av_push(av, name); 728 34 av_push(av, arg); 729 34 av_push(av, newSViv((IV)l->flags)); 730 34 l = l->next; 731 } 732 } 733 734 13 return av; 735 } 736 737 /*--------------------------------------------------------------------------------------*/ 738 /* 739 * XS Interface for perl code 740 */ 741 742 PerlIO_funcs * 743 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) 744 11226 { 745 dVAR; 746 11226 IV i; 747 11226 if ((SSize_t) len <= 0) 748 9006 len = strlen(name); 749 36348 for (i = 0; i < PL_known_layers->cur; i++) { 750 36305 PerlIO_funcs *f = PL_known_layers->array[i].funcs; 751 36305 if (memEQ(f->name, name, len) && f->name[len] == 0) { 752 11183 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); 753 11183 return f; 754 } 755 } 756 43 if (load && PL_subname && PL_def_layerlist 757 && PL_def_layerlist->cur >= 2) { 758 33 if (PL_in_load_module) { 759 ###### Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); 760 33 return NULL; 761 } else { 762 33 SV *pkgsv = newSVpvn("PerlIO", 6); 763 33 SV *layer = newSVpvn(name, len); 764 33 CV *cv = get_cv("PerlIO::Layer::NoWarnings", FALSE); 765 33 ENTER; 766 33 SAVEINT(PL_in_load_module); 767 33 if (cv) { 768 33 SAVEGENERICSV(PL_warnhook); 769 33 (void)SvREFCNT_inc(cv); 770 33 PL_warnhook = (SV *) cv; 771 } 772 33 PL_in_load_module++; 773 /* 774 * The two SVs are magically freed by load_module 775 */ 776 33 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv); 777 33 PL_in_load_module--; 778 33 LEAVE; 779 33 return PerlIO_find_layer(aTHX_ name, len, 0); 780 } 781 } 782 10 PerlIO_debug("Cannot find %.*s\n", (int) len, name); 783 10 return NULL; 784 } 785 786 #ifdef USE_ATTRIBUTES_FOR_PERLIO 787 788 static int 789 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) 790 { 791 if (SvROK(sv)) { 792 IO *io = GvIOn((GV *) SvRV(sv)); 793 PerlIO *ifp = IoIFP(io); 794 PerlIO *ofp = IoOFP(io); 795 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp); 796 } 797 return 0; 798 } 799 800 static int 801 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) 802 { 803 if (SvROK(sv)) { 804 IO *io = GvIOn((GV *) SvRV(sv)); 805 PerlIO *ifp = IoIFP(io); 806 PerlIO *ofp = IoOFP(io); 807 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp); 808 } 809 return 0; 810 } 811 812 static int 813 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) 814 { 815 Perl_warn(aTHX_ "clear %" SVf, sv); 816 return 0; 817 } 818 819 static int 820 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) 821 { 822 Perl_warn(aTHX_ "free %" SVf, sv); 823 return 0; 824 } 825 826 MGVTBL perlio_vtab = { 827 perlio_mg_get, 828 perlio_mg_set, 829 NULL, /* len */ 830 perlio_mg_clear, 831 perlio_mg_free 832 }; 833 834 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) 835 { 836 dXSARGS; 837 SV *sv = SvRV(ST(1)); 838 AV *av = newAV(); 839 MAGIC *mg; 840 int count = 0; 841 int i; 842 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0); 843 SvRMAGICAL_off(sv); 844 mg = mg_find(sv, PERL_MAGIC_ext); 845 mg->mg_virtual = &perlio_vtab; 846 mg_magical(sv); 847 Perl_warn(aTHX_ "attrib %" SVf, sv); 848 for (i = 2; i < items; i++) { 849 STRLEN len; 850 const char *name = SvPV_const(ST(i), len); 851 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1); 852 if (layer) { 853 av_push(av, SvREFCNT_inc(layer)); 854 } 855 else { 856 ST(count) = ST(i); 857 count++; 858 } 859 } 860 SvREFCNT_dec(av); 861 XSRETURN(count); 862 } 863 864 #endif /* USE_ATTIBUTES_FOR_PERLIO */ 865 866 SV * 867 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) 868 73 { 869 73 HV *stash = gv_stashpv("PerlIO::Layer", TRUE); 870 73 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash); 871 73 return sv; 872 } 873 874 XS(XS_PerlIO__Layer__NoWarnings) 875 11 { 876 /* This is used as a %SIG{__WARN__} handler to supress warnings 877 during loading of layers. 878 */ 879 11 dXSARGS; 880 11 if (items) 881 11 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))); 882 11 XSRETURN(0); 883 } 884 885 XS(XS_PerlIO__Layer__find) 886 76 { 887 76 dXSARGS; 888 76 if (items < 2) 889 ###### Perl_croak(aTHX_ "Usage class->find(name[,load])"); 890 else { 891 76 STRLEN len; 892 76 const char *name = SvPV_const(ST(1), len); 893 76 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0; 894 76 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load); 895 76 ST(0) = 896 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : 897 &PL_sv_undef; 898 76 XSRETURN(1); 899 } 900 } 901 902 void 903 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) 904 40562 { 905 40562 if (!PL_known_layers) 906 4503 PL_known_layers = PerlIO_list_alloc(aTHX); 907 40562 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv); 908 40562 PerlIO_debug("define %s %p\n", tab->name, (void*)tab); 909 } 910 911 int 912 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) 913 1135 { 914 1135 if (names) { 915 1135 const char *s = names; 916 2302 while (*s) { 917 1587 while (isSPACE(*s) || *s == ':') 918 406 s++; 919 1181 if (*s) { 920 1181 STRLEN llen = 0; 921 1181 const char *e = s; 922 1181 const char *as = Nullch; 923 1181 STRLEN alen = 0; 924 1181 if (!isIDFIRST(*s)) { 925 /* 926 * Message is consistent with how attribute lists are 927 * passed. Even though this means "foo : : bar" is 928 * seen as an invalid separator character. 929 */ 930 5 const char q = ((*s == '\'') ? '"' : '\''); 931 5 if (ckWARN(WARN_LAYER)) 932 4 Perl_warner(aTHX_ packWARN(WARN_LAYER), 933 "Invalid separator character %c%c%c in PerlIO layer specification %s", 934 q, *s, q, s); 935 5 SETERRNO(EINVAL, LIB_INVARG); 936 5 return -1; 937 } 938 5109 do { 939 5109 e++; 940 5109 } while (isALNUM(*e)); 941 1176 llen = e - s; 942 1176 if (*e == '(') { 943 116 int nesting = 1; 944 116 as = ++e; 945 1113 while (nesting) { 946 999 switch (*e++) { 947 case ')': 948 114 if (--nesting == 0) 949 114 alen = (e - 1) - as; 950 114 break; 951 case '(': 952 ###### ++nesting; 953 ###### break; 954 case '\\': 955 /* 956 * It's a nul terminated string, not allowed 957 * to \ the terminating null. Anything other 958 * character is passed over. 959 */ 960 ###### if (*e++) { 961 ###### break; 962 } 963 /* 964 * Drop through 965 */ 966 case '\0': 967 2 e--; 968 2 if (ckWARN(WARN_LAYER)) 969 1 Perl_warner(aTHX_ packWARN(WARN_LAYER), 970 "Argument list not closed for PerlIO layer \"%.*s\"", 971 (int) (e - s), s); 972 2 return -1; 973 default: 974 /* 975 * boring. 976 */ 977 1174 break; 978 } 979 } 980 } 981 1174 if (e > s) { 982 1174 const bool warn_layer = ckWARN(WARN_LAYER); 983 1174 PerlIO_funcs *layer = 984 1174 PerlIO_find_layer(aTHX_ s, llen, 1); 985 1174 if (layer) { 986 1167 PerlIO_list_push(aTHX_ av, layer, 987 (as) ? newSVpvn(as, 988 alen) : 989 &PL_sv_undef); 990 } 991 else { 992 7 if (warn_layer) 993 5 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", 994 (int) llen, s); 995 7 return -1; 996 } 997 } 998 1167 s = e; 999 } 1000 } 1001 } 1002 1121 return 0; 1003 } 1004 1005 void 1006 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) 1007 4503 { 1008 4503 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio; 1009 #ifdef PERLIO_USING_CRLF 1010 tab = &PerlIO_crlf; 1011 #else 1012 4503 if (PerlIO_stdio.Set_ptrcnt) 1013 ###### tab = &PerlIO_stdio; 1014 #endif 1015 4503 PerlIO_debug("Pushing %s\n", tab->name); 1016 4503 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), 1017 &PL_sv_undef); 1018 } 1019 1020 SV * 1021 PerlIO_arg_fetch(PerlIO_list_t *av, IV n) 1022 153733 { 1023 153733 return av->array[n].arg; 1024 } 1025 1026 PerlIO_funcs * 1027 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) 1028 251883 { 1029 251883 if (n >= 0 && n < av->cur) { 1030 251883 PerlIO_debug("Layer %" IVdf " is %s\n", n, 1031 av->array[n].funcs->name); 1032 251883 return av->array[n].funcs; 1033 } 1034 ###### if (!def) 1035 ###### Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); 1036 ###### return def; 1037 } 1038 1039 IV 1040 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1041 1 { 1042 1 PERL_UNUSED_ARG(mode); 1043 1 PERL_UNUSED_ARG(arg); 1044 1 PERL_UNUSED_ARG(tab); 1045 1 if (PerlIOValid(f)) { 1046 1 PerlIO_flush(f); 1047 1 PerlIO_pop(aTHX_ f); 1048 1 return 0; 1049 } 1050 ###### return -1; 1051 } 1052 1053 PERLIO_FUNCS_DECL(PerlIO_remove) = { 1054 sizeof(PerlIO_funcs), 1055 "pop", 1056 0, 1057 PERLIO_K_DUMMY | PERLIO_K_UTF8, 1058 PerlIOPop_pushed, 1059 NULL, 1060 NULL, 1061 NULL, 1062 NULL, 1063 NULL, 1064 NULL, 1065 NULL, 1066 NULL, 1067 NULL, 1068 NULL, 1069 NULL, 1070 NULL, 1071 NULL, /* flush */ 1072 NULL, /* fill */ 1073 NULL, 1074 NULL, 1075 NULL, 1076 NULL, 1077 NULL, /* get_base */ 1078 NULL, /* get_bufsiz */ 1079 NULL, /* get_ptr */ 1080 NULL, /* get_cnt */ 1081 NULL, /* set_ptrcnt */ 1082 }; 1083 1084 PerlIO_list_t * 1085 PerlIO_default_layers(pTHX) 1086 167492 { 1087 167492 if (!PL_def_layerlist) { 1088 4503 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO"); 1089 4503 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; 1090 4503 PL_def_layerlist = PerlIO_list_alloc(aTHX); 1091 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); 1092 #if defined(WIN32) 1093 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); 1094 #if 0 1095 osLayer = &PerlIO_win32; 1096 #endif 1097 #endif 1098 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); 1099 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); 1100 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); 1101 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); 1102 #ifdef HAS_MMAP 1103 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap)); 1104 #endif 1105 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); 1106 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); 1107 4503 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); 1108 4503 PerlIO_list_push(aTHX_ PL_def_layerlist, 1109 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), 1110 &PL_sv_undef); 1111 4503 if (s) { 1112 ###### PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); 1113 } 1114 else { 1115 4503 PerlIO_default_buffer(aTHX_ PL_def_layerlist); 1116 } 1117 } 1118 167492 if (PL_def_layerlist->cur < 2) { 1119 ###### PerlIO_default_buffer(aTHX_ PL_def_layerlist); 1120 } 1121 167492 return PL_def_layerlist; 1122 } 1123 1124 void 1125 Perl_boot_core_PerlIO(pTHX) 1126 4500 { 1127 #ifdef USE_ATTRIBUTES_FOR_PERLIO 1128 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES, 1129 __FILE__); 1130 #endif 1131 4500 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 1132 4500 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__); 1133 } 1134 1135 PerlIO_funcs * 1136 PerlIO_default_layer(pTHX_ I32 n) 1137 83305 { 1138 83305 PerlIO_list_t *av = PerlIO_default_layers(aTHX); 1139 83305 if (n < 0) 1140 ###### n += av->cur; 1141 83305 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio)); 1142 } 1143 1144 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) 1145 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0) 1146 1147 void 1148 PerlIO_stdstreams(pTHX) 1149 4503 { 1150 4503 if (!PL_perlio) { 1151 4503 PerlIO_allocate(aTHX); 1152 4503 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); 1153 4503 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); 1154 4503 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); 1155 } 1156 } 1157 1158 PerlIO * 1159 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) 1160 167931 { 1161 167931 if (tab->fsize != sizeof(PerlIO_funcs)) { 1162 mismatch: 1163 ###### Perl_croak(aTHX_ "Layer does not match this perl"); 1164 } 1165 167931 if (tab->size) { 1166 156622 PerlIOl *l; 1167 156622 if (tab->size < sizeof(PerlIOl)) { 1168 ###### goto mismatch; 1169 } 1170 /* Real layer with a data area */ 1171 156622 Newc('L',l,tab->size,char,PerlIOl); 1172 156622 if (l && f) { 1173 156622 Zero(l, tab->size, char); 1174 156622 l->next = *f; 1175 156622 l->tab = (PerlIO_funcs*) tab; 1176 156622 *f = l; 1177 156622 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, 1178 (mode) ? mode : "(Null)", (void*)arg); 1179 156622 if (*l->tab->Pushed && 1180 (*l->tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { 1181 7 PerlIO_pop(aTHX_ f); 1182 7 return NULL; 1183 } 1184 } 1185 } 1186 11309 else if (f) { 1187 /* Pseudo-layer where push does its own stack adjust */ 1188 11309 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, 1189 (mode) ? mode : "(Null)", (void*)arg); 1190 11309 if (tab->Pushed && 1191 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { 1192 ###### return NULL; 1193 } 1194 } 1195 167924 return f; 1196 } 1197 1198 IV 1199 PerlIOBase_binmode(pTHX_ PerlIO *f) 1200 20668 { 1201 20668 if (PerlIOValid(f)) { 1202 /* Is layer suitable for raw stream ? */ 1203 20668 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { 1204 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ 1205 20668 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1206 } 1207 else { 1208 /* Not suitable - pop it */ 1209 ###### PerlIO_pop(aTHX_ f); 1210 } 1211 20668 return 0; 1212 } 1213 ###### return -1; 1214 } 1215 1216 IV 1217 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1218 10333 { 1219 10333 PERL_UNUSED_ARG(mode); 1220 10333 PERL_UNUSED_ARG(arg); 1221 10333 PERL_UNUSED_ARG(tab); 1222 1223 10333 if (PerlIOValid(f)) { 1224 10333 PerlIO *t; 1225 10333 const PerlIOl *l; 1226 10333 PerlIO_flush(f); 1227 /* 1228 * Strip all layers that are not suitable for a raw stream 1229 */ 1230 10333 t = f; 1231 31014 while (t && (l = *t)) { 1232 20681 if (l->tab->Binmode) { 1233 /* Has a handler - normal case */ 1234 20671 if ((*l->tab->Binmode)(aTHX_ f) == 0) { 1235 20671 if (*t == l) { 1236 /* Layer still there - move down a layer */ 1237 20668 t = PerlIONext(t); 1238 } 1239 } 1240 else { 1241 ###### return -1; 1242 } 1243 } 1244 else { 1245 /* No handler - pop it */ 1246 10 PerlIO_pop(aTHX_ t); 1247 } 1248 } 1249 10333 if (PerlIOValid(f)) { 1250 10333 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name); 1251 10333 return 0; 1252 } 1253 } 1254 ###### return -1; 1255 } 1256 1257 int 1258 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, 1259 PerlIO_list_t *layers, IV n, IV max) 1260 1036 { 1261 1036 int code = 0; 1262 2102 while (n < max) { 1263 1066 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); 1264 1066 if (tab) { 1265 1066 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { 1266 ###### code = -1; 1267 ###### break; 1268 } 1269 } 1270 1066 n++; 1271 } 1272 1036 return code; 1273 } 1274 1275 int 1276 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 1277 992 { 1278 992 int code = 0; 1279 992 if (f && names) { 1280 992 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); 1281 992 code = PerlIO_parse_layers(aTHX_ layers, names); 1282 992 if (code == 0) { 1283 990 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); 1284 } 1285 992 PerlIO_list_free(aTHX_ layers); 1286 } 1287 992 return code; 1288 } 1289 1290 1291 /*--------------------------------------------------------------------------------------*/ 1292 /* 1293 * Given the abstraction above the public API functions 1294 */ 1295 1296 int 1297 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) 1298 11276 { 1299 11276 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", 1300 (void*)f, PerlIOBase(f)->tab->name, iotype, mode, 1301 (names) ? names : "(Null)"); 1302 11276 if (names) { 1303 /* Do not flush etc. if (e.g.) switching encodings. 1304 if a pushed layer knows it needs to flush lower layers 1305 (for example :unix which is never going to call them) 1306 it can do the flush when it is pushed. 1307 */ 1308 983 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; 1309 } 1310 else { 1311 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ 1312 #ifdef PERLIO_USING_CRLF 1313 /* Legacy binmode only has meaning if O_TEXT has a value distinct from 1314 O_BINARY so we can look for it in mode. 1315 */ 1316 if (!(mode & O_BINARY)) { 1317 /* Text mode */ 1318 /* FIXME?: Looking down the layer stack seems wrong, 1319 but is a way of reaching past (say) an encoding layer 1320 to flip CRLF-ness of the layer(s) below 1321 */ 1322 while (*f) { 1323 /* Perhaps we should turn on bottom-most aware layer 1324 e.g. Ilya's idea that UNIX TTY could serve 1325 */ 1326 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) { 1327 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { 1328 /* Not in text mode - flush any pending stuff and flip it */ 1329 PerlIO_flush(f); 1330 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 1331 } 1332 /* Only need to turn it on in one layer so we are done */ 1333 return TRUE; 1334 } 1335 f = PerlIONext(f); 1336 } 1337 /* Not finding a CRLF aware layer presumably means we are binary 1338 which is not what was requested - so we failed 1339 We _could_ push :crlf layer but so could caller 1340 */ 1341 return FALSE; 1342 } 1343 #endif 1344 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw 1345 So code that used to be here is now in PerlIORaw_pushed(). 1346 */ 1347 10293 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), Nullch, Nullsv) ? TRUE : FALSE; 1348 } 1349 } 1350 1351 int 1352 PerlIO__close(pTHX_ PerlIO *f) 1353 78959 { 1354 78959 if (PerlIOValid(f)) { 1355 78958 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1356 78958 if (tab && tab->Close) 1357 78958 return (*tab->Close)(aTHX_ f); 1358 else 1359 ###### return PerlIOBase_close(aTHX_ f); 1360 } 1361 else { 1362 1 SETERRNO(EBADF, SS_IVCHAN); 1363 1 return -1; 1364 } 1365 } 1366 1367 int 1368 Perl_PerlIO_close(pTHX_ PerlIO *f) 1369 78959 { 1370 78959 const int code = PerlIO__close(aTHX_ f); 1371 236001 while (PerlIOValid(f)) { 1372 157042 PerlIO_pop(aTHX_ f); 1373 } 1374 78959 return code; 1375 } 1376 1377 int 1378 Perl_PerlIO_fileno(pTHX_ PerlIO *f) 1379 400431 { 1380 400431 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); 1381 } 1382 1383 static const char * 1384 PerlIO_context_layers(pTHX_ const char *mode) 1385 82959 { 1386 82959 const char *type = NULL; 1387 /* 1388 * Need to supply default layer info from open.pm 1389 */ 1390 82959 if (PL_curcop) { 1391 82959 SV *layers = PL_curcop->cop_io; 1392 82959 if (layers) { 1393 7 STRLEN len; 1394 7 type = SvPV_const(layers, len); 1395 7 if (type && mode[0] != 'r') { 1396 /* 1397 * Skip to write part 1398 */ 1399 3 const char *s = strchr(type, 0); 1400 3 if (s && (STRLEN)(s - type) < len) { 1401 3 type = s + 1; 1402 } 1403 } 1404 } 1405 } 1406 82959 return type; 1407 } 1408 1409 static PerlIO_funcs * 1410 PerlIO_layer_from_ref(pTHX_ SV *sv) 1411 937 { 1412 /* 1413 * For any scalar type load the handler which is bundled with perl 1414 */ 1415 937 if (SvTYPE(sv) < SVt_PVAV) 1416 937 return PerlIO_find_layer(aTHX_ "scalar", 6, 1); 1417 1418 /* 1419 * For other types allow if layer is known but don't try and load it 1420 */ 1421 ###### switch (SvTYPE(sv)) { 1422 case SVt_PVAV: 1423 ###### return PerlIO_find_layer(aTHX_ "Array", 5, 0); 1424 case SVt_PVHV: 1425 ###### return PerlIO_find_layer(aTHX_ "Hash", 4, 0); 1426 case SVt_PVCV: 1427 ###### return PerlIO_find_layer(aTHX_ "Code", 4, 0); 1428 case SVt_PVGV: 1429 ###### return PerlIO_find_layer(aTHX_ "Glob", 4, 0); 1430 } 1431 ###### return NULL; 1432 } 1433 1434 PerlIO_list_t * 1435 PerlIO_resolve_layers(pTHX_ const char *layers, 1436 const char *mode, int narg, SV **args) 1437 84187 { 1438 84187 PerlIO_list_t *def = PerlIO_default_layers(aTHX); 1439 84187 int incdef = 1; 1440 84187 if (!PL_perlio) 1441 4481 PerlIO_stdstreams(aTHX); 1442 84187 if (narg) { 1443 65559 SV *arg = *args; 1444 /* 1445 * If it is a reference but not an object see if we have a handler 1446 * for it 1447 */ 1448 65559 if (SvROK(arg) && !sv_isobject(arg)) { 1449 937 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); 1450 937 if (handler) { 1451 937 def = PerlIO_list_alloc(aTHX); 1452 937 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); 1453 937 incdef = 0; 1454 } 1455 /* 1456 * Don't fail if handler cannot be found :via(...) etc. may do 1457 * something sensible else we will just stringfy and open 1458 * resulting string. 1459 */ 1460 } 1461 } 1462 84187 if (!layers) 1463 82959 layers = PerlIO_context_layers(aTHX_ mode); 1464 84187 if (layers && *layers) { 1465 143 PerlIO_list_t *av; 1466 143 if (incdef) { 1467 142 IV i; 1468 142 av = PerlIO_list_alloc(aTHX); 1469 426 for (i = 0; i < def->cur; i++) { 1470 284 PerlIO_list_push(aTHX_ av, def->array[i].funcs, 1471 def->array[i].arg); 1472 } 1473 } 1474 else { 1475 1 av = def; 1476 } 1477 143 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { 1478 131 return av; 1479 } 1480 else { 1481 12 PerlIO_list_free(aTHX_ av); 1482 12 return (PerlIO_list_t *) NULL; 1483 } 1484 } 1485 else { 1486 84044 if (incdef) 1487 83108 def->refcnt++; 1488 84044 return def; 1489 } 1490 } 1491 1492 PerlIO * 1493 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 1494 int imode, int perm, PerlIO *f, int narg, SV **args) 1495 84191 { 1496 84191 if (!f && narg == 1 && *args == &PL_sv_undef) { 1497 4 if ((f = PerlIO_tmpfile())) { 1498 4 if (!layers) 1499 ###### layers = PerlIO_context_layers(aTHX_ mode); 1500 4 if (layers && *layers) 1501 ###### PerlIO_apply_layers(aTHX_ f, mode, layers); 1502 } 1503 } 1504 else { 1505 84187 PerlIO_list_t *layera; 1506 84187 IV n; 1507 84187 PerlIO_funcs *tab = NULL; 1508 84187 if (PerlIOValid(f)) { 1509 /* 1510 * This is "reopen" - it is not tested as perl does not use it 1511 * yet 1512 */ 1513 ###### PerlIOl *l = *f; 1514 ###### layera = PerlIO_list_alloc(aTHX); 1515 ###### while (l) { 1516 ###### SV *arg = (l->tab->Getarg) 1517 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0) 1518 ###### : &PL_sv_undef; 1519 ###### PerlIO_list_push(aTHX_ layera, l->tab, arg); 1520 ###### l = *PerlIONext(&l); 1521 } 1522 } 1523 else { 1524 84187 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); 1525 84187 if (!layera) { 1526 12 return NULL; 1527 } 1528 } 1529 /* 1530 * Start at "top" of layer stack 1531 */ 1532 84175 n = layera->cur - 1; 1533 84221 while (n >= 0) { 1534 84221 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); 1535 84221 if (t && t->Open) { 1536 84175 tab = t; 1537 84175 break; 1538 } 1539 46 n--; 1540 } 1541 84175 if (tab) { 1542 /* 1543 * Found that layer 'n' can do opens - call it 1544 */ 1545 84175 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { 1546 ###### Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); 1547 } 1548 84175 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", 1549 tab->name, layers, mode, fd, imode, perm, 1550 (void*)f, narg, (void*)args); 1551 84175 if (tab->Open) 1552 84175 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, 1553 f, narg, args); 1554 else { 1555 ###### SETERRNO(EINVAL, LIB_INVARG); 1556 ###### f = NULL; 1557 } 1558 84175 if (f) { 1559 77237 if (n + 1 < layera->cur) { 1560 /* 1561 * More layers above the one that we used to open - 1562 * apply them now 1563 */ 1564 46 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { 1565 /* If pushing layers fails close the file */ 1566 ###### PerlIO_close(f); 1567 ###### f = NULL; 1568 } 1569 } 1570 } 1571 } 1572 84175 PerlIO_list_free(aTHX_ layera); 1573 } 1574 84179 return f; 1575 } 1576 1577 1578 SSize_t 1579 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 1580 508610 { 1581 508610 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count)); 1582 } 1583 1584 SSize_t 1585 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1586 7437 { 1587 7437 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count)); 1588 } 1589 1590 SSize_t 1591 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1592 1318615 { 1593 1318615 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count)); 1594 } 1595 1596 int 1597 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 1598 77937 { 1599 77937 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence)); 1600 } 1601 1602 Off_t 1603 Perl_PerlIO_tell(pTHX_ PerlIO *f) 1604 1886891 { 1605 1886891 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f)); 1606 } 1607 1608 int 1609 Perl_PerlIO_flush(pTHX_ PerlIO *f) 1610 1113344 { 1611 1113344 if (f) { 1612 1104217 if (*f) { 1613 1104213 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1614 1615 1104213 if (tab && tab->Flush) 1616 1104213 return (*tab->Flush) (aTHX_ f); 1617 else 1618 ###### return 0; /* If no Flush defined, silently succeed. */ 1619 } 1620 else { 1621 4 PerlIO_debug("Cannot flush f=%p\n", (void*)f); 1622 4 SETERRNO(EBADF, SS_IVCHAN); 1623 4 return -1; 1624 } 1625 } 1626 else { 1627 /* 1628 * Is it good API design to do flush-all on NULL, a potentially 1629 * errorneous input? Maybe some magical value (PerlIO* 1630 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar 1631 * things on fflush(NULL), but should we be bound by their design 1632 * decisions? --jhi 1633 */ 1634 9127 PerlIO **table = &PL_perlio; 1635 9127 int code = 0; 1636 18251 while ((f = *table)) { 1637 9124 int i; 1638 9124 table = (PerlIO **) (f++); 1639 583936 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1640 574812 if (*f && PerlIO_flush(f) != 0) 1641 ###### code = -1; 1642 574812 f++; 1643 } 1644 } 1645 9127 return code; 1646 } 1647 } 1648 1649 void 1650 PerlIOBase_flush_linebuf(pTHX) 1651 9 { 1652 9 PerlIO **table = &PL_perlio; 1653 18 PerlIO *f; 1654 18 while ((f = *table)) { 1655 9 int i; 1656 9 table = (PerlIO **) (f++); 1657 576 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1658 567 if (*f 1659 && (PerlIOBase(f)-> 1660 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1661 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1662 13 PerlIO_flush(f); 1663 567 f++; 1664 } 1665 } 1666 } 1667 1668 int 1669 Perl_PerlIO_fill(pTHX_ PerlIO *f) 1670 244516 { 1671 244516 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f)); 1672 } 1673 1674 int 1675 PerlIO_isutf8(PerlIO *f) 1676 13412227 { 1677 13412227 if (PerlIOValid(f)) 1678 13412227 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; 1679 else 1680 ###### SETERRNO(EBADF, SS_IVCHAN); 1681 1682 ###### return -1; 1683 } 1684 1685 int 1686 Perl_PerlIO_eof(pTHX_ PerlIO *f) 1687 3749 { 1688 3749 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f)); 1689 } 1690 1691 int 1692 Perl_PerlIO_error(pTHX_ PerlIO *f) 1693 1207558 { 1694 1207558 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f)); 1695 } 1696 1697 void 1698 Perl_PerlIO_clearerr(pTHX_ PerlIO *f) 1699 7760 { 1700 7760 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f)); 1701 } 1702 1703 void 1704 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f) 1705 ###### { 1706 ###### Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f)); 1707 } 1708 1709 int 1710 PerlIO_has_base(PerlIO *f) 1711 11 { 1712 11 if (PerlIOValid(f)) { 1713 11 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1714 1715 11 if (tab) 1716 11 return (tab->Get_base != NULL); 1717 ###### SETERRNO(EINVAL, LIB_INVARG); 1718 } 1719 else 1720 ###### SETERRNO(EBADF, SS_IVCHAN); 1721 1722 ###### return 0; 1723 } 1724 1725 int 1726 PerlIO_fast_gets(PerlIO *f) 1727 11376159 { 1728 11376159 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) { 1729 11132035 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1730 1731 11132035 if (tab) 1732 11132035 return (tab->Set_ptrcnt != NULL); 1733 ###### SETERRNO(EINVAL, LIB_INVARG); 1734 } 1735 else 1736 244124 SETERRNO(EBADF, SS_IVCHAN); 1737 1738 244124 return 0; 1739 } 1740 1741 int 1742 PerlIO_has_cntptr(PerlIO *f) 1743 1575 { 1744 1575 if (PerlIOValid(f)) { 1745 1575 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1746 1747 1575 if (tab) 1748 1575 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); 1749 ###### SETERRNO(EINVAL, LIB_INVARG); 1750 } 1751 else 1752 ###### SETERRNO(EBADF, SS_IVCHAN); 1753 1754 ###### return 0; 1755 } 1756 1757 int 1758 PerlIO_canset_cnt(PerlIO *f) 1759 49 { 1760 49 if (PerlIOValid(f)) { 1761 49 const PerlIO_funcs *tab = PerlIOBase(f)->tab; 1762 1763 49 if (tab) 1764 49 return (tab->Set_ptrcnt != NULL); 1765 ###### SETERRNO(EINVAL, LIB_INVARG); 1766 } 1767 else 1768 ###### SETERRNO(EBADF, SS_IVCHAN); 1769 1770 ###### return 0; 1771 } 1772 1773 STDCHAR * 1774 Perl_PerlIO_get_base(pTHX_ PerlIO *f) 1775 351986 { 1776 351986 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f)); 1777 } 1778 1779 int 1780 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) 1781 9 { 1782 9 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f)); 1783 } 1784 1785 STDCHAR * 1786 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f) 1787 11606560 { 1788 11606560 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f)); 1789 } 1790 1791 int 1792 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) 1793 23412647 { 1794 23412647 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f)); 1795 } 1796 1797 void 1798 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt) 1799 ###### { 1800 ###### Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt)); 1801 } 1802 1803 void 1804 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt) 1805 11606552 { 1806 11606552 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt)); 1807 } 1808 1809 1810 /*--------------------------------------------------------------------------------------*/ 1811 /* 1812 * utf8 and raw dummy layers 1813 */ 1814 1815 IV 1816 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1817 975 { 1818 975 PERL_UNUSED_ARG(mode); 1819 975 PERL_UNUSED_ARG(arg); 1820 975 if (PerlIOValid(f)) { 1821 975 if (tab->kind & PERLIO_K_UTF8) 1822 911 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 1823 else 1824 64 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1825 975 return 0; 1826 } 1827 ###### return -1; 1828 } 1829 1830 PERLIO_FUNCS_DECL(PerlIO_utf8) = { 1831 sizeof(PerlIO_funcs), 1832 "utf8", 1833 0, 1834 PERLIO_K_DUMMY | PERLIO_K_UTF8, 1835 PerlIOUtf8_pushed, 1836 NULL, 1837 NULL, 1838 NULL, 1839 NULL, 1840 NULL, 1841 NULL, 1842 NULL, 1843 NULL, 1844 NULL, 1845 NULL, 1846 NULL, 1847 NULL, 1848 NULL, /* flush */ 1849 NULL, /* fill */ 1850 NULL, 1851 NULL, 1852 NULL, 1853 NULL, 1854 NULL, /* get_base */ 1855 NULL, /* get_bufsiz */ 1856 NULL, /* get_ptr */ 1857 NULL, /* get_cnt */ 1858 NULL, /* set_ptrcnt */ 1859 }; 1860 1861 PERLIO_FUNCS_DECL(PerlIO_byte) = { 1862 sizeof(PerlIO_funcs), 1863 "bytes", 1864 0, 1865 PERLIO_K_DUMMY, 1866 PerlIOUtf8_pushed, 1867 NULL, 1868 NULL, 1869 NULL, 1870 NULL, 1871 NULL, 1872 NULL, 1873 NULL, 1874 NULL, 1875 NULL, 1876 NULL, 1877 NULL, 1878 NULL, 1879 NULL, /* flush */ 1880 NULL, /* fill */ 1881 NULL, 1882 NULL, 1883 NULL, 1884 NULL, 1885 NULL, /* get_base */ 1886 NULL, /* get_bufsiz */ 1887 NULL, /* get_ptr */ 1888 NULL, /* get_cnt */ 1889 NULL, /* set_ptrcnt */ 1890 }; 1891 1892 PerlIO * 1893 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 1894 IV n, const char *mode, int fd, int imode, int perm, 1895 PerlIO *old, int narg, SV **args) 1896 19 { 1897 19 PerlIO_funcs * const tab = PerlIO_default_btm(); 1898 19 PERL_UNUSED_ARG(self); 1899 19 if (tab && tab->Open) 1900 19 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 1901 old, narg, args); 1902 ###### SETERRNO(EINVAL, LIB_INVARG); 1903 ###### return NULL; 1904 } 1905 1906 PERLIO_FUNCS_DECL(PerlIO_raw) = { 1907 sizeof(PerlIO_funcs), 1908 "raw", 1909 0, 1910 PERLIO_K_DUMMY, 1911 PerlIORaw_pushed, 1912 PerlIOBase_popped, 1913 PerlIORaw_open, 1914 NULL, 1915 NULL, 1916 NULL, 1917 NULL, 1918 NULL, 1919 NULL, 1920 NULL, 1921 NULL, 1922 NULL, 1923 NULL, 1924 NULL, /* flush */ 1925 NULL, /* fill */ 1926 NULL, 1927 NULL, 1928 NULL, 1929 NULL, 1930 NULL, /* get_base */ 1931 NULL, /* get_bufsiz */ 1932 NULL, /* get_ptr */ 1933 NULL, /* get_cnt */ 1934 NULL, /* set_ptrcnt */ 1935 }; 1936 /*--------------------------------------------------------------------------------------*/ 1937 /*--------------------------------------------------------------------------------------*/ 1938 /* 1939 * "Methods" of the "base class" 1940 */ 1941 1942 IV 1943 PerlIOBase_fileno(pTHX_ PerlIO *f) 1944 199852 { 1945 199852 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1; 1946 } 1947 1948 char * 1949 PerlIO_modestr(PerlIO * f, char *buf) 1950 2967 { 1951 2967 char *s = buf; 1952 2967 if (PerlIOValid(f)) { 1953 2967 const IV flags = PerlIOBase(f)->flags; 1954 2967 if (flags & PERLIO_F_APPEND) { 1955 ###### *s++ = 'a'; 1956 ###### if (flags & PERLIO_F_CANREAD) { 1957 ###### *s++ = '+'; 1958 } 1959 } 1960 2967 else if (flags & PERLIO_F_CANREAD) { 1961 11 *s++ = 'r'; 1962 11 if (flags & PERLIO_F_CANWRITE) 1963 1 *s++ = '+'; 1964 } 1965 2956 else if (flags & PERLIO_F_CANWRITE) { 1966 2956 *s++ = 'w'; 1967 2956 if (flags & PERLIO_F_CANREAD) { 1968 ###### *s++ = '+'; 1969 } 1970 } 1971 #ifdef PERLIO_USING_CRLF 1972 if (!(flags & PERLIO_F_CRLF)) 1973 *s++ = 'b'; 1974 #endif 1975 } 1976 2967 *s = '\0'; 1977 2967 return buf; 1978 } 1979 1980 1981 IV 1982 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1983 156622 { 1984 156622 PerlIOl * const l = PerlIOBase(f); 1985 156622 PERL_UNUSED_ARG(arg); 1986 1987 156622 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | 1988 PERLIO_F_TRUNCATE | PERLIO_F_APPEND); 1989 156622 if (tab->Set_ptrcnt != NULL) 1990 78835 l->flags |= PERLIO_F_FASTGETS; 1991 156622 if (mode) { 1992 156572 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) 1993 16557 mode++; 1994 156572 switch (*mode++) { 1995 case 'r': 1996 120356 l->flags |= PERLIO_F_CANREAD; 1997 120356 break; 1998 case 'a': 1999 75 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; 2000 75 break; 2001 case 'w': 2002 36141 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; 2003 36141 break; 2004 default: 2005 ###### SETERRNO(EINVAL, LIB_INVARG); 2006 ###### return -1; 2007 } 2008 162650 while (*mode) { 2009 6078 switch (*mode++) { 2010 case '+': 2011 6078 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 2012 6078 break; 2013 case 'b': 2014 ###### l->flags &= ~PERLIO_F_CRLF; 2015 ###### break; 2016 case 't': 2017 ###### l->flags |= PERLIO_F_CRLF; 2018 ###### break; 2019 default: 2020 ###### SETERRNO(EINVAL, LIB_INVARG); 2021 ###### return -1; 2022 } 2023 } 2024 } 2025 else { 2026 50 if (l->next) { 2027 50 l->flags |= l->next->flags & 2028 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | 2029 PERLIO_F_APPEND); 2030 } 2031 } 2032 #if 0 2033 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", 2034 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", 2035 l->flags, PerlIO_modestr(f, temp)); 2036 #endif 2037 156622 return 0; 2038 } 2039 2040 IV 2041 PerlIOBase_popped(pTHX_ PerlIO *f) 2042 156040 { 2043 156040 PERL_UNUSED_ARG(f); 2044 156040 return 0; 2045 } 2046 2047 SSize_t 2048 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2049 ###### { 2050 /* 2051 * Save the position as current head considers it 2052 */ 2053 ###### const Off_t old = PerlIO_tell(f); 2054 ###### PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", Nullsv); 2055 ###### PerlIOSelf(f, PerlIOBuf)->posn = old; 2056 ###### return PerlIOBuf_unread(aTHX_ f, vbuf, count); 2057 } 2058 2059 SSize_t 2060 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2061 264479 { 2062 264479 STDCHAR *buf = (STDCHAR *) vbuf; 2063 264479 if (f) { 2064 264479 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { 2065 10 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2066 10 SETERRNO(EBADF, SS_IVCHAN); 2067 10 return 0; 2068 } 2069 693017 while (count > 0) { 2070 468517 SSize_t avail = PerlIO_get_cnt(f); 2071 468517 SSize_t take = 0; 2072 468517 if (avail > 0) 2073 232910 take = ((SSize_t)count < avail) ? count : avail; 2074 468517 if (take > 0) { 2075 232910 STDCHAR *ptr = PerlIO_get_ptr(f); 2076 232910 Copy(ptr, buf, take, STDCHAR); 2077 232910 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); 2078 232910 count -= take; 2079 232910 buf += take; 2080 } 2081 468517 if (count > 0 && avail <= 0) { 2082 244341 if (PerlIO_fill(f) != 0) 2083 264468 break; 2084 } 2085 } 2086 264468 return (buf - (STDCHAR *) vbuf); 2087 } 2088 ###### return 0; 2089 } 2090 2091 IV 2092 PerlIOBase_noop_ok(pTHX_ PerlIO *f) 2093 550317 { 2094 550317 PERL_UNUSED_ARG(f); 2095 550317 return 0; 2096 } 2097 2098 IV 2099 PerlIOBase_noop_fail(pTHX_ PerlIO *f) 2100 ###### { 2101 ###### PERL_UNUSED_ARG(f); 2102 ###### return -1; 2103 } 2104 2105 IV 2106 PerlIOBase_close(pTHX_ PerlIO *f) 2107 79018 { 2108 79018 IV code = -1; 2109 79018 if (PerlIOValid(f)) { 2110 79018 PerlIO *n = PerlIONext(f); 2111 79018 code = PerlIO_flush(f); 2112 79018 PerlIOBase(f)->flags &= 2113 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2114 79018 while (PerlIOValid(n)) { 2115 78080 const PerlIO_funcs * const tab = PerlIOBase(n)->tab; 2116 78080 if (tab && tab->Close) { 2117 78080 if ((*tab->Close)(aTHX_ n) != 0) 2118 2 code = -1; 2119 2 break; 2120 } 2121 else { 2122 ###### PerlIOBase(n)->flags &= 2123 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2124 } 2125 ###### n = PerlIONext(n); 2126 } 2127 } 2128 else { 2129 ###### SETERRNO(EBADF, SS_IVCHAN); 2130 } 2131 79018 return code; 2132 } 2133 2134 IV 2135 PerlIOBase_eof(pTHX_ PerlIO *f) 2136 3749 { 2137 3749 if (PerlIOValid(f)) { 2138 3749 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; 2139 } 2140 ###### return 1; 2141 } 2142 2143 IV 2144 PerlIOBase_error(pTHX_ PerlIO *f) 2145 1207557 { 2146 1207557 if (PerlIOValid(f)) { 2147 1207557 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; 2148 } 2149 ###### return 1; 2150 } 2151 2152 void 2153 PerlIOBase_clearerr(pTHX_ PerlIO *f) 2154 7760 { 2155 7760 if (PerlIOValid(f)) { 2156 7760 PerlIO *n = PerlIONext(f); 2157 7760 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); 2158 7760 if (PerlIOValid(n)) 2159 3891 PerlIO_clearerr(n); 2160 } 2161 } 2162 2163 void 2164 PerlIOBase_setlinebuf(pTHX_ PerlIO *f) 2165 ###### { 2166 ###### if (PerlIOValid(f)) { 2167 ###### PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; 2168 } 2169 } 2170 2171 SV * 2172 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) 2173 2 { 2174 2 if (!arg) 2175 ###### return Nullsv; 2176 #ifdef sv_dup 2177 if (param) { 2178 return sv_dup(arg, param); 2179 } 2180 else { 2181 return newSVsv(arg); 2182 } 2183 #else 2184 2 PERL_UNUSED_ARG(param); 2185 2 return newSVsv(arg); 2186 #endif 2187 } 2188 2189 PerlIO * 2190 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2191 2967 { 2192 2967 PerlIO * const nexto = PerlIONext(o); 2193 2967 if (PerlIOValid(nexto)) { 2194 1484 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; 2195 1484 if (tab && tab->Dup) 2196 1484 f = (*tab->Dup)(aTHX_ f, nexto, param, flags); 2197 else 2198 ###### f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); 2199 } 2200 2967 if (f) { 2201 2967 PerlIO_funcs *self = PerlIOBase(o)->tab; 2202 2967 SV *arg; 2203 2967 char buf[8]; 2204 2967 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", 2205 self->name, (void*)f, (void*)o, (void*)param); 2206 2967 if (self->Getarg) 2207 3 arg = (*self->Getarg)(aTHX_ o, param, flags); 2208 else { 2209 2964 arg = Nullsv; 2210 } 2211 2967 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); 2212 2967 if (arg) { 2213 3 SvREFCNT_dec(arg); 2214 } 2215 } 2216 2967 return f; 2217 } 2218 2219 #ifdef USE_THREADS 2220 perl_mutex PerlIO_mutex; 2221 #endif 2222 2223 /* PL_perlio_fd_refcnt[] is in intrpvar.h */ 2224 2225 void 2226 PerlIO_init(pTHX) 2227 4503 { 2228 /* Place holder for stdstreams call ??? */ 2229 #ifdef USE_THREADS 2230 MUTEX_INIT(&PerlIO_mutex); 2231 #endif 2232 } 2233 2234 void 2235 PerlIOUnix_refcnt_inc(int fd) 2236 91433 { 2237 dTHX; 2238 91433 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 2239 #ifdef USE_THREADS 2240 MUTEX_LOCK(&PerlIO_mutex); 2241 #endif 2242 91433 PL_perlio_fd_refcnt[fd]++; 2243 91433 PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]); 2244 #ifdef USE_THREADS 2245 MUTEX_UNLOCK(&PerlIO_mutex); 2246 #endif 2247 } 2248 } 2249 2250 int 2251 PerlIOUnix_refcnt_dec(int fd) 2252 91667 { 2253 dTHX; 2254 91667 int cnt = 0; 2255 91667 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 2256 #ifdef USE_THREADS 2257 MUTEX_LOCK(&PerlIO_mutex); 2258 #endif 2259 91667 cnt = --PL_perlio_fd_refcnt[fd]; 2260 91667 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt); 2261 #ifdef USE_THREADS 2262 MUTEX_UNLOCK(&PerlIO_mutex); 2263 #endif 2264 } 2265 91667 return cnt; 2266 } 2267 2268 void 2269 PerlIO_cleanup(pTHX) 2270 4549 { 2271 4549 int i; 2272 #ifdef USE_ITHREADS 2273 PerlIO_debug("Cleanup layers for %p\n",aTHX); 2274 #else 2275 4549 PerlIO_debug("Cleanup layers\n"); 2276 #endif 2277 /* Raise STDIN..STDERR refcount so we don't close them */ 2278 18196 for (i=0; i < 3; i++) 2279 13647 PerlIOUnix_refcnt_inc(i); 2280 4549 PerlIO_cleantable(aTHX_ &PL_perlio); 2281 /* Restore STDIN..STDERR refcount */ 2282 18196 for (i=0; i < 3; i++) 2283 13647 PerlIOUnix_refcnt_dec(i); 2284 2285 4549 if (PL_known_layers) { 2286 4549 PerlIO_list_free(aTHX_ PL_known_layers); 2287 4549 PL_known_layers = NULL; 2288 } 2289 4549 if (PL_def_layerlist) { 2290 4549 PerlIO_list_free(aTHX_ PL_def_layerlist); 2291 4549 PL_def_layerlist = NULL; 2292 } 2293 } 2294 2295 2296 2297 /*--------------------------------------------------------------------------------------*/ 2298 /* 2299 * Bottom-most level for UNIX-like case 2300 */ 2301 2302 typedef struct { 2303 struct _PerlIO base; /* The generic part */ 2304 int fd; /* UNIX like file descriptor */ 2305 int oflags; /* open/fcntl flags */ 2306 } PerlIOUnix; 2307 2308 int 2309 PerlIOUnix_oflags(const char *mode) 2310 61552 { 2311 61552 int oflags = -1; 2312 61552 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) 2313 ###### mode++; 2314 61552 switch (*mode) { 2315 case 'r': 2316 55112 oflags = O_RDONLY; 2317 55112 if (*++mode == '+') { 2318 3 oflags = O_RDWR; 2319 3 mode++; 2320 } 2321 3 break; 2322 2323 case 'w': 2324 6402 oflags = O_CREAT | O_TRUNC; 2325 6402 if (*++mode == '+') { 2326 8 oflags |= O_RDWR; 2327 8 mode++; 2328 } 2329 else 2330 6394 oflags |= O_WRONLY; 2331 6394 break; 2332 2333 case 'a': 2334 38 oflags = O_CREAT | O_APPEND; 2335 38 if (*++mode == '+') { 2336 1 oflags |= O_RDWR; 2337 1 mode++; 2338 } 2339 else 2340 37 oflags |= O_WRONLY; 2341 break; 2342 } 2343 61552 if (*mode == 'b') { 2344 ###### oflags |= O_BINARY; 2345 ###### oflags &= ~O_TEXT; 2346 ###### mode++; 2347 } 2348 61552 else if (*mode == 't') { 2349 ###### oflags |= O_TEXT; 2350 ###### oflags &= ~O_BINARY; 2351 ###### mode++; 2352 } 2353 /* 2354 * Always open in binary mode 2355 */ 2356 61552 oflags |= O_BINARY; 2357 61552 if (*mode || oflags == -1) { 2358 ###### SETERRNO(EINVAL, LIB_INVARG); 2359 ###### oflags = -1; 2360 } 2361 61552 return oflags; 2362 } 2363 2364 IV 2365 PerlIOUnix_fileno(pTHX_ PerlIO *f) 2366 199630 { 2367 199630 return PerlIOSelf(f, PerlIOUnix)->fd; 2368 } 2369 2370 static void 2371 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) 2372 77786 { 2373 77786 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix); 2374 #if defined(WIN32) 2375 Stat_t st; 2376 if (PerlLIO_fstat(fd, &st) == 0) { 2377 if (!S_ISREG(st.st_mode)) { 2378 PerlIO_debug("%d is not regular file\n",fd); 2379 PerlIOBase(f)->flags |= PERLIO_F_NOTREG; 2380 } 2381 else { 2382 PerlIO_debug("%d _is_ a regular file\n",fd); 2383 } 2384 } 2385 #endif 2386 77786 s->fd = fd; 2387 77786 s->oflags = imode; 2388 77786 PerlIOUnix_refcnt_inc(fd); 2389 } 2390 2391 IV 2392 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2393 77786 { 2394 77786 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2395 77786 if (*PerlIONext(f)) { 2396 /* We never call down so do any pending stuff now */ 2397 2 PerlIO_flush(PerlIONext(f)); 2398 /* 2399 * XXX could (or should) we retrieve the oflags from the open file 2400 * handle rather than believing the "mode" we are passed in? XXX 2401 * Should the value on NULL mode be 0 or -1? 2402 */ 2403 2 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), 2404 mode ? PerlIOUnix_oflags(mode) : -1); 2405 } 2406 77786 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2407 2408 77786 return code; 2409 } 2410 2411 IV 2412 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 2413 48925 { 2414 48925 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2415 48925 Off_t new_loc; 2416 48925 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { 2417 #ifdef ESPIPE 2418 ###### SETERRNO(ESPIPE, LIB_INVARG); 2419 #else 2420 SETERRNO(EINVAL, LIB_INVARG); 2421 #endif 2422 ###### return -1; 2423 } 2424 48925 new_loc = PerlLIO_lseek(fd, offset, whence); 2425 48925 if (new_loc == (Off_t) - 1) 2426 { 2427 12 return -1; 2428 } 2429 48913 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 2430 48913 return 0; 2431 } 2432 2433 PerlIO * 2434 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 2435 IV n, const char *mode, int fd, int imode, 2436 int perm, PerlIO *f, int narg, SV **args) 2437 83233 { 2438 83233 if (PerlIOValid(f)) { 2439 ###### if (PerlIOBase(f)->flags & PERLIO_F_OPEN) 2440 ###### (*PerlIOBase(f)->tab->Close)(aTHX_ f); 2441 } 2442 83233 if (narg > 0) { 2443 64605 if (*mode == IoTYPE_NUMERIC) 2444 3053 mode++; 2445 else { 2446 61552 imode = PerlIOUnix_oflags(mode); 2447 61552 perm = 0666; 2448 } 2449 64605 if (imode != -1) { 2450 64605 const char *path = SvPV_nolen_const(*args); 2451 64605 fd = PerlLIO_open3(path, imode, perm); 2452 } 2453 } 2454 83233 if (fd >= 0) { 2455 76302 if (*mode == IoTYPE_IMPLICIT) 2456 13509 mode++; 2457 76302 if (!f) { 2458 76298 f = PerlIO_allocate(aTHX); 2459 } 2460 76302 if (!PerlIOValid(f)) { 2461 76302 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 2462 ###### return NULL; 2463 } 2464 } 2465 76302 PerlIOUnix_setfd(aTHX_ f, fd, imode); 2466 76302 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2467 76302 if (*mode == IoTYPE_APPEND) 2468 37 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); 2469 76302 return f; 2470 } 2471 else { 2472 6931 if (f) { 2473 /* 2474 * FIXME: pop layers ??? 2475 */ 2476 } 2477 6931 return NULL; 2478 } 2479 } 2480 2481 PerlIO * 2482 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2483 1482 { 2484 1482 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix); 2485 1482 int fd = os->fd; 2486 1482 if (flags & PERLIO_DUP_FD) { 2487 1477 fd = PerlLIO_dup(fd); 2488 } 2489 1482 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 2490 1482 f = PerlIOBase_dup(aTHX_ f, o, param, flags); 2491 1482 if (f) { 2492 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ 2493 1482 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); 2494 1482 return f; 2495 } 2496 } 2497 ###### return NULL; 2498 } 2499 2500 2501 SSize_t 2502 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2503 244131 { 2504 244131 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2505 #ifdef PERLIO_STD_SPECIAL 2506 if (fd == 0) 2507 return PERLIO_STD_IN(fd, vbuf, count); 2508 #endif 2509 244131 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || 2510 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { 2511 2173 return 0; 2512 } 2513 241958 while (1) { 2514 241958 const SSize_t len = PerlLIO_read(fd, vbuf, count); 2515 241958 if (len >= 0 || errno != EINTR) { 2516 241957 if (len < 0) { 2517 2 if (errno != EAGAIN) { 2518 2 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2519 } 2520 } 2521 241955 else if (len == 0 && count != 0) { 2522 37784 PerlIOBase(f)->flags |= PERLIO_F_EOF; 2523 37784 SETERRNO(0,0); 2524 } 2525 241957 return len; 2526 } 2527 1 PERL_ASYNC_CHECK(); 2528 } 2529 /*NOTREACHED*/ 2530 } 2531 2532 SSize_t 2533 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2534 146040 { 2535 146040 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2536 #ifdef PERLIO_STD_SPECIAL 2537 if (fd == 1 || fd == 2) 2538 return PERLIO_STD_OUT(fd, vbuf, count); 2539 #endif 2540 146040 while (1) { 2541 146040 const SSize_t len = PerlLIO_write(fd, vbuf, count); 2542 146040 if (len >= 0 || errno != EINTR) { 2543 146040 if (len < 0) { 2544 3 if (errno != EAGAIN) { 2545 3 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2546 } 2547 } 2548 146040 return len; 2549 } 2550 ###### PERL_ASYNC_CHECK(); 2551 } 2552 /*NOTREACHED*/ 2553 } 2554 2555 Off_t 2556 PerlIOUnix_tell(pTHX_ PerlIO *f) 2557 126660 { 2558 126660 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR); 2559 } 2560 2561 2562 IV 2563 PerlIOUnix_close(pTHX_ PerlIO *f) 2564 78020 { 2565 78020 const int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2566 78020 int code = 0; 2567 78020 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { 2568 78020 if (PerlIOUnix_refcnt_dec(fd) > 0) { 2569 14269 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2570 14269 return 0; 2571 } 2572 } 2573 else { 2574 ###### SETERRNO(EBADF,SS_IVCHAN); 2575 ###### return -1; 2576 } 2577 63751 while (PerlLIO_close(fd) != 0) { 2578 2 if (errno != EINTR) { 2579 2 code = -1; 2580 2 break; 2581 } 2582 ###### PERL_ASYNC_CHECK(); 2583 } 2584 63751 if (code == 0) { 2585 63749 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2586 } 2587 63751 return code; 2588 } 2589 2590 PERLIO_FUNCS_DECL(PerlIO_unix) = { 2591 sizeof(PerlIO_funcs), 2592 "unix", 2593 sizeof(PerlIOUnix), 2594 PERLIO_K_RAW, 2595 PerlIOUnix_pushed, 2596 PerlIOBase_popped, 2597 PerlIOUnix_open, 2598 PerlIOBase_binmode, /* binmode */ 2599 NULL, 2600 PerlIOUnix_fileno, 2601 PerlIOUnix_dup, 2602 PerlIOUnix_read, 2603 PerlIOBase_unread, 2604 PerlIOUnix_write, 2605 PerlIOUnix_seek, 2606 PerlIOUnix_tell, 2607 PerlIOUnix_close, 2608 PerlIOBase_noop_ok, /* flush */ 2609 PerlIOBase_noop_fail, /* fill */ 2610 PerlIOBase_eof, 2611 PerlIOBase_error, 2612 PerlIOBase_clearerr, 2613 PerlIOBase_setlinebuf, 2614 NULL, /* get_base */ 2615 NULL, /* get_bufsiz */ 2616 NULL, /* get_ptr */ 2617 NULL, /* get_cnt */ 2618 NULL, /* set_ptrcnt */ 2619 }; 2620 2621 /*--------------------------------------------------------------------------------------*/ 2622 /* 2623 * stdio as a layer 2624 */ 2625 2626 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE) 2627 /* perl5.8 - This ensures the last minute VMS ungetc fix is not 2628 broken by the last second glibc 2.3 fix 2629 */ 2630 #define STDIO_BUFFER_WRITABLE 2631 #endif 2632 2633 2634 typedef struct { 2635 struct _PerlIO base; 2636 FILE *stdio; /* The stream */ 2637 } PerlIOStdio; 2638 2639 IV 2640 PerlIOStdio_fileno(pTHX_ PerlIO *f) 2641 1 { 2642 1 FILE *s; 2643 1 if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) { 2644 1 return PerlSIO_fileno(s); 2645 } 2646 ###### errno = EBADF; 2647 ###### return -1; 2648 } 2649 2650 char * 2651 PerlIOStdio_mode(const char *mode, char *tmode) 2652 ###### { 2653 ###### char * const ret = tmode; 2654 ###### if (mode) { 2655 ###### while (*mode) { 2656 ###### *tmode++ = *mode++; 2657 } 2658 } 2659 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) 2660 *tmode++ = 'b'; 2661 #endif 2662 ###### *tmode = '\0'; 2663 ###### return ret; 2664 } 2665 2666 IV 2667 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2668 1 { 2669 1 PerlIO *n; 2670 1 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { 2671 ###### PerlIO_funcs *toptab = PerlIOBase(n)->tab; 2672 ###### if (toptab == tab) { 2673 /* Top is already stdio - pop self (duplicate) and use original */ 2674 ###### PerlIO_pop(aTHX_ f); 2675 ###### return 0; 2676 } else { 2677 ###### const int fd = PerlIO_fileno(n); 2678 ###### char tmode[8]; 2679 ###### FILE *stdio; 2680 ###### if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, 2681 mode = PerlIOStdio_mode(mode, tmode)))) { 2682 ###### PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 2683 /* We never call down so do any pending stuff now */ 2684 ###### PerlIO_flush(PerlIONext(f)); 2685 } 2686 else { 2687 ###### return -1; 2688 } 2689 } 2690 } 2691 1 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2692 } 2693 2694 2695 PerlIO * 2696 PerlIO_importFILE(FILE *stdio, const char *mode) 2697 1 { 2698 dTHX; 2699 1 PerlIO *f = NULL; 2700 1 if (stdio) { 2701 1 PerlIOStdio *s; 2702 1 if (!mode || !*mode) { 2703 /* We need to probe to see how we can open the stream 2704 so start with read/write and then try write and read 2705 we dup() so that we can fclose without loosing the fd. 2706 2707 Note that the errno value set by a failing fdopen 2708 varies between stdio implementations. 2709 */ 2710 1 const int fd = PerlLIO_dup(fileno(stdio)); 2711 1 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+")); 2712 1 if (!f2) { 2713 1 f2 = PerlSIO_fdopen(fd, (mode = "w")); 2714 } 2715 1 if (!f2) { 2716 ###### f2 = PerlSIO_fdopen(fd, (mode = "r")); 2717 } 2718 1 if (!f2) { 2719 /* Don't seem to be able to open */ 2720 ###### PerlLIO_close(fd); 2721 ###### return f; 2722 } 2723 1 fclose(f2); 2724 } 2725 1 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, Nullsv))) { 2726 1 s = PerlIOSelf(f, PerlIOStdio); 2727 1 s->stdio = stdio; 2728 } 2729 } 2730 1 return f; 2731 } 2732 2733 PerlIO * 2734 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 2735 IV n, const char *mode, int fd, int imode, 2736 int perm, PerlIO *f, int narg, SV **args) 2737 ###### { 2738 ###### char tmode[8]; 2739 ###### if (PerlIOValid(f)) { 2740 ###### const char *path = SvPV_nolen_const(*args); 2741 ###### PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); 2742 ###### FILE *stdio; 2743 ###### PerlIOUnix_refcnt_dec(fileno(s->stdio)); 2744 ###### stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)), 2745 s->stdio); 2746 ###### if (!s->stdio) 2747 ###### return NULL; 2748 ###### s->stdio = stdio; 2749 ###### PerlIOUnix_refcnt_inc(fileno(s->stdio)); 2750 ###### return f; 2751 } 2752 else { 2753 ###### if (narg > 0) { 2754 ###### const char *path = SvPV_nolen_const(*args); 2755 ###### if (*mode == IoTYPE_NUMERIC) { 2756 ###### mode++; 2757 ###### fd = PerlLIO_open3(path, imode, perm); 2758 } 2759 else { 2760 ###### FILE *stdio; 2761 ###### bool appended = FALSE; 2762 #ifdef __CYGWIN__ 2763 /* Cygwin wants its 'b' early. */ 2764 appended = TRUE; 2765 mode = PerlIOStdio_mode(mode, tmode); 2766 #endif 2767 ###### stdio = PerlSIO_fopen(path, mode); 2768 ###### if (stdio) { 2769 ###### PerlIOStdio *s; 2770 ###### if (!f) { 2771 ###### f = PerlIO_allocate(aTHX); 2772 } 2773 ###### if (!appended) 2774 ###### mode = PerlIOStdio_mode(mode, tmode); 2775 ###### f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); 2776 ###### if (f) { 2777 ###### s = PerlIOSelf(f, PerlIOStdio); 2778 ###### s->stdio = stdio; 2779 ###### PerlIOUnix_refcnt_inc(fileno(s->stdio)); 2780 } 2781 ###### return f; 2782 } 2783 else { 2784 ###### return NULL; 2785 } 2786 } 2787 } 2788 ###### if (fd >= 0) { 2789 ###### FILE *stdio = NULL; 2790 ###### int init = 0; 2791 ###### if (*mode == IoTYPE_IMPLICIT) { 2792 ###### init = 1; 2793 ###### mode++; 2794 } 2795 ###### if (init) { 2796 ###### switch (fd) { 2797 case 0: 2798 ###### stdio = PerlSIO_stdin; 2799 ###### break; 2800 case 1: 2801 ###### stdio = PerlSIO_stdout; 2802 ###### break; 2803 case 2: 2804 ###### stdio = PerlSIO_stderr; 2805 ###### break; 2806 } 2807 } 2808 else { 2809 ###### stdio = PerlSIO_fdopen(fd, mode = 2810 PerlIOStdio_mode(mode, tmode)); 2811 } 2812 ###### if (stdio) { 2813 ###### if (!f) { 2814 ###### f = PerlIO_allocate(aTHX); 2815 } 2816 ###### if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 2817 ###### PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); 2818 ###### s->stdio = stdio; 2819 ###### PerlIOUnix_refcnt_inc(fileno(s->stdio)); 2820 } 2821 ###### return f; 2822 } 2823 } 2824 } 2825 ###### return NULL; 2826 } 2827 2828 PerlIO * 2829 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2830 ###### { 2831 /* This assumes no layers underneath - which is what 2832 happens, but is not how I remember it. NI-S 2001/10/16 2833 */ 2834 ###### if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { 2835 ###### FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; 2836 ###### const int fd = fileno(stdio); 2837 ###### char mode[8]; 2838 ###### if (flags & PERLIO_DUP_FD) { 2839 ###### const int dfd = PerlLIO_dup(fileno(stdio)); 2840 ###### if (dfd >= 0) { 2841 ###### stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); 2842 ###### goto set_this; 2843 } 2844 else { 2845 /* FIXME: To avoid messy error recovery if dup fails 2846 re-use the existing stdio as though flag was not set 2847 */ 2848 } 2849 } 2850 ###### stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); 2851 set_this: 2852 ###### PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 2853 ###### PerlIOUnix_refcnt_inc(fileno(stdio)); 2854 } 2855 ###### return f; 2856 } 2857 2858 static int 2859 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) 2860 ###### { 2861 /* XXX this could use PerlIO_canset_fileno() and 2862 * PerlIO_set_fileno() support from Configure 2863 */ 2864 # if defined(__UCLIBC__) 2865 /* uClibc must come before glibc because it defines __GLIBC__ as well. */ 2866 f->__filedes = -1; 2867 return 1; 2868 # elif defined(__GLIBC__) 2869 /* There may be a better way for GLIBC: 2870 - libio.h defines a flag to not close() on cleanup 2871 */ 2872 ###### f->_fileno = -1; 2873 ###### return 1; 2874 # elif defined(__sun__) 2875 # if defined(_LP64) 2876 /* On solaris, if _LP64 is defined, the FILE structure is this: 2877 * 2878 * struct FILE { 2879 * long __pad[16]; 2880 * }; 2881 * 2882 * It turns out that the fd is stored in the top 32 bits of 2883 * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears 2884 * to contain a pointer or offset into another structure. All the 2885 * remaining fields are zero. 2886 * 2887 * We set the top bits to -1 (0xFFFFFFFF). 2888 */ 2889 f->__pad[4] |= 0xffffffff00000000L; 2890 assert(fileno(f) == 0xffffffff); 2891 # else /* !defined(_LP64) */ 2892 /* _file is just a unsigned char :-( 2893 Not clear why we dup() rather than using -1 2894 even if that would be treated as 0xFF - so will 2895 a dup fail ... 2896 */ 2897 f->_file = PerlLIO_dup(fileno(f)); 2898 # endif /* defined(_LP64) */ 2899 return 1; 2900 # elif defined(__hpux) 2901 f->__fileH = 0xff; 2902 f->__fileL = 0xff; 2903 return 1; 2904 /* Next one ->_file seems to be a reasonable fallback, i.e. if 2905 your platform does not have special entry try this one. 2906 [For OSF only have confirmation for Tru64 (alpha) 2907 but assume other OSFs will be similar.] 2908 */ 2909 # elif defined(_AIX) || defined(__osf__) || defined(__irix__) 2910 f->_file = -1; 2911 return 1; 2912 # elif defined(__FreeBSD__) 2913 /* There may be a better way on FreeBSD: 2914 - we could insert a dummy func in the _close function entry 2915 f->_close = (int (*)(void *)) dummy_close; 2916 */ 2917 f->_file = -1; 2918 return 1; 2919 # elif defined(__OpenBSD__) 2920 /* There may be a better way on OpenBSD: 2921 - we could insert a dummy func in the _close function entry 2922 f->_close = (int (*)(void *)) dummy_close; 2923 */ 2924 f->_file = -1; 2925 return 1; 2926 # elif defined(__EMX__) 2927 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */ 2928 f->_handle = -1; 2929 return 1; 2930 # elif defined(__CYGWIN__) 2931 /* There may be a better way on CYGWIN: 2932 - we could insert a dummy func in the _close function entry 2933 f->_close = (int (*)(void *)) dummy_close; 2934 */ 2935 f->_file = -1; 2936 return 1; 2937 # elif defined(WIN32) 2938 # if defined(__BORLANDC__) 2939 f->fd = PerlLIO_dup(fileno(f)); 2940 # elif defined(UNDER_CE) 2941 /* WIN_CE does not have access to FILE internals, it hardly has FILE 2942 structure at all 2943 */ 2944 # else 2945 f->_file = -1; 2946 # endif 2947 return 1; 2948 # else 2949 #if 0 2950 /* Sarathy's code did this - we fall back to a dup/dup2 hack 2951 (which isn't thread safe) instead 2952 */ 2953 # error "Don't know how to set FILE.fileno on your platform" 2954 #endif 2955 PERL_UNUSED_ARG(f); 2956 return 0; 2957 # endif 2958 } 2959 2960 IV 2961 PerlIOStdio_close(pTHX_ PerlIO *f) 2962 ###### { 2963 ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2964 ###### if (!stdio) { 2965 ###### errno = EBADF; 2966 ###### return -1; 2967 } 2968 else { 2969 ###### const int fd = fileno(stdio); 2970 ###### int socksfd = 0; 2971 ###### int invalidate = 0; 2972 ###### IV result = 0; 2973 ###### int saveerr = 0; 2974 ###### int dupfd = 0; 2975 #ifdef SOCKS5_VERSION_NAME 2976 /* Socks lib overrides close() but stdio isn't linked to 2977 that library (though we are) - so we must call close() 2978 on sockets on stdio's behalf. 2979 */ 2980 int optval; 2981 Sock_size_t optlen = sizeof(int); 2982 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) { 2983 socksfd = 1; 2984 invalidate = 1; 2985 } 2986 #endif 2987 ###### if (PerlIOUnix_refcnt_dec(fd) > 0) { 2988 /* File descriptor still in use */ 2989 ###### invalidate = 1; 2990 ###### socksfd = 0; 2991 } 2992 ###### if (invalidate) { 2993 /* For STD* handles don't close the stdio at all 2994 this is because we have shared the FILE * too 2995 */ 2996 ###### if (stdio == stdin) { 2997 /* Some stdios are buggy fflush-ing inputs */ 2998 ###### return 0; 2999 } 3000 ###### else if (stdio == stdout || stdio == stderr) { 3001 ###### return PerlIO_flush(f); 3002 } 3003 /* Tricky - must fclose(stdio) to free memory but not close(fd) 3004 Use Sarathy's trick from maint-5.6 to invalidate the 3005 fileno slot of the FILE * 3006 */ 3007 ###### result = PerlIO_flush(f); 3008 ###### saveerr = errno; 3009 ###### if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) { 3010 ###### dupfd = PerlLIO_dup(fd); 3011 } 3012 } 3013 ###### result = PerlSIO_fclose(stdio); 3014 /* We treat error from stdio as success if we invalidated 3015 errno may NOT be expected EBADF 3016 */ 3017 ###### if (invalidate && result != 0) { 3018 ###### errno = saveerr; 3019 ###### result = 0; 3020 } 3021 ###### if (socksfd) { 3022 /* in SOCKS case let close() determine return value */ 3023 ###### result = close(fd); 3024 } 3025 ###### if (dupfd) { 3026 ###### PerlLIO_dup2(dupfd,fd); 3027 ###### PerlLIO_close(dupfd); 3028 } 3029 ###### return result; 3030 } 3031 } 3032 3033 SSize_t 3034 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 3035 ###### { 3036 ###### FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio; 3037 ###### SSize_t got = 0; 3038 ###### for (;;) { 3039 ###### if (count == 1) { 3040 ###### STDCHAR *buf = (STDCHAR *) vbuf; 3041 /* 3042 * Perl is expecting PerlIO_getc() to fill the buffer Linux's 3043 * stdio does not do that for fread() 3044 */ 3045 ###### const int ch = PerlSIO_fgetc(s); 3046 ###### if (ch != EOF) { 3047 ###### *buf = ch; 3048 ###### got = 1; 3049 } 3050 } 3051 else 3052 ###### got = PerlSIO_fread(vbuf, 1, count, s); 3053 ###### if (got == 0 && PerlSIO_ferror(s)) 3054 ###### got = -1; 3055 ###### if (got >= 0 || errno != EINTR) 3056 ###### break; 3057 ###### PERL_ASYNC_CHECK(); 3058 ###### SETERRNO(0,0); /* just in case */ 3059 } 3060 ###### return got; 3061 } 3062 3063 SSize_t 3064 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3065 ###### { 3066 ###### SSize_t unread = 0; 3067 ###### FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio; 3068 3069 #ifdef STDIO_BUFFER_WRITABLE 3070 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 3071 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 3072 STDCHAR *base = PerlIO_get_base(f); 3073 SSize_t cnt = PerlIO_get_cnt(f); 3074 STDCHAR *ptr = PerlIO_get_ptr(f); 3075 SSize_t avail = ptr - base; 3076 if (avail > 0) { 3077 if (avail > count) { 3078 avail = count; 3079 } 3080 ptr -= avail; 3081 Move(buf-avail,ptr,avail,STDCHAR); 3082 count -= avail; 3083 unread += avail; 3084 PerlIO_set_ptrcnt(f,ptr,cnt+avail); 3085 if (PerlSIO_feof(s) && unread >= 0) 3086 PerlSIO_clearerr(s); 3087 } 3088 } 3089 else 3090 #endif 3091 ###### if (PerlIO_has_cntptr(f)) { 3092 /* We can get pointer to buffer but not its base 3093 Do ungetc() but check chars are ending up in the 3094 buffer 3095 */ 3096 ###### STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); 3097 ###### STDCHAR *buf = ((STDCHAR *) vbuf) + count; 3098 ###### while (count > 0) { 3099 ###### const int ch = *--buf & 0xFF; 3100 ###### if (ungetc(ch,s) != ch) { 3101 /* ungetc did not work */ 3102 ###### break; 3103 } 3104 ###### if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { 3105 /* Did not change pointer as expected */ 3106 ###### fgetc(s); /* get char back again */ 3107 ###### break; 3108 } 3109 /* It worked ! */ 3110 ###### count--; 3111 ###### unread++; 3112 } 3113 } 3114 3115 ###### if (count > 0) { 3116 ###### unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 3117 } 3118 ###### return unread; 3119 } 3120 3121 SSize_t 3122 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3123 1 { 3124 1 SSize_t got; 3125 1 for (;;) { 3126 1 got = PerlSIO_fwrite(vbuf, 1, count, 3127 PerlIOSelf(f, PerlIOStdio)->stdio); 3128 1 if (got >= 0 || errno != EINTR) 3129 ###### break; 3130 ###### PERL_ASYNC_CHECK(); 3131 ###### SETERRNO(0,0); /* just in case */ 3132 } 3133 1 return got; 3134 } 3135 3136 IV 3137 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 3138 ###### { 3139 ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3140 ###### return PerlSIO_fseek(stdio, offset, whence); 3141 } 3142 3143 Off_t 3144 PerlIOStdio_tell(pTHX_ PerlIO *f) 3145 ###### { 3146 ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3147 ###### return PerlSIO_ftell(stdio); 3148 } 3149 3150 IV 3151 PerlIOStdio_flush(pTHX_ PerlIO *f) 3152 ###### { 3153 ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3154 ###### if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 3155 ###### return PerlSIO_fflush(stdio); 3156 } 3157 else { 3158 #if 0 3159 /* 3160 * FIXME: This discards ungetc() and pre-read stuff which is not 3161 * right if this is just a "sync" from a layer above Suspect right 3162 * design is to do _this_ but not have layer above flush this 3163 * layer read-to-read 3164 */ 3165 /* 3166 * Not writeable - sync by attempting a seek 3167 */ 3168 int err = errno; 3169 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) 3170 errno = err; 3171 #endif 3172 } 3173 ###### return 0; 3174 } 3175 3176 IV 3177 PerlIOStdio_eof(pTHX_ PerlIO *f) 3178 ###### { 3179 ###### return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio); 3180 } 3181 3182 IV 3183 PerlIOStdio_error(pTHX_ PerlIO *f) 3184 1 { 3185 1 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio); 3186 } 3187 3188 void 3189 PerlIOStdio_clearerr(pTHX_ PerlIO *f) 3190 ###### { 3191 ###### PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio); 3192 } 3193 3194 void 3195 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f) 3196 ###### { 3197 #ifdef HAS_SETLINEBUF 3198 ###### PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio); 3199 #else 3200 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0); 3201 #endif 3202 } 3203 3204 #ifdef FILE_base 3205 STDCHAR * 3206 PerlIOStdio_get_base(pTHX_ PerlIO *f) 3207 { 3208 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3209 return (STDCHAR*)PerlSIO_get_base(stdio); 3210 } 3211 3212 Size_t 3213 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f) 3214 { 3215 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3216 return PerlSIO_get_bufsiz(stdio); 3217 } 3218 #endif 3219 3220 #ifdef USE_STDIO_PTR 3221 STDCHAR * 3222 PerlIOStdio_get_ptr(pTHX_ PerlIO *f) 3223 { 3224 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3225 return (STDCHAR*)PerlSIO_get_ptr(stdio); 3226 } 3227 3228 SSize_t 3229 PerlIOStdio_get_cnt(pTHX_ PerlIO *f) 3230 { 3231 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3232 return PerlSIO_get_cnt(stdio); 3233 } 3234 3235 void 3236 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 3237 { 3238 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3239 if (ptr != NULL) { 3240 #ifdef STDIO_PTR_LVALUE 3241 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */ 3242 #ifdef STDIO_PTR_LVAL_SETS_CNT 3243 if (PerlSIO_get_cnt(stdio) != (cnt)) { 3244 assert(PerlSIO_get_cnt(stdio) == (cnt)); 3245 } 3246 #endif 3247 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) 3248 /* 3249 * Setting ptr _does_ change cnt - we are done 3250 */ 3251 return; 3252 #endif 3253 #else /* STDIO_PTR_LVALUE */ 3254 PerlProc_abort(); 3255 #endif /* STDIO_PTR_LVALUE */ 3256 } 3257 /* 3258 * Now (or only) set cnt 3259 */ 3260 #ifdef STDIO_CNT_LVALUE 3261 PerlSIO_set_cnt(stdio, cnt); 3262 #else /* STDIO_CNT_LVALUE */ 3263 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) 3264 PerlSIO_set_ptr(stdio, 3265 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - 3266 cnt)); 3267 #else /* STDIO_PTR_LVAL_SETS_CNT */ 3268 PerlProc_abort(); 3269 #endif /* STDIO_PTR_LVAL_SETS_CNT */ 3270 #endif /* STDIO_CNT_LVALUE */ 3271 } 3272 3273 3274 #endif 3275 3276 IV 3277 PerlIOStdio_fill(pTHX_ PerlIO *f) 3278 ###### { 3279 ###### FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 3280 ###### int c; 3281 /* 3282 * fflush()ing read-only streams can cause trouble on some stdio-s 3283 */ 3284 ###### if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { 3285 ###### if (PerlSIO_fflush(stdio) != 0) 3286 ###### return EOF; 3287 } 3288 ###### c = PerlSIO_fgetc(stdio); 3289 ###### if (c == EOF) 3290 ###### return EOF; 3291 3292 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) 3293 3294 #ifdef STDIO_BUFFER_WRITABLE 3295 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 3296 /* Fake ungetc() to the real buffer in case system's ungetc 3297 goes elsewhere 3298 */ 3299 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); 3300 SSize_t cnt = PerlSIO_get_cnt(stdio); 3301 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); 3302 if (ptr == base+1) { 3303 *--ptr = (STDCHAR) c; 3304 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); 3305 if (PerlSIO_feof(stdio)) 3306 PerlSIO_clearerr(stdio); 3307 return 0; 3308 } 3309 } 3310 else 3311 #endif 3312 if (PerlIO_has_cntptr(f)) { 3313 STDCHAR ch = c; 3314 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { 3315 return 0; 3316 } 3317 } 3318 #endif 3319 3320 #if defined(VMS) 3321 /* An ungetc()d char is handled separately from the regular 3322 * buffer, so we stuff it in the buffer ourselves. 3323 * Should never get called as should hit code above 3324 */ 3325 *(--((*stdio)->_ptr)) = (unsigned char) c; 3326 (*stdio)->_cnt++; 3327 #else 3328 /* If buffer snoop scheme above fails fall back to 3329 using ungetc(). 3330 */ 3331 ###### if (PerlSIO_ungetc(c, stdio) != c) 3332 ###### return EOF; 3333 #endif 3334 ###### return 0; 3335 } 3336 3337 3338 3339 PERLIO_FUNCS_DECL(PerlIO_stdio) = { 3340 sizeof(PerlIO_funcs), 3341 "stdio", 3342 sizeof(PerlIOStdio), 3343 PERLIO_K_BUFFERED|PERLIO_K_RAW, 3344 PerlIOStdio_pushed, 3345 PerlIOBase_popped, 3346 PerlIOStdio_open, 3347 PerlIOBase_binmode, /* binmode */ 3348 NULL, 3349 PerlIOStdio_fileno, 3350 PerlIOStdio_dup, 3351 PerlIOStdio_read, 3352 PerlIOStdio_unread, 3353 PerlIOStdio_write, 3354 PerlIOStdio_seek, 3355 PerlIOStdio_tell, 3356 PerlIOStdio_close, 3357 PerlIOStdio_flush, 3358 PerlIOStdio_fill, 3359 PerlIOStdio_eof, 3360 PerlIOStdio_error, 3361 PerlIOStdio_clearerr, 3362 PerlIOStdio_setlinebuf, 3363 #ifdef FILE_base 3364 PerlIOStdio_get_base, 3365 PerlIOStdio_get_bufsiz, 3366 #else 3367 NULL, 3368 NULL, 3369 #endif 3370 #ifdef USE_STDIO_PTR 3371 PerlIOStdio_get_ptr, 3372 PerlIOStdio_get_cnt, 3373 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO) 3374 PerlIOStdio_set_ptrcnt, 3375 # else 3376 NULL, 3377 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */ 3378 #else 3379 NULL, 3380 NULL, 3381 NULL, 3382 #endif /* USE_STDIO_PTR */ 3383 }; 3384 3385 /* Note that calls to PerlIO_exportFILE() are reversed using 3386 * PerlIO_releaseFILE(), not importFILE. */ 3387 FILE * 3388 PerlIO_exportFILE(PerlIO * f, const char *mode) 3389 ###### { 3390 dTHX; 3391 ###### FILE *stdio = NULL; 3392 ###### if (PerlIOValid(f)) { 3393 ###### char buf[8]; 3394 ###### PerlIO_flush(f); 3395 ###### if (!mode || !*mode) { 3396 ###### mode = PerlIO_modestr(f, buf); 3397 } 3398 ###### stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); 3399 ###### if (stdio) { 3400 ###### PerlIOl *l = *f; 3401 ###### PerlIO *f2; 3402 /* De-link any lower layers so new :stdio sticks */ 3403 ###### *f = NULL; 3404 ###### if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, Nullsv))) { 3405 ###### PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); 3406 ###### s->stdio = stdio; 3407 /* Link previous lower layers under new one */ 3408 ###### *PerlIONext(f) = l; 3409 } 3410 else { 3411 /* restore layers list */ 3412 ###### *f = l; 3413 } 3414 } 3415 } 3416 ###### return stdio; 3417 } 3418 3419 3420 FILE * 3421 PerlIO_findFILE(PerlIO *f) 3422 2 { 3423 2 PerlIOl *l = *f; 3424 2 while (l) { 3425 2 if (l->tab == &PerlIO_stdio) { 3426 2 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3427 2 return s->stdio; 3428 } 3429 ###### l = *PerlIONext(&l); 3430 } 3431 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ 3432 ###### return PerlIO_exportFILE(f, Nullch); 3433 } 3434 3435 /* Use this to reverse PerlIO_exportFILE calls. */ 3436 void 3437 PerlIO_releaseFILE(PerlIO *p, FILE *f) 3438 1 { 3439 dVAR; 3440 1 PerlIOl *l; 3441 1 while ((l = *p)) { 3442 1 if (l->tab == &PerlIO_stdio) { 3443 1 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3444 1 if (s->stdio == f) { 3445 dTHX; 3446 1 PerlIO_pop(aTHX_ p); 3447 1 return; 3448 } 3449 } 3450 ###### p = PerlIONext(p); 3451 } 3452 1 return; 3453 } 3454 3455 /*--------------------------------------------------------------------------------------*/ 3456 /* 3457 * perlio buffer layer 3458 */ 3459 3460 IV 3461 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 3462 77887 { 3463 77887 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3464 77887 const int fd = PerlIO_fileno(f); 3465 77887 if (fd >= 0 && PerlLIO_isatty(fd)) { 3466 9041 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; 3467 } 3468 77887 if (*PerlIONext(f)) { 3469 77887 const Off_t posn = PerlIO_tell(PerlIONext(f)); 3470 77887 if (posn != (Off_t) - 1) { 3471 57982 b->posn = posn; 3472 } 3473 } 3474 77887 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 3475 } 3476 3477 PerlIO * 3478 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 3479 IV n, const char *mode, int fd, int imode, int perm, 3480 PerlIO *f, int narg, SV **args) 3481 83286 { 3482 83286 if (PerlIOValid(f)) { 3483 ###### PerlIO *next = PerlIONext(f); 3484 ###### PerlIO_funcs *tab = 3485 ###### PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); 3486 ###### if (tab && tab->Open) 3487 ###### next = 3488 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3489 next, narg, args); 3490 ###### if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { 3491 ###### return NULL; 3492 } 3493 } 3494 else { 3495 83286 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); 3496 83286 int init = 0; 3497 83286 if (*mode == IoTYPE_IMPLICIT) { 3498 13509 init = 1; 3499 /* 3500 * mode++; 3501 */ 3502 } 3503 83286 if (tab && tab->Open) 3504 83286 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3505 f, narg, args); 3506 else 3507 ###### SETERRNO(EINVAL, LIB_INVARG); 3508 83286 if (f) { 3509 76355 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { 3510 /* 3511 * if push fails during open, open fails. close will pop us. 3512 */ 3513 2 PerlIO_close (f); 3514 2 return NULL; 3515 } else { 3516 76353 fd = PerlIO_fileno(f); 3517 76353 if (init && fd == 2) { 3518 /* 3519 * Initial stderr is unbuffered 3520 */ 3521 4503 PerlIOBase(f)->flags |= PERLIO_F_UNBUF; 3522 } 3523 #ifdef PERLIO_USING_CRLF 3524 # ifdef PERLIO_IS_BINMODE_FD 3525 if (PERLIO_IS_BINMODE_FD(fd)) 3526 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch); 3527 else 3528 # endif 3529 /* 3530 * do something about failing setmode()? --jhi 3531 */ 3532 PerlLIO_setmode(fd, O_BINARY); 3533 #endif 3534 } 3535 } 3536 } 3537 83284 return f; 3538 } 3539 3540 /* 3541 * This "flush" is akin to sfio's sync in that it handles files in either 3542 * read or write state 3543 */ 3544 IV 3545 PerlIOBuf_flush(pTHX_ PerlIO *f) 3546 550364 { 3547 550364 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3548 550364 int code = 0; 3549 550364 PerlIO *n = PerlIONext(f); 3550 550364 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { 3551 /* 3552 * write() the buffer 3553 */ 3554 146033 const STDCHAR *buf = b->buf; 3555 146033 const STDCHAR *p = buf; 3556 292063 while (p < b->ptr) { 3557 146033 SSize_t count = PerlIO_write(n, p, b->ptr - p); 3558 146033 if (count > 0) { 3559 146030 p += count; 3560 } 3561 3 else if (count < 0 || PerlIO_error(n)) { 3562 3 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 3563 3 code = -1; 3564 break; 3565 } 3566 } 3567 146033 b->posn += (p - buf); 3568 } 3569 404331 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 3570 288657 STDCHAR *buf = PerlIO_get_base(f); 3571 /* 3572 * Note position change 3573 */ 3574 288657 b->posn += (b->ptr - buf); 3575 288657 if (b->ptr < b->end) { 3576 /* We did not consume all of it - try and seek downstream to 3577 our logical position 3578 */ 3579