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