perlio.c

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