perlio.c

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