perlio.c

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