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