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