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