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