perlio.c

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