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    = get_cvs("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         if(stdio) {
3037             PerlIOUnix_refcnt_inc(fileno(stdio));
3038         }
3039     }
3040     return f;
3041 }
3042
3043 static int
3044 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3045 {
3046     PERL_UNUSED_CONTEXT;
3047
3048     /* XXX this could use PerlIO_canset_fileno() and
3049      * PerlIO_set_fileno() support from Configure
3050      */
3051 #  if defined(__UCLIBC__)
3052     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3053     f->__filedes = -1;
3054     return 1;
3055 #  elif defined(__GLIBC__)
3056     /* There may be a better way for GLIBC:
3057         - libio.h defines a flag to not close() on cleanup
3058      */
3059     f->_fileno = -1;
3060     return 1;
3061 #  elif defined(__sun__)
3062     PERL_UNUSED_ARG(f);
3063     return 0;
3064 #  elif defined(__hpux)
3065     f->__fileH = 0xff;
3066     f->__fileL = 0xff;
3067     return 1;
3068    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3069       your platform does not have special entry try this one.
3070       [For OSF only have confirmation for Tru64 (alpha)
3071       but assume other OSFs will be similar.]
3072     */
3073 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3074     f->_file = -1;
3075     return 1;
3076 #  elif defined(__FreeBSD__)
3077     /* There may be a better way on FreeBSD:
3078         - we could insert a dummy func in the _close function entry
3079         f->_close = (int (*)(void *)) dummy_close;
3080      */
3081     f->_file = -1;
3082     return 1;
3083 #  elif defined(__OpenBSD__)
3084     /* There may be a better way on OpenBSD:
3085         - we could insert a dummy func in the _close function entry
3086         f->_close = (int (*)(void *)) dummy_close;
3087      */
3088     f->_file = -1;
3089     return 1;
3090 #  elif defined(__EMX__)
3091     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3092     f->_handle = -1;
3093     return 1;
3094 #  elif defined(__CYGWIN__)
3095     /* There may be a better way on CYGWIN:
3096         - we could insert a dummy func in the _close function entry
3097         f->_close = (int (*)(void *)) dummy_close;
3098      */
3099     f->_file = -1;
3100     return 1;
3101 #  elif defined(WIN32)
3102 #    if defined(__BORLANDC__)
3103     f->fd = PerlLIO_dup(fileno(f));
3104 #    elif defined(UNDER_CE)
3105     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3106        structure at all
3107      */
3108 #    else
3109     f->_file = -1;
3110 #    endif
3111     return 1;
3112 #  else
3113 #if 0
3114     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3115        (which isn't thread safe) instead
3116      */
3117 #    error "Don't know how to set FILE.fileno on your platform"
3118 #endif
3119     PERL_UNUSED_ARG(f);
3120     return 0;
3121 #  endif
3122 }
3123
3124 IV
3125 PerlIOStdio_close(pTHX_ PerlIO *f)
3126 {
3127     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3128     if (!stdio) {
3129         errno = EBADF;
3130         return -1;
3131     }
3132     else {
3133         const int fd = fileno(stdio);
3134         int invalidate = 0;
3135         IV result = 0;
3136         int dupfd = -1;
3137         dSAVEDERRNO;
3138 #ifdef USE_ITHREADS
3139         dVAR;
3140 #endif
3141 #ifdef SOCKS5_VERSION_NAME
3142         /* Socks lib overrides close() but stdio isn't linked to
3143            that library (though we are) - so we must call close()
3144            on sockets on stdio's behalf.
3145          */
3146         int optval;
3147         Sock_size_t optlen = sizeof(int);
3148         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3149             invalidate = 1;
3150 #endif
3151         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3152            that a subsequent fileno() on it returns -1. Don't want to croak()
3153            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3154            trying to close an already closed handle which somehow it still has
3155            a reference to. (via.xs, I'm looking at you).  */
3156         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3157             /* File descriptor still in use */
3158             invalidate = 1;
3159         }
3160         if (invalidate) {
3161             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3162             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3163                 return 0;
3164             if (stdio == stdout || stdio == stderr)
3165                 return PerlIO_flush(f);
3166             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3167                Use Sarathy's trick from maint-5.6 to invalidate the
3168                fileno slot of the FILE *
3169             */
3170             result = PerlIO_flush(f);
3171             SAVE_ERRNO;
3172             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3173             if (!invalidate) {
3174 #ifdef USE_ITHREADS
3175                 MUTEX_LOCK(&PL_perlio_mutex);
3176                 /* Right. We need a mutex here because for a brief while we
3177                    will have the situation that fd is actually closed. Hence if
3178                    a second thread were to get into this block, its dup() would
3179                    likely return our fd as its dupfd. (after all, it is closed)
3180                    Then if we get to the dup2() first, we blat the fd back
3181                    (messing up its temporary as a side effect) only for it to
3182                    then close its dupfd (== our fd) in its close(dupfd) */
3183
3184                 /* There is, of course, a race condition, that any other thread
3185                    trying to input/output/whatever on this fd will be stuffed
3186                    for the duration of this little manoeuvrer. Perhaps we
3187                    should hold an IO mutex for the duration of every IO
3188                    operation if we know that invalidate doesn't work on this
3189                    platform, but that would suck, and could kill performance.
3190
3191                    Except that correctness trumps speed.
3192                    Advice from klortho #11912. */
3193 #endif
3194                 dupfd = PerlLIO_dup(fd);
3195 #ifdef USE_ITHREADS
3196                 if (dupfd < 0) {
3197                     MUTEX_UNLOCK(&PL_perlio_mutex);
3198                     /* Oh cXap. This isn't going to go well. Not sure if we can
3199                        recover from here, or if closing this particular FILE *
3200                        is a good idea now.  */
3201                 }
3202 #endif
3203             }
3204         } else {
3205             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3206         }
3207         result = PerlSIO_fclose(stdio);
3208         /* We treat error from stdio as success if we invalidated
3209            errno may NOT be expected EBADF
3210          */
3211         if (invalidate && result != 0) {
3212             RESTORE_ERRNO;
3213             result = 0;
3214         }
3215 #ifdef SOCKS5_VERSION_NAME
3216         /* in SOCKS' case, let close() determine return value */
3217         result = close(fd);
3218 #endif
3219         if (dupfd >= 0) {
3220             PerlLIO_dup2(dupfd,fd);
3221             PerlLIO_close(dupfd);
3222 #ifdef USE_ITHREADS
3223             MUTEX_UNLOCK(&PL_perlio_mutex);
3224 #endif
3225         }
3226         return result;
3227     }
3228 }
3229
3230 SSize_t
3231 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3232 {
3233     dVAR;
3234     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3235     SSize_t got = 0;
3236     for (;;) {
3237         if (count == 1) {
3238             STDCHAR *buf = (STDCHAR *) vbuf;
3239             /*
3240              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3241              * stdio does not do that for fread()
3242              */
3243             const int ch = PerlSIO_fgetc(s);
3244             if (ch != EOF) {
3245                 *buf = ch;
3246                 got = 1;
3247             }
3248         }
3249         else
3250             got = PerlSIO_fread(vbuf, 1, count, s);
3251         if (got == 0 && PerlSIO_ferror(s))
3252             got = -1;
3253         if (got >= 0 || errno != EINTR)
3254             break;
3255         PERL_ASYNC_CHECK();
3256         SETERRNO(0,0);  /* just in case */
3257     }
3258     return got;
3259 }
3260
3261 SSize_t
3262 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3263 {
3264     SSize_t unread = 0;
3265     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3266
3267 #ifdef STDIO_BUFFER_WRITABLE
3268     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3269         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3270         STDCHAR *base = PerlIO_get_base(f);
3271         SSize_t cnt   = PerlIO_get_cnt(f);
3272         STDCHAR *ptr  = PerlIO_get_ptr(f);
3273         SSize_t avail = ptr - base;
3274         if (avail > 0) {
3275             if (avail > count) {
3276                 avail = count;
3277             }
3278             ptr -= avail;
3279             Move(buf-avail,ptr,avail,STDCHAR);
3280             count -= avail;
3281             unread += avail;
3282             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3283             if (PerlSIO_feof(s) && unread >= 0)
3284                 PerlSIO_clearerr(s);
3285         }
3286     }
3287     else
3288 #endif
3289     if (PerlIO_has_cntptr(f)) {
3290         /* We can get pointer to buffer but not its base
3291            Do ungetc() but check chars are ending up in the
3292            buffer
3293          */
3294         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3295         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3296         while (count > 0) {
3297             const int ch = *--buf & 0xFF;
3298             if (ungetc(ch,s) != ch) {
3299                 /* ungetc did not work */
3300                 break;
3301             }
3302             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3303                 /* Did not change pointer as expected */
3304                 fgetc(s);  /* get char back again */
3305                 break;
3306             }
3307             /* It worked ! */
3308             count--;
3309             unread++;
3310         }
3311     }
3312
3313     if (count > 0) {
3314         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3315     }
3316     return unread;
3317 }
3318
3319 SSize_t
3320 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3321 {
3322     dVAR;
3323     SSize_t got;
3324     for (;;) {
3325         got = PerlSIO_fwrite(vbuf, 1, count,
3326                               PerlIOSelf(f, PerlIOStdio)->stdio);
3327         if (got >= 0 || errno != EINTR)
3328             break;
3329         PERL_ASYNC_CHECK();
3330         SETERRNO(0,0);  /* just in case */
3331     }
3332     return got;
3333 }
3334
3335 IV
3336 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3337 {
3338     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3339     PERL_UNUSED_CONTEXT;
3340
3341     return PerlSIO_fseek(stdio, offset, whence);
3342 }
3343
3344 Off_t
3345 PerlIOStdio_tell(pTHX_ PerlIO *f)
3346 {
3347     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3348     PERL_UNUSED_CONTEXT;
3349
3350     return PerlSIO_ftell(stdio);
3351 }
3352
3353 IV
3354 PerlIOStdio_flush(pTHX_ PerlIO *f)
3355 {
3356     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3357     PERL_UNUSED_CONTEXT;
3358
3359     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3360         return PerlSIO_fflush(stdio);
3361     }
3362     else {
3363         NOOP;
3364 #if 0
3365         /*
3366          * FIXME: This discards ungetc() and pre-read stuff which is not
3367          * right if this is just a "sync" from a layer above Suspect right
3368          * design is to do _this_ but not have layer above flush this
3369          * layer read-to-read
3370          */
3371         /*
3372          * Not writeable - sync by attempting a seek
3373          */
3374         dSAVE_ERRNO;
3375         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3376             RESTORE_ERRNO;
3377 #endif
3378     }
3379     return 0;
3380 }
3381
3382 IV
3383 PerlIOStdio_eof(pTHX_ PerlIO *f)
3384 {
3385     PERL_UNUSED_CONTEXT;
3386
3387     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3388 }
3389
3390 IV
3391 PerlIOStdio_error(pTHX_ PerlIO *f)
3392 {
3393     PERL_UNUSED_CONTEXT;
3394
3395     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3396 }
3397
3398 void
3399 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3400 {
3401     PERL_UNUSED_CONTEXT;
3402
3403     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3404 }
3405
3406 void
3407 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3408 {
3409     PERL_UNUSED_CONTEXT;
3410
3411 #ifdef HAS_SETLINEBUF
3412     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3413 #else
3414     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3415 #endif
3416 }
3417
3418 #ifdef FILE_base
3419 STDCHAR *
3420 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3421 {
3422     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3423     return (STDCHAR*)PerlSIO_get_base(stdio);
3424 }
3425
3426 Size_t
3427 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3428 {
3429     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3430     return PerlSIO_get_bufsiz(stdio);
3431 }
3432 #endif
3433
3434 #ifdef USE_STDIO_PTR
3435 STDCHAR *
3436 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3437 {
3438     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3439     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3440 }
3441
3442 SSize_t
3443 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3444 {
3445     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3446     return PerlSIO_get_cnt(stdio);
3447 }
3448
3449 void
3450 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3451 {
3452     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3453     if (ptr != NULL) {
3454 #ifdef STDIO_PTR_LVALUE
3455         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3456 #ifdef STDIO_PTR_LVAL_SETS_CNT
3457         assert(PerlSIO_get_cnt(stdio) == (cnt));
3458 #endif
3459 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3460         /*
3461          * Setting ptr _does_ change cnt - we are done
3462          */
3463         return;
3464 #endif
3465 #else                           /* STDIO_PTR_LVALUE */
3466         PerlProc_abort();
3467 #endif                          /* STDIO_PTR_LVALUE */
3468     }
3469     /*
3470      * Now (or only) set cnt
3471      */
3472 #ifdef STDIO_CNT_LVALUE
3473     PerlSIO_set_cnt(stdio, cnt);
3474 #else                           /* STDIO_CNT_LVALUE */
3475 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3476     PerlSIO_set_ptr(stdio,
3477                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3478                                               cnt));
3479 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3480     PerlProc_abort();
3481 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3482 #endif                          /* STDIO_CNT_LVALUE */
3483 }
3484
3485
3486 #endif
3487
3488 IV
3489 PerlIOStdio_fill(pTHX_ PerlIO *f)
3490 {
3491     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3492     int c;
3493     PERL_UNUSED_CONTEXT;
3494
3495     /*
3496      * fflush()ing read-only streams can cause trouble on some stdio-s
3497      */
3498     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3499         if (PerlSIO_fflush(stdio) != 0)
3500             return EOF;
3501     }
3502     for (;;) {
3503         c = PerlSIO_fgetc(stdio);
3504         if (c != EOF)
3505             break;
3506         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3507             return EOF;
3508         PERL_ASYNC_CHECK();
3509         SETERRNO(0,0);
3510     }
3511
3512 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3513
3514 #ifdef STDIO_BUFFER_WRITABLE
3515     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3516         /* Fake ungetc() to the real buffer in case system's ungetc
3517            goes elsewhere
3518          */
3519         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3520         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3521         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3522         if (ptr == base+1) {
3523             *--ptr = (STDCHAR) c;
3524             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3525             if (PerlSIO_feof(stdio))
3526                 PerlSIO_clearerr(stdio);
3527             return 0;
3528         }
3529     }
3530     else
3531 #endif
3532     if (PerlIO_has_cntptr(f)) {
3533         STDCHAR ch = c;
3534         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3535             return 0;
3536         }
3537     }
3538 #endif
3539
3540 #if defined(VMS)
3541     /* An ungetc()d char is handled separately from the regular
3542      * buffer, so we stuff it in the buffer ourselves.
3543      * Should never get called as should hit code above
3544      */
3545     *(--((*stdio)->_ptr)) = (unsigned char) c;
3546     (*stdio)->_cnt++;
3547 #else
3548     /* If buffer snoop scheme above fails fall back to
3549        using ungetc().
3550      */
3551     if (PerlSIO_ungetc(c, stdio) != c)
3552         return EOF;
3553 #endif
3554     return 0;
3555 }
3556
3557
3558
3559 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3560     sizeof(PerlIO_funcs),
3561     "stdio",
3562     sizeof(PerlIOStdio),
3563     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3564     PerlIOStdio_pushed,
3565     PerlIOBase_popped,
3566     PerlIOStdio_open,
3567     PerlIOBase_binmode,         /* binmode */
3568     NULL,
3569     PerlIOStdio_fileno,
3570     PerlIOStdio_dup,
3571     PerlIOStdio_read,
3572     PerlIOStdio_unread,
3573     PerlIOStdio_write,
3574     PerlIOStdio_seek,
3575     PerlIOStdio_tell,
3576     PerlIOStdio_close,
3577     PerlIOStdio_flush,
3578     PerlIOStdio_fill,
3579     PerlIOStdio_eof,
3580     PerlIOStdio_error,
3581     PerlIOStdio_clearerr,
3582     PerlIOStdio_setlinebuf,
3583 #ifdef FILE_base
3584     PerlIOStdio_get_base,
3585     PerlIOStdio_get_bufsiz,
3586 #else
3587     NULL,
3588     NULL,
3589 #endif
3590 #ifdef USE_STDIO_PTR
3591     PerlIOStdio_get_ptr,
3592     PerlIOStdio_get_cnt,
3593 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3594     PerlIOStdio_set_ptrcnt,
3595 #   else
3596     NULL,
3597 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3598 #else
3599     NULL,
3600     NULL,
3601     NULL,
3602 #endif /* USE_STDIO_PTR */
3603 };
3604
3605 /* Note that calls to PerlIO_exportFILE() are reversed using
3606  * PerlIO_releaseFILE(), not importFILE. */
3607 FILE *
3608 PerlIO_exportFILE(PerlIO * f, const char *mode)
3609 {
3610     dTHX;
3611     FILE *stdio = NULL;
3612     if (PerlIOValid(f)) {
3613         char buf[8];
3614         PerlIO_flush(f);
3615         if (!mode || !*mode) {
3616             mode = PerlIO_modestr(f, buf);
3617         }
3618         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3619         if (stdio) {
3620             PerlIOl *l = *f;
3621             PerlIO *f2;
3622             /* De-link any lower layers so new :stdio sticks */
3623             *f = NULL;
3624             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3625                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3626                 s->stdio = stdio;
3627                 PerlIOUnix_refcnt_inc(fileno(stdio));
3628                 /* Link previous lower layers under new one */
3629                 *PerlIONext(f) = l;
3630             }
3631             else {
3632                 /* restore layers list */
3633                 *f = l;
3634             }
3635         }
3636     }
3637     return stdio;
3638 }
3639
3640
3641 FILE *
3642 PerlIO_findFILE(PerlIO *f)
3643 {
3644     PerlIOl *l = *f;
3645     FILE *stdio;
3646     while (l) {
3647         if (l->tab == &PerlIO_stdio) {
3648             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3649             return s->stdio;
3650         }
3651         l = *PerlIONext(&l);
3652     }
3653     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3654     /* However, we're not really exporting a FILE * to someone else (who
3655        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3656        So we need to undo its refernce count increase on the underlying file
3657        descriptor. We have to do this, because if the loop above returns you
3658        the FILE *, then *it* didn't increase any reference count. So there's
3659        only one way to be consistent. */
3660     stdio = PerlIO_exportFILE(f, NULL);
3661     if (stdio) {
3662         const int fd = fileno(stdio);
3663         if (fd >= 0)
3664             PerlIOUnix_refcnt_dec(fd);
3665     }
3666     return stdio;
3667 }
3668
3669 /* Use this to reverse PerlIO_exportFILE calls. */
3670 void
3671 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3672 {
3673     dVAR;
3674     PerlIOl *l;
3675     while ((l = *p)) {
3676         if (l->tab == &PerlIO_stdio) {
3677             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3678             if (s->stdio == f) {
3679                 dTHX;
3680                 const int fd = fileno(f);
3681                 if (fd >= 0)
3682                     PerlIOUnix_refcnt_dec(fd);
3683                 PerlIO_pop(aTHX_ p);
3684                 return;
3685             }
3686         }
3687         p = PerlIONext(p);
3688     }
3689     return;
3690 }
3691
3692 /*--------------------------------------------------------------------------------------*/
3693 /*
3694  * perlio buffer layer
3695  */
3696
3697 IV
3698 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3699 {
3700     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3701     const int fd = PerlIO_fileno(f);
3702     if (fd >= 0 && PerlLIO_isatty(fd)) {
3703         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3704     }
3705     if (*PerlIONext(f)) {
3706         const Off_t posn = PerlIO_tell(PerlIONext(f));
3707         if (posn != (Off_t) - 1) {
3708             b->posn = posn;
3709         }
3710     }
3711     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3712 }
3713
3714 PerlIO *
3715 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3716                IV n, const char *mode, int fd, int imode, int perm,
3717                PerlIO *f, int narg, SV **args)
3718 {
3719     if (PerlIOValid(f)) {
3720         PerlIO *next = PerlIONext(f);
3721         PerlIO_funcs *tab =
3722              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3723         if (tab && tab->Open)
3724              next =
3725                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3726                                next, narg, args);
3727         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3728             return NULL;
3729         }
3730     }
3731     else {
3732         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3733         int init = 0;
3734         if (*mode == IoTYPE_IMPLICIT) {
3735             init = 1;
3736             /*
3737              * mode++;
3738              */
3739         }
3740         if (tab && tab->Open)
3741              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3742                               f, narg, args);
3743         else
3744              SETERRNO(EINVAL, LIB_INVARG);
3745         if (f) {
3746             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3747                 /*
3748                  * if push fails during open, open fails. close will pop us.
3749                  */
3750                 PerlIO_close (f);
3751                 return NULL;
3752             } else {
3753                 fd = PerlIO_fileno(f);
3754                 if (init && fd == 2) {
3755                     /*
3756                      * Initial stderr is unbuffered
3757                      */
3758                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3759                 }
3760 #ifdef PERLIO_USING_CRLF
3761 #  ifdef PERLIO_IS_BINMODE_FD
3762                 if (PERLIO_IS_BINMODE_FD(fd))
3763                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3764                 else
3765 #  endif
3766                 /*
3767                  * do something about failing setmode()? --jhi
3768                  */
3769                 PerlLIO_setmode(fd, O_BINARY);
3770 #endif
3771             }
3772         }
3773     }
3774     return f;
3775 }
3776
3777 /*
3778  * This "flush" is akin to sfio's sync in that it handles files in either
3779  * read or write state.  For write state, we put the postponed data through
3780  * the next layers.  For read state, we seek() the next layers to the
3781  * offset given by current position in the buffer, and discard the buffer
3782  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3783  * in any case?).  Then the pass the stick further in chain.
3784  */
3785 IV
3786 PerlIOBuf_flush(pTHX_ PerlIO *f)
3787 {
3788     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3789     int code = 0;
3790     PerlIO *n = PerlIONext(f);
3791     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3792         /*
3793          * write() the buffer
3794          */
3795         const STDCHAR *buf = b->buf;
3796         const STDCHAR *p = buf;
3797         while (p < b->ptr) {
3798             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3799             if (count > 0) {
3800                 p += count;
3801             }
3802             else if (count < 0 || PerlIO_error(n)) {
3803                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3804                 code = -1;
3805                 break;
3806             }
3807         }
3808         b->posn += (p - buf);
3809     }
3810     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3811         STDCHAR *buf = PerlIO_get_base(f);
3812         /*
3813          * Note position change
3814          */
3815         b->posn += (b->ptr - buf);
3816         if (b->ptr < b->end) {
3817             /* We did not consume all of it - try and seek downstream to
3818                our logical position
3819              */
3820             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3821                 /* Reload n as some layers may pop themselves on seek */
3822                 b->posn = PerlIO_tell(n = PerlIONext(f));
3823             }
3824             else {
3825                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3826                    data is lost for good - so return saying "ok" having undone
3827                    the position adjust
3828                  */
3829                 b->posn -= (b->ptr - buf);
3830                 return code;
3831             }
3832         }
3833     }
3834     b->ptr = b->end = b->buf;
3835     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3836     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3837     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3838         code = -1;
3839     return code;
3840 }
3841
3842 /* This discards the content of the buffer after b->ptr, and rereads
3843  * the buffer from the position off in the layer downstream; here off
3844  * is at offset corresponding to b->ptr - b->buf.
3845  */
3846 IV
3847 PerlIOBuf_fill(pTHX_ PerlIO *f)
3848 {
3849     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3850     PerlIO *n = PerlIONext(f);
3851     SSize_t avail;
3852     /*
3853      * Down-stream flush is defined not to loose read data so is harmless.
3854      * we would not normally be fill'ing if there was data left in anycase.
3855      */
3856     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
3857         return -1;
3858     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3859         PerlIOBase_flush_linebuf(aTHX);
3860
3861     if (!b->buf)
3862         PerlIO_get_base(f);     /* allocate via vtable */
3863
3864     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3865
3866     b->ptr = b->end = b->buf;
3867
3868     if (!PerlIOValid(n)) {
3869         PerlIOBase(f)->flags |= PERLIO_F_EOF;
3870         return -1;
3871     }
3872
3873     if (PerlIO_fast_gets(n)) {
3874         /*
3875          * Layer below is also buffered. We do _NOT_ want to call its
3876          * ->Read() because that will loop till it gets what we asked for
3877          * which may hang on a pipe etc. Instead take anything it has to
3878          * hand, or ask it to fill _once_.
3879          */
3880         avail = PerlIO_get_cnt(n);
3881         if (avail <= 0) {
3882             avail = PerlIO_fill(n);
3883             if (avail == 0)
3884                 avail = PerlIO_get_cnt(n);
3885             else {
3886                 if (!PerlIO_error(n) && PerlIO_eof(n))
3887                     avail = 0;
3888             }
3889         }
3890         if (avail > 0) {
3891             STDCHAR *ptr = PerlIO_get_ptr(n);
3892             const SSize_t cnt = avail;
3893             if (avail > (SSize_t)b->bufsiz)
3894                 avail = b->bufsiz;
3895             Copy(ptr, b->buf, avail, STDCHAR);
3896             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3897         }
3898     }
3899     else {
3900         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3901     }
3902     if (avail <= 0) {
3903         if (avail == 0)
3904             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3905         else
3906             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3907         return -1;
3908     }
3909     b->end = b->buf + avail;
3910     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3911     return 0;
3912 }
3913
3914 SSize_t
3915 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3916 {
3917     if (PerlIOValid(f)) {
3918         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3919         if (!b->ptr)
3920             PerlIO_get_base(f);
3921         return PerlIOBase_read(aTHX_ f, vbuf, count);
3922     }
3923     return 0;
3924 }
3925
3926 SSize_t
3927 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3928 {
3929     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3930     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3931     SSize_t unread = 0;
3932     SSize_t avail;
3933     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3934         PerlIO_flush(f);
3935     if (!b->buf)
3936         PerlIO_get_base(f);
3937     if (b->buf) {
3938         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3939             /*
3940              * Buffer is already a read buffer, we can overwrite any chars
3941              * which have been read back to buffer start
3942              */
3943             avail = (b->ptr - b->buf);
3944         }
3945         else {
3946             /*
3947              * Buffer is idle, set it up so whole buffer is available for
3948              * unread
3949              */
3950             avail = b->bufsiz;
3951             b->end = b->buf + avail;
3952             b->ptr = b->end;
3953             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3954             /*
3955              * Buffer extends _back_ from where we are now
3956              */
3957             b->posn -= b->bufsiz;
3958         }
3959         if (avail > (SSize_t) count) {
3960             /*
3961              * If we have space for more than count, just move count
3962              */
3963             avail = count;
3964         }
3965         if (avail > 0) {
3966             b->ptr -= avail;
3967             buf -= avail;
3968             /*
3969              * In simple stdio-like ungetc() case chars will be already
3970              * there
3971              */
3972             if (buf != b->ptr) {
3973                 Copy(buf, b->ptr, avail, STDCHAR);
3974             }
3975             count -= avail;
3976             unread += avail;
3977             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3978         }
3979     }
3980     if (count > 0) {
3981         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3982     }
3983     return unread;
3984 }
3985
3986 SSize_t
3987 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3988 {
3989     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3990     const STDCHAR *buf = (const STDCHAR *) vbuf;
3991     const STDCHAR *flushptr = buf;
3992     Size_t written = 0;
3993     if (!b->buf)
3994         PerlIO_get_base(f);
3995     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3996         return 0;
3997     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3998         if (PerlIO_flush(f) != 0) {
3999             return 0;
4000         }
4001     }
4002     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4003         flushptr = buf + count;
4004         while (flushptr > buf && *(flushptr - 1) != '\n')
4005             --flushptr;
4006     }
4007     while (count > 0) {
4008         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4009         if ((SSize_t) count < avail)
4010             avail = count;
4011         if (flushptr > buf && flushptr <= buf + avail)
4012             avail = flushptr - buf;
4013         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4014         if (avail) {
4015             Copy(buf, b->ptr, avail, STDCHAR);
4016             count -= avail;
4017             buf += avail;
4018             written += avail;
4019             b->ptr += avail;
4020             if (buf == flushptr)
4021                 PerlIO_flush(f);
4022         }
4023         if (b->ptr >= (b->buf + b->bufsiz))
4024             PerlIO_flush(f);
4025     }
4026     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4027         PerlIO_flush(f);
4028     return written;
4029 }
4030
4031 IV
4032 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4033 {
4034     IV code;
4035     if ((code = PerlIO_flush(f)) == 0) {
4036         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4037         code = PerlIO_seek(PerlIONext(f), offset, whence);
4038         if (code == 0) {
4039             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4040             b->posn = PerlIO_tell(PerlIONext(f));
4041         }
4042     }
4043     return code;
4044 }
4045
4046 Off_t
4047 PerlIOBuf_tell(pTHX_ PerlIO *f)
4048 {
4049     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4050     /*
4051      * b->posn is file position where b->buf was read, or will be written
4052      */
4053     Off_t posn = b->posn;
4054     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4055         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4056 #if 1
4057         /* As O_APPEND files are normally shared in some sense it is better
4058            to flush :
4059          */
4060         PerlIO_flush(f);
4061 #else
4062         /* when file is NOT shared then this is sufficient */
4063         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4064 #endif
4065         posn = b->posn = PerlIO_tell(PerlIONext(f));
4066     }
4067     if (b->buf) {
4068         /*
4069          * If buffer is valid adjust position by amount in buffer
4070          */
4071         posn += (b->ptr - b->buf);
4072     }
4073     return posn;
4074 }
4075
4076 IV
4077 PerlIOBuf_popped(pTHX_ PerlIO *f)
4078 {
4079     const IV code = PerlIOBase_popped(aTHX_ f);
4080     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4081     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4082         Safefree(b->buf);
4083     }
4084     b->ptr = b->end = b->buf = NULL;
4085     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4086     return code;
4087 }
4088
4089 IV
4090 PerlIOBuf_close(pTHX_ PerlIO *f)
4091 {
4092     const IV code = PerlIOBase_close(aTHX_ f);
4093     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4094     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4095         Safefree(b->buf);
4096     }
4097     b->ptr = b->end = b->buf = NULL;
4098     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4099     return code;
4100 }
4101
4102 STDCHAR *
4103 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4104 {
4105     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4106     if (!b->buf)
4107         PerlIO_get_base(f);
4108     return b->ptr;
4109 }
4110
4111 SSize_t
4112 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4113 {
4114     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4115     if (!b->buf)
4116         PerlIO_get_base(f);
4117     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4118         return (b->end - b->ptr);
4119     return 0;
4120 }
4121
4122 STDCHAR *
4123 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4124 {
4125     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4126     PERL_UNUSED_CONTEXT;
4127
4128     if (!b->buf) {
4129         if (!b->bufsiz)
4130             b->bufsiz = 4096;
4131         b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4132         if (!b->buf) {
4133             b->buf = (STDCHAR *) & b->oneword;
4134             b->bufsiz = sizeof(b->oneword);
4135         }
4136         b->end = b->ptr = b->buf;
4137     }
4138     return b->buf;
4139 }
4140
4141 Size_t
4142 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4143 {
4144     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4145     if (!b->buf)
4146         PerlIO_get_base(f);
4147     return (b->end - b->buf);
4148 }
4149
4150 void
4151 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4152 {
4153     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4154 #ifndef DEBUGGING
4155     PERL_UNUSED_ARG(cnt);
4156 #endif
4157     if (!b->buf)
4158         PerlIO_get_base(f);
4159     b->ptr = ptr;
4160     assert(PerlIO_get_cnt(f) == cnt);
4161     assert(b->ptr >= b->buf);
4162     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4163 }
4164
4165 PerlIO *
4166 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4167 {
4168  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4169 }
4170
4171
4172
4173 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4174     sizeof(PerlIO_funcs),
4175     "perlio",
4176     sizeof(PerlIOBuf),
4177     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4178     PerlIOBuf_pushed,
4179     PerlIOBuf_popped,
4180     PerlIOBuf_open,
4181     PerlIOBase_binmode,         /* binmode */
4182     NULL,
4183     PerlIOBase_fileno,
4184     PerlIOBuf_dup,
4185     PerlIOBuf_read,
4186     PerlIOBuf_unread,
4187     PerlIOBuf_write,
4188     PerlIOBuf_seek,
4189     PerlIOBuf_tell,
4190     PerlIOBuf_close,
4191     PerlIOBuf_flush,
4192     PerlIOBuf_fill,
4193     PerlIOBase_eof,
4194     PerlIOBase_error,
4195     PerlIOBase_clearerr,
4196     PerlIOBase_setlinebuf,
4197     PerlIOBuf_get_base,
4198     PerlIOBuf_bufsiz,
4199     PerlIOBuf_get_ptr,
4200     PerlIOBuf_get_cnt,
4201     PerlIOBuf_set_ptrcnt,
4202 };
4203
4204 /*--------------------------------------------------------------------------------------*/
4205 /*
4206  * Temp layer to hold unread chars when cannot do it any other way
4207  */
4208
4209 IV
4210 PerlIOPending_fill(pTHX_ PerlIO *f)
4211 {
4212     /*
4213      * Should never happen
4214      */
4215     PerlIO_flush(f);
4216     return 0;
4217 }
4218
4219 IV
4220 PerlIOPending_close(pTHX_ PerlIO *f)
4221 {
4222     /*
4223      * A tad tricky - flush pops us, then we close new top
4224      */
4225     PerlIO_flush(f);
4226     return PerlIO_close(f);
4227 }
4228
4229 IV
4230 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4231 {
4232     /*
4233      * A tad tricky - flush pops us, then we seek new top
4234      */
4235     PerlIO_flush(f);
4236     return PerlIO_seek(f, offset, whence);
4237 }
4238
4239
4240 IV
4241 PerlIOPending_flush(pTHX_ PerlIO *f)
4242 {
4243     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4244     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4245         Safefree(b->buf);
4246         b->buf = NULL;
4247     }
4248     PerlIO_pop(aTHX_ f);
4249     return 0;
4250 }
4251
4252 void
4253 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4254 {
4255     if (cnt <= 0) {
4256         PerlIO_flush(f);
4257     }
4258     else {
4259         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4260     }
4261 }
4262
4263 IV
4264 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4265 {
4266     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4267     PerlIOl * const l = PerlIOBase(f);
4268     /*
4269      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4270      * etc. get muddled when it changes mid-string when we auto-pop.
4271      */
4272     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4273         (PerlIOBase(PerlIONext(f))->
4274          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4275     return code;
4276 }
4277
4278 SSize_t
4279 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4280 {
4281     SSize_t avail = PerlIO_get_cnt(f);
4282     SSize_t got = 0;
4283     if ((SSize_t)count < avail)
4284         avail = count;
4285     if (avail > 0)
4286         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4287     if (got >= 0 && got < (SSize_t)count) {
4288         const SSize_t more =
4289             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4290         if (more >= 0 || got == 0)
4291             got += more;
4292     }
4293     return got;
4294 }
4295
4296 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4297     sizeof(PerlIO_funcs),
4298     "pending",
4299     sizeof(PerlIOBuf),
4300     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4301     PerlIOPending_pushed,
4302     PerlIOBuf_popped,
4303     NULL,
4304     PerlIOBase_binmode,         /* binmode */
4305     NULL,
4306     PerlIOBase_fileno,
4307     PerlIOBuf_dup,
4308     PerlIOPending_read,
4309     PerlIOBuf_unread,
4310     PerlIOBuf_write,
4311     PerlIOPending_seek,
4312     PerlIOBuf_tell,
4313     PerlIOPending_close,
4314     PerlIOPending_flush,
4315     PerlIOPending_fill,
4316     PerlIOBase_eof,
4317     PerlIOBase_error,
4318     PerlIOBase_clearerr,
4319     PerlIOBase_setlinebuf,
4320     PerlIOBuf_get_base,
4321     PerlIOBuf_bufsiz,
4322     PerlIOBuf_get_ptr,
4323     PerlIOBuf_get_cnt,
4324     PerlIOPending_set_ptrcnt,
4325 };
4326
4327
4328
4329 /*--------------------------------------------------------------------------------------*/
4330 /*
4331  * crlf - translation On read translate CR,LF to "\n" we do this by
4332  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4333  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4334  *
4335  * c->nl points on the first byte of CR LF pair when it is temporarily
4336  * replaced by LF, or to the last CR of the buffer.  In the former case
4337  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4338  * that it ends at c->nl; these two cases can be distinguished by
4339  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4340  * _unread() and _flush() calls.
4341  * It only matters for read operations.
4342  */
4343
4344 typedef struct {
4345     PerlIOBuf base;             /* PerlIOBuf stuff */
4346     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4347                                  * buffer */
4348 } PerlIOCrlf;
4349
4350 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4351  * Otherwise the :crlf layer would always revert back to
4352  * raw mode.
4353  */
4354 static void
4355 S_inherit_utf8_flag(PerlIO *f)
4356 {
4357     PerlIO *g = PerlIONext(f);
4358     if (PerlIOValid(g)) {
4359         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4360             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4361         }
4362     }
4363 }
4364
4365 IV
4366 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4367 {
4368     IV code;
4369     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4370     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4371 #if 0
4372     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4373                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4374                  PerlIOBase(f)->flags);
4375 #endif
4376     {
4377       /* Enable the first CRLF capable layer you can find, but if none
4378        * found, the one we just pushed is fine.  This results in at
4379        * any given moment at most one CRLF-capable layer being enabled
4380        * in the whole layer stack. */
4381          PerlIO *g = PerlIONext(f);
4382          while (PerlIOValid(g)) {
4383               PerlIOl *b = PerlIOBase(g);
4384               if (b && b->tab == &PerlIO_crlf) {
4385                    if (!(b->flags & PERLIO_F_CRLF))
4386                         b->flags |= PERLIO_F_CRLF;
4387                    S_inherit_utf8_flag(g);
4388                    PerlIO_pop(aTHX_ f);
4389                    return code;
4390               }
4391               g = PerlIONext(g);
4392          }
4393     }
4394     S_inherit_utf8_flag(f);
4395     return code;
4396 }
4397
4398
4399 SSize_t
4400 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4401 {
4402     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4403     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4404         *(c->nl) = 0xd;
4405         c->nl = NULL;
4406     }
4407     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4408         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4409     else {
4410         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4411         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4412         SSize_t unread = 0;
4413         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4414             PerlIO_flush(f);
4415         if (!b->buf)
4416             PerlIO_get_base(f);
4417         if (b->buf) {
4418             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4419                 b->end = b->ptr = b->buf + b->bufsiz;
4420                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4421                 b->posn -= b->bufsiz;
4422             }
4423             while (count > 0 && b->ptr > b->buf) {
4424                 const int ch = *--buf;
4425                 if (ch == '\n') {
4426                     if (b->ptr - 2 >= b->buf) {
4427                         *--(b->ptr) = 0xa;
4428                         *--(b->ptr) = 0xd;
4429                         unread++;
4430                         count--;
4431                     }
4432                     else {
4433                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4434                         *--(b->ptr) = 0xa;      /* Works even if 0xa == '\r' */
4435                         unread++;
4436                         count--;
4437                     }
4438                 }
4439                 else {
4440                     *--(b->ptr) = ch;
4441                     unread++;
4442                     count--;
4443                 }
4444             }
4445         }
4446         return unread;
4447     }
4448 }
4449
4450 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4451 SSize_t
4452 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4453 {
4454     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4455     if (!b->buf)
4456         PerlIO_get_base(f);
4457     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4458         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4459         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4460             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4461           scan:
4462             while (nl < b->end && *nl != 0xd)
4463                 nl++;
4464             if (nl < b->end && *nl == 0xd) {
4465               test:
4466                 if (nl + 1 < b->end) {
4467                     if (nl[1] == 0xa) {
4468                         *nl = '\n';
4469                         c->nl = nl;
4470                     }
4471                     else {
4472                         /*
4473                          * Not CR,LF but just CR
4474                          */
4475                         nl++;
4476                         goto scan;
4477                     }
4478                 }
4479                 else {
4480                     /*
4481                      * Blast - found CR as last char in buffer
4482                      */
4483
4484                     if (b->ptr < nl) {
4485                         /*
4486                          * They may not care, defer work as long as
4487                          * possible
4488                          */
4489                         c->nl = nl;
4490                         return (nl - b->ptr);
4491                     }
4492                     else {
4493                         int code;
4494                         b->ptr++;       /* say we have read it as far as
4495                                          * flush() is concerned */
4496                         b->buf++;       /* Leave space in front of buffer */
4497                         /* Note as we have moved buf up flush's
4498                            posn += ptr-buf
4499                            will naturally make posn point at CR
4500                          */
4501                         b->bufsiz--;    /* Buffer is thus smaller */
4502                         code = PerlIO_fill(f);  /* Fetch some more */
4503                         b->bufsiz++;    /* Restore size for next time */
4504                         b->buf--;       /* Point at space */
4505                         b->ptr = nl = b->buf;   /* Which is what we hand
4506                                                  * off */
4507                         *nl = 0xd;      /* Fill in the CR */
4508                         if (code == 0)
4509                             goto test;  /* fill() call worked */
4510                         /*
4511                          * CR at EOF - just fall through
4512                          */
4513                         /* Should we clear EOF though ??? */
4514                     }
4515                 }
4516             }
4517         }
4518         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4519     }
4520     return 0;
4521 }
4522
4523 void
4524 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4525 {
4526     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4527     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4528     if (!b->buf)
4529         PerlIO_get_base(f);
4530     if (!ptr) {
4531         if (c->nl) {
4532             ptr = c->nl + 1;
4533             if (ptr == b->end && *c->nl == 0xd) {
4534                 /* Defered CR at end of buffer case - we lied about count */
4535                 ptr--;
4536             }
4537         }
4538         else {
4539             ptr = b->end;
4540         }
4541         ptr -= cnt;
4542     }
4543     else {
4544         NOOP;
4545 #if 0
4546         /*
4547          * Test code - delete when it works ...
4548          */
4549         IV flags = PerlIOBase(f)->flags;
4550         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4551         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4552           /* Defered CR at end of buffer case - we lied about count */
4553           chk--;
4554         }
4555         chk -= cnt;
4556
4557         if (ptr != chk ) {
4558             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4559                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4560                        flags, c->nl, b->end, cnt);
4561         }
4562 #endif
4563     }
4564     if (c->nl) {
4565         if (ptr > c->nl) {
4566             /*
4567              * They have taken what we lied about
4568              */
4569             *(c->nl) = 0xd;
4570             c->nl = NULL;
4571             ptr++;
4572         }
4573     }
4574     b->ptr = ptr;
4575     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4576 }
4577
4578 SSize_t
4579 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4580 {
4581     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4582         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4583     else {
4584         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4585         const STDCHAR *buf = (const STDCHAR *) vbuf;
4586         const STDCHAR * const ebuf = buf + count;
4587         if (!b->buf)
4588             PerlIO_get_base(f);
4589         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4590             return 0;
4591         while (buf < ebuf) {
4592             const STDCHAR * const eptr = b->buf + b->bufsiz;
4593             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4594             while (buf < ebuf && b->ptr < eptr) {
4595                 if (*buf == '\n') {
4596                     if ((b->ptr + 2) > eptr) {
4597                         /*
4598                          * Not room for both
4599                          */
4600                         PerlIO_flush(f);
4601                         break;
4602                     }
4603                     else {
4604                         *(b->ptr)++ = 0xd;      /* CR */
4605                         *(b->ptr)++ = 0xa;      /* LF */
4606                         buf++;
4607                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4608                             PerlIO_flush(f);
4609                             break;
4610                         }
4611                     }
4612                 }
4613                 else {
4614                     *(b->ptr)++ = *buf++;
4615                 }
4616                 if (b->ptr >= eptr) {
4617                     PerlIO_flush(f);
4618                     break;
4619                 }
4620             }
4621         }
4622         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4623             PerlIO_flush(f);
4624         return (buf - (STDCHAR *) vbuf);
4625     }
4626 }
4627
4628 IV
4629 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4630 {
4631     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4632     if (c->nl) {
4633         *(c->nl) = 0xd;
4634         c->nl = NULL;
4635     }
4636     return PerlIOBuf_flush(aTHX_ f);
4637 }
4638
4639 IV
4640 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4641 {
4642     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4643         /* In text mode - flush any pending stuff and flip it */
4644         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4645 #ifndef PERLIO_USING_CRLF
4646         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4647         PerlIO_pop(aTHX_ f);
4648 #endif
4649     }
4650     return 0;
4651 }
4652
4653 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4654     sizeof(PerlIO_funcs),
4655     "crlf",
4656     sizeof(PerlIOCrlf),
4657     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4658     PerlIOCrlf_pushed,
4659     PerlIOBuf_popped,         /* popped */
4660     PerlIOBuf_open,
4661     PerlIOCrlf_binmode,       /* binmode */
4662     NULL,
4663     PerlIOBase_fileno,
4664     PerlIOBuf_dup,
4665     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4666     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4667     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4668     PerlIOBuf_seek,
4669     PerlIOBuf_tell,
4670     PerlIOBuf_close,
4671     PerlIOCrlf_flush,
4672     PerlIOBuf_fill,
4673     PerlIOBase_eof,
4674     PerlIOBase_error,
4675     PerlIOBase_clearerr,
4676     PerlIOBase_setlinebuf,
4677     PerlIOBuf_get_base,
4678     PerlIOBuf_bufsiz,
4679     PerlIOBuf_get_ptr,
4680     PerlIOCrlf_get_cnt,
4681     PerlIOCrlf_set_ptrcnt,
4682 };
4683
4684 #ifdef HAS_MMAP
4685 /*--------------------------------------------------------------------------------------*/
4686 /*
4687  * mmap as "buffer" layer
4688  */
4689
4690 typedef struct {
4691     PerlIOBuf base;             /* PerlIOBuf stuff */
4692     Mmap_t mptr;                /* Mapped address */
4693     Size_t len;                 /* mapped length */
4694     STDCHAR *bbuf;              /* malloced buffer if map fails */
4695 } PerlIOMmap;
4696
4697 IV
4698 PerlIOMmap_map(pTHX_ PerlIO *f)
4699 {
4700     dVAR;
4701     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4702     const IV flags = PerlIOBase(f)->flags;
4703     IV code = 0;
4704     if (m->len)
4705         abort();
4706     if (flags & PERLIO_F_CANREAD) {
4707         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4708         const int fd = PerlIO_fileno(f);
4709         Stat_t st;
4710         code = Fstat(fd, &st);
4711         if (code == 0 && S_ISREG(st.st_mode)) {
4712             SSize_t len = st.st_size - b->posn;
4713             if (len > 0) {
4714                 Off_t posn;
4715                 if (PL_mmap_page_size <= 0)
4716                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4717                              PL_mmap_page_size);
4718                 if (b->posn < 0) {
4719                     /*
4720                      * This is a hack - should never happen - open should
4721                      * have set it !
4722                      */
4723                     b->posn = PerlIO_tell(PerlIONext(f));
4724                 }
4725                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4726                 len = st.st_size - posn;
4727                 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4728                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4729 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4730                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4731 #endif
4732 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4733                     madvise(m->mptr, len, MADV_WILLNEED);
4734 #endif
4735                     PerlIOBase(f)->flags =
4736                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4737                     b->end = ((STDCHAR *) m->mptr) + len;
4738                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4739                     b->ptr = b->buf;
4740                     m->len = len;
4741                 }
4742                 else {
4743                     b->buf = NULL;
4744                 }
4745             }
4746             else {
4747                 PerlIOBase(f)->flags =
4748                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4749                 b->buf = NULL;
4750                 b->ptr = b->end = b->ptr;
4751                 code = -1;
4752             }
4753         }
4754     }
4755     return code;
4756 }
4757
4758 IV
4759 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4760 {
4761     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4762     IV code = 0;
4763     if (m->len) {
4764         PerlIOBuf * const b = &m->base;
4765         if (b->buf) {
4766             /* The munmap address argument is tricky: depending on the
4767              * standard it is either "void *" or "caddr_t" (which is
4768              * usually "char *" (signed or unsigned).  If we cast it
4769              * to "void *", those that have it caddr_t and an uptight
4770              * C++ compiler, will freak out.  But casting it as char*
4771              * should work.  Maybe.  (Using Mmap_t figured out by
4772              * Configure doesn't always work, apparently.) */
4773             code = munmap((char*)m->mptr, m->len);
4774             b->buf = NULL;
4775             m->len = 0;
4776             m->mptr = NULL;
4777             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4778                 code = -1;
4779         }
4780         b->ptr = b->end = b->buf;
4781         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4782     }
4783     return code;
4784 }
4785
4786 STDCHAR *
4787 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4788 {
4789     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4790     PerlIOBuf * const b = &m->base;
4791     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4792         /*
4793          * Already have a readbuffer in progress
4794          */
4795         return b->buf;
4796     }
4797     if (b->buf) {
4798         /*
4799          * We have a write buffer or flushed PerlIOBuf read buffer
4800          */
4801         m->bbuf = b->buf;       /* save it in case we need it again */
4802         b->buf = NULL;          /* Clear to trigger below */
4803     }
4804     if (!b->buf) {
4805         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
4806         if (!b->buf) {
4807             /*
4808              * Map did not work - recover PerlIOBuf buffer if we have one
4809              */
4810             b->buf = m->bbuf;
4811         }
4812     }
4813     b->ptr = b->end = b->buf;
4814     if (b->buf)
4815         return b->buf;
4816     return PerlIOBuf_get_base(aTHX_ f);
4817 }
4818
4819 SSize_t
4820 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4821 {
4822     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4823     PerlIOBuf * const b = &m->base;
4824     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4825         PerlIO_flush(f);
4826     if (b->ptr && (b->ptr - count) >= b->buf
4827         && memEQ(b->ptr - count, vbuf, count)) {
4828         b->ptr -= count;
4829         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4830         return count;
4831     }
4832     if (m->len) {
4833         /*
4834          * Loose the unwritable mapped buffer
4835          */
4836         PerlIO_flush(f);
4837         /*
4838          * If flush took the "buffer" see if we have one from before
4839          */
4840         if (!b->buf && m->bbuf)
4841             b->buf = m->bbuf;
4842         if (!b->buf) {
4843             PerlIOBuf_get_base(aTHX_ f);
4844             m->bbuf = b->buf;
4845         }
4846     }
4847     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4848 }
4849
4850 SSize_t
4851 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4852 {
4853     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4854     PerlIOBuf * const b = &m->base;
4855
4856     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4857         /*
4858          * No, or wrong sort of, buffer
4859          */
4860         if (m->len) {
4861             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4862                 return 0;
4863         }
4864         /*
4865          * If unmap took the "buffer" see if we have one from before
4866          */
4867         if (!b->buf && m->bbuf)
4868             b->buf = m->bbuf;
4869         if (!b->buf) {
4870             PerlIOBuf_get_base(aTHX_ f);
4871             m->bbuf = b->buf;
4872         }
4873     }
4874     return PerlIOBuf_write(aTHX_ f, vbuf, count);
4875 }
4876
4877 IV
4878 PerlIOMmap_flush(pTHX_ PerlIO *f)
4879 {
4880     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4881     PerlIOBuf * const b = &m->base;
4882     IV code = PerlIOBuf_flush(aTHX_ f);
4883     /*
4884      * Now we are "synced" at PerlIOBuf level
4885      */
4886     if (b->buf) {
4887         if (m->len) {
4888             /*
4889              * Unmap the buffer
4890              */
4891             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4892                 code = -1;
4893         }
4894         else {
4895             /*
4896              * We seem to have a PerlIOBuf buffer which was not mapped
4897              * remember it in case we need one later
4898              */
4899             m->bbuf = b->buf;
4900         }
4901     }
4902     return code;
4903 }
4904
4905 IV
4906 PerlIOMmap_fill(pTHX_ PerlIO *f)
4907 {
4908     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4909     IV code = PerlIO_flush(f);
4910     if (code == 0 && !b->buf) {
4911         code = PerlIOMmap_map(aTHX_ f);
4912     }
4913     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4914         code = PerlIOBuf_fill(aTHX_ f);
4915     }
4916     return code;
4917 }
4918
4919 IV
4920 PerlIOMmap_close(pTHX_ PerlIO *f)
4921 {
4922     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4923     PerlIOBuf * const b = &m->base;
4924     IV code = PerlIO_flush(f);
4925     if (m->bbuf) {
4926         b->buf = m->bbuf;
4927         m->bbuf = NULL;
4928         b->ptr = b->end = b->buf;
4929     }
4930     if (PerlIOBuf_close(aTHX_ f) != 0)
4931         code = -1;
4932     return code;
4933 }
4934
4935 PerlIO *
4936 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4937 {
4938  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4939 }
4940
4941
4942 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4943     sizeof(PerlIO_funcs),
4944     "mmap",
4945     sizeof(PerlIOMmap),
4946     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4947     PerlIOBuf_pushed,
4948     PerlIOBuf_popped,
4949     PerlIOBuf_open,
4950     PerlIOBase_binmode,         /* binmode */
4951     NULL,
4952     PerlIOBase_fileno,
4953     PerlIOMmap_dup,
4954     PerlIOBuf_read,
4955     PerlIOMmap_unread,
4956     PerlIOMmap_write,
4957     PerlIOBuf_seek,
4958     PerlIOBuf_tell,
4959     PerlIOBuf_close,
4960     PerlIOMmap_flush,
4961     PerlIOMmap_fill,
4962     PerlIOBase_eof,
4963     PerlIOBase_error,
4964     PerlIOBase_clearerr,
4965     PerlIOBase_setlinebuf,
4966     PerlIOMmap_get_base,
4967     PerlIOBuf_bufsiz,
4968     PerlIOBuf_get_ptr,
4969     PerlIOBuf_get_cnt,
4970     PerlIOBuf_set_ptrcnt,
4971 };
4972
4973 #endif                          /* HAS_MMAP */
4974
4975 PerlIO *
4976 Perl_PerlIO_stdin(pTHX)
4977 {
4978     dVAR;
4979     if (!PL_perlio) {
4980         PerlIO_stdstreams(aTHX);
4981     }
4982     return &PL_perlio[1];
4983 }
4984
4985 PerlIO *
4986 Perl_PerlIO_stdout(pTHX)
4987 {
4988     dVAR;
4989     if (!PL_perlio) {
4990         PerlIO_stdstreams(aTHX);
4991     }
4992     return &PL_perlio[2];
4993 }
4994
4995 PerlIO *
4996 Perl_PerlIO_stderr(pTHX)
4997 {
4998     dVAR;
4999     if (!PL_perlio) {
5000         PerlIO_stdstreams(aTHX);
5001     }
5002     return &PL_perlio[3];
5003 }
5004
5005 /*--------------------------------------------------------------------------------------*/
5006
5007 char *
5008 PerlIO_getname(PerlIO *f, char *buf)
5009 {
5010     dTHX;
5011 #ifdef VMS
5012     char *name = NULL;
5013     bool exported = FALSE;
5014     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5015     if (!stdio) {
5016         stdio = PerlIO_exportFILE(f,0);
5017         exported = TRUE;
5018     }
5019     if (stdio) {
5020         name = fgetname(stdio, buf);
5021         if (exported) PerlIO_releaseFILE(f,stdio);
5022     }
5023     return name;
5024 #else
5025     PERL_UNUSED_ARG(f);
5026     PERL_UNUSED_ARG(buf);
5027     Perl_croak(aTHX_ "Don't know how to get file name");
5028     return NULL;
5029 #endif
5030 }
5031
5032
5033 /*--------------------------------------------------------------------------------------*/
5034 /*
5035  * Functions which can be called on any kind of PerlIO implemented in
5036  * terms of above
5037  */
5038
5039 #undef PerlIO_fdopen
5040 PerlIO *
5041 PerlIO_fdopen(int fd, const char *mode)
5042 {
5043     dTHX;
5044     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5045 }
5046
5047 #undef PerlIO_open
5048 PerlIO *
5049 PerlIO_open(const char *path, const char *mode)
5050 {
5051     dTHX;
5052     SV *name = sv_2mortal(newSVpv(path, 0));
5053     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5054 }
5055
5056 #undef Perlio_reopen
5057 PerlIO *
5058 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5059 {
5060     dTHX;
5061     SV *name = sv_2mortal(newSVpv(path,0));
5062     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5063 }
5064
5065 #undef PerlIO_getc
5066 int
5067 PerlIO_getc(PerlIO *f)
5068 {
5069     dTHX;
5070     STDCHAR buf[1];
5071     if ( 1 == PerlIO_read(f, buf, 1) ) {
5072         return (unsigned char) buf[0];
5073     }
5074     return EOF;
5075 }
5076
5077 #undef PerlIO_ungetc
5078 int
5079 PerlIO_ungetc(PerlIO *f, int ch)
5080 {
5081     dTHX;
5082     if (ch != EOF) {
5083         STDCHAR buf = ch;
5084         if (PerlIO_unread(f, &buf, 1) == 1)
5085             return ch;
5086     }
5087     return EOF;
5088 }
5089
5090 #undef PerlIO_putc
5091 int
5092 PerlIO_putc(PerlIO *f, int ch)
5093 {
5094     dTHX;
5095     STDCHAR buf = ch;
5096     return PerlIO_write(f, &buf, 1);
5097 }
5098
5099 #undef PerlIO_puts
5100 int
5101 PerlIO_puts(PerlIO *f, const char *s)
5102 {
5103     dTHX;
5104     return PerlIO_write(f, s, strlen(s));
5105 }
5106
5107 #undef PerlIO_rewind
5108 void
5109 PerlIO_rewind(PerlIO *f)
5110 {
5111     dTHX;
5112     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5113     PerlIO_clearerr(f);
5114 }
5115
5116 #undef PerlIO_vprintf
5117 int
5118 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5119 {
5120     dTHX;
5121     SV * sv;
5122     const char *s;
5123     STRLEN len;
5124     SSize_t wrote;
5125 #ifdef NEED_VA_COPY
5126     va_list apc;
5127     Perl_va_copy(ap, apc);
5128     sv = vnewSVpvf(fmt, &apc);
5129 #else
5130     sv = vnewSVpvf(fmt, &ap);
5131 #endif
5132     s = SvPV_const(sv, len);
5133     wrote = PerlIO_write(f, s, len);
5134     SvREFCNT_dec(sv);
5135     return wrote;
5136 }
5137
5138 #undef PerlIO_printf
5139 int
5140 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5141 {
5142     va_list ap;
5143     int result;
5144     va_start(ap, fmt);
5145     result = PerlIO_vprintf(f, fmt, ap);
5146     va_end(ap);
5147     return result;
5148 }
5149
5150 #undef PerlIO_stdoutf
5151 int
5152 PerlIO_stdoutf(const char *fmt, ...)
5153 {
5154     dTHX;
5155     va_list ap;
5156     int result;
5157     va_start(ap, fmt);
5158     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5159     va_end(ap);
5160     return result;
5161 }
5162
5163 #undef PerlIO_tmpfile
5164 PerlIO *
5165 PerlIO_tmpfile(void)
5166 {
5167      dTHX;
5168      PerlIO *f = NULL;
5169 #ifdef WIN32
5170      const int fd = win32_tmpfd();
5171      if (fd >= 0)
5172           f = PerlIO_fdopen(fd, "w+b");
5173 #else /* WIN32 */
5174 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5175      SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
5176      /*
5177       * I have no idea how portable mkstemp() is ... NI-S
5178       */
5179      const int fd = mkstemp(SvPVX(sv));
5180      if (fd >= 0) {
5181           f = PerlIO_fdopen(fd, "w+");
5182           if (f)
5183                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5184           PerlLIO_unlink(SvPVX_const(sv));
5185      }
5186      SvREFCNT_dec(sv);
5187 #    else       /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5188      FILE * const stdio = PerlSIO_tmpfile();
5189
5190      if (stdio)
5191           f = PerlIO_fdopen(fileno(stdio), "w+");
5192
5193 #    endif /* else HAS_MKSTEMP */
5194 #endif /* else WIN32 */
5195      return f;
5196 }
5197
5198 #undef HAS_FSETPOS
5199 #undef HAS_FGETPOS
5200
5201 #endif                          /* USE_SFIO */
5202 #endif                          /* PERLIO_IS_STDIO */
5203
5204 /*======================================================================================*/
5205 /*
5206  * Now some functions in terms of above which may be needed even if we are
5207  * not in true PerlIO mode
5208  */
5209 const char *
5210 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5211 {
5212     dVAR;
5213     const char *direction = NULL;
5214     SV *layers;
5215     /*
5216      * Need to supply default layer info from open.pm
5217      */
5218
5219     if (!PL_curcop)
5220         return NULL;
5221
5222     if (mode && mode[0] != 'r') {
5223         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5224             direction = "open>";
5225     } else {
5226         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5227             direction = "open<";
5228     }
5229     if (!direction)
5230         return NULL;
5231
5232     layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5233                                       0, direction, 5, 0, 0);
5234
5235     assert(layers);
5236     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5237 }
5238
5239
5240 #ifndef HAS_FSETPOS
5241 #undef PerlIO_setpos
5242 int
5243 PerlIO_setpos(PerlIO *f, SV *pos)
5244 {
5245     dTHX;
5246     if (SvOK(pos)) {
5247         STRLEN len;
5248         const Off_t * const posn = (Off_t *) SvPV(pos, len);
5249         if (f && len == sizeof(Off_t))
5250             return PerlIO_seek(f, *posn, SEEK_SET);
5251     }
5252     SETERRNO(EINVAL, SS_IVCHAN);
5253     return -1;
5254 }
5255 #else
5256 #undef PerlIO_setpos
5257 int
5258 PerlIO_setpos(PerlIO *f, SV *pos)
5259 {
5260     dTHX;
5261     if (SvOK(pos)) {
5262         STRLEN len;
5263         Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5264         if (f && len == sizeof(Fpos_t)) {
5265 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5266             return fsetpos64(f, fpos);
5267 #else
5268             return fsetpos(f, fpos);
5269 #endif
5270         }
5271     }
5272     SETERRNO(EINVAL, SS_IVCHAN);
5273     return -1;
5274 }
5275 #endif
5276
5277 #ifndef HAS_FGETPOS
5278 #undef PerlIO_getpos
5279 int
5280 PerlIO_getpos(PerlIO *f, SV *pos)
5281 {
5282     dTHX;
5283     Off_t posn = PerlIO_tell(f);
5284     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5285     return (posn == (Off_t) - 1) ? -1 : 0;
5286 }
5287 #else
5288 #undef PerlIO_getpos
5289 int
5290 PerlIO_getpos(PerlIO *f, SV *pos)
5291 {
5292     dTHX;
5293     Fpos_t fpos;
5294     int code;
5295 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5296     code = fgetpos64(f, &fpos);
5297 #else
5298     code = fgetpos(f, &fpos);
5299 #endif
5300     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5301     return code;
5302 }
5303 #endif
5304
5305 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5306
5307 int
5308 vprintf(char *pat, char *args)
5309 {
5310     _doprnt(pat, args, stdout);
5311     return 0;                   /* wrong, but perl doesn't use the return
5312                                  * value */
5313 }
5314
5315 int
5316 vfprintf(FILE *fd, char *pat, char *args)
5317 {
5318     _doprnt(pat, args, fd);
5319     return 0;                   /* wrong, but perl doesn't use the return
5320                                  * value */
5321 }
5322
5323 #endif
5324
5325 #ifndef PerlIO_vsprintf
5326 int
5327 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5328 {
5329     dTHX;
5330     const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5331     PERL_UNUSED_CONTEXT;
5332
5333 #ifndef PERL_MY_VSNPRINTF_GUARDED
5334     if (val < 0 || (n > 0 ? val >= n : 0)) {
5335         Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5336     }
5337 #endif
5338     return val;
5339 }
5340 #endif
5341
5342 #ifndef PerlIO_sprintf
5343 int
5344 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5345 {
5346     va_list ap;
5347     int result;
5348     va_start(ap, fmt);
5349     result = PerlIO_vsprintf(s, n, fmt, ap);
5350     va_end(ap);
5351     return result;
5352 }
5353 #endif
5354
5355 /*
5356  * Local variables:
5357  * c-indentation-style: bsd
5358  * c-basic-offset: 4
5359  * indent-tabs-mode: t
5360  * End:
5361  *
5362  * ex: set ts=8 sts=4 sw=4 noet:
5363  */