perlio.c

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