perlio.c

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