perlio.c

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