perlio.c

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