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