perlio.c

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