perlio.c

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