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