perlio.c

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