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