perlio.c

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