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