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      }
1777
1778      return 0;
1779 }
1780
1781 int
1782 PerlIO_fast_gets(PerlIO *f)
1783 {
1784     if (PerlIOValid(f)) {
1785          if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1786              const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1787
1788              if (tab)
1789                   return (tab->Set_ptrcnt != NULL);
1790          }
1791     }
1792
1793     return 0;
1794 }
1795
1796 int
1797 PerlIO_has_cntptr(PerlIO *f)
1798 {
1799     if (PerlIOValid(f)) {
1800         const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1801
1802         if (tab)
1803              return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1804     }
1805
1806     return 0;
1807 }
1808
1809 int
1810 PerlIO_canset_cnt(PerlIO *f)
1811 {
1812     if (PerlIOValid(f)) {
1813           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1814
1815           if (tab)
1816                return (tab->Set_ptrcnt != NULL);
1817     }
1818
1819     return 0;
1820 }
1821
1822 STDCHAR *
1823 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1824 {
1825      Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1826 }
1827
1828 int
1829 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1830 {
1831      Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1832 }
1833
1834 STDCHAR *
1835 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1836 {
1837      Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1838 }
1839
1840 int
1841 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1842 {
1843      Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1844 }
1845
1846 void
1847 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1848 {
1849      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1850 }
1851
1852 void
1853 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1854 {
1855      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1856 }
1857
1858
1859 /*--------------------------------------------------------------------------------------*/
1860 /*
1861  * utf8 and raw dummy layers
1862  */
1863
1864 IV
1865 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1866 {
1867     PERL_UNUSED_CONTEXT;
1868     PERL_UNUSED_ARG(mode);
1869     PERL_UNUSED_ARG(arg);
1870     if (PerlIOValid(f)) {
1871         if (tab->kind & PERLIO_K_UTF8)
1872             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1873         else
1874             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1875         return 0;
1876     }
1877     return -1;
1878 }
1879
1880 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1881     sizeof(PerlIO_funcs),
1882     "utf8",
1883     0,
1884     PERLIO_K_DUMMY | PERLIO_K_UTF8,
1885     PerlIOUtf8_pushed,
1886     NULL,
1887     NULL,
1888     NULL,
1889     NULL,
1890     NULL,
1891     NULL,
1892     NULL,
1893     NULL,
1894     NULL,
1895     NULL,
1896     NULL,
1897     NULL,
1898     NULL,                       /* flush */
1899     NULL,                       /* fill */
1900     NULL,
1901     NULL,
1902     NULL,
1903     NULL,
1904     NULL,                       /* get_base */
1905     NULL,                       /* get_bufsiz */
1906     NULL,                       /* get_ptr */
1907     NULL,                       /* get_cnt */
1908     NULL,                       /* set_ptrcnt */
1909 };
1910
1911 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1912     sizeof(PerlIO_funcs),
1913     "bytes",
1914     0,
1915     PERLIO_K_DUMMY,
1916     PerlIOUtf8_pushed,
1917     NULL,
1918     NULL,
1919     NULL,
1920     NULL,
1921     NULL,
1922     NULL,
1923     NULL,
1924     NULL,
1925     NULL,
1926     NULL,
1927     NULL,
1928     NULL,
1929     NULL,                       /* flush */
1930     NULL,                       /* fill */
1931     NULL,
1932     NULL,
1933     NULL,
1934     NULL,
1935     NULL,                       /* get_base */
1936     NULL,                       /* get_bufsiz */
1937     NULL,                       /* get_ptr */
1938     NULL,                       /* get_cnt */
1939     NULL,                       /* set_ptrcnt */
1940 };
1941
1942 PerlIO *
1943 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1944                IV n, const char *mode, int fd, int imode, int perm,
1945                PerlIO *old, int narg, SV **args)
1946 {
1947     PerlIO_funcs * const tab = PerlIO_default_btm();
1948     PERL_UNUSED_ARG(self);
1949     if (tab && tab->Open)
1950          return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1951                               old, narg, args);
1952     SETERRNO(EINVAL, LIB_INVARG);
1953     return NULL;
1954 }
1955
1956 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1957     sizeof(PerlIO_funcs),
1958     "raw",
1959     0,
1960     PERLIO_K_DUMMY,
1961     PerlIORaw_pushed,
1962     PerlIOBase_popped,
1963     PerlIORaw_open,
1964     NULL,
1965     NULL,
1966     NULL,
1967     NULL,
1968     NULL,
1969     NULL,
1970     NULL,
1971     NULL,
1972     NULL,
1973     NULL,
1974     NULL,                       /* flush */
1975     NULL,                       /* fill */
1976     NULL,
1977     NULL,
1978     NULL,
1979     NULL,
1980     NULL,                       /* get_base */
1981     NULL,                       /* get_bufsiz */
1982     NULL,                       /* get_ptr */
1983     NULL,                       /* get_cnt */
1984     NULL,                       /* set_ptrcnt */
1985 };
1986 /*--------------------------------------------------------------------------------------*/
1987 /*--------------------------------------------------------------------------------------*/
1988 /*
1989  * "Methods" of the "base class"
1990  */
1991
1992 IV
1993 PerlIOBase_fileno(pTHX_ PerlIO *f)
1994 {
1995     return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1996 }
1997
1998 char *
1999 PerlIO_modestr(PerlIO * f, char *buf)
2000 {
2001     char *s = buf;
2002     if (PerlIOValid(f)) {
2003         const IV flags = PerlIOBase(f)->flags;
2004         if (flags & PERLIO_F_APPEND) {
2005             *s++ = 'a';
2006             if (flags & PERLIO_F_CANREAD) {
2007                 *s++ = '+';
2008             }
2009         }
2010         else if (flags & PERLIO_F_CANREAD) {
2011             *s++ = 'r';
2012             if (flags & PERLIO_F_CANWRITE)
2013                 *s++ = '+';
2014         }
2015         else if (flags & PERLIO_F_CANWRITE) {
2016             *s++ = 'w';
2017             if (flags & PERLIO_F_CANREAD) {
2018                 *s++ = '+';
2019             }
2020         }
2021 #ifdef PERLIO_USING_CRLF
2022         if (!(flags & PERLIO_F_CRLF))
2023             *s++ = 'b';
2024 #endif
2025     }
2026     *s = '\0';
2027     return buf;
2028 }
2029
2030
2031 IV
2032 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2033 {
2034     PerlIOl * const l = PerlIOBase(f);
2035     PERL_UNUSED_CONTEXT;
2036     PERL_UNUSED_ARG(arg);
2037
2038     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2039                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2040     if (tab->Set_ptrcnt != NULL)
2041         l->flags |= PERLIO_F_FASTGETS;
2042     if (mode) {
2043         if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2044             mode++;
2045         switch (*mode++) {
2046         case 'r':
2047             l->flags |= PERLIO_F_CANREAD;
2048             break;
2049         case 'a':
2050             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2051             break;
2052         case 'w':
2053             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2054             break;
2055         default:
2056             SETERRNO(EINVAL, LIB_INVARG);
2057             return -1;
2058         }
2059         while (*mode) {
2060             switch (*mode++) {
2061             case '+':
2062                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2063                 break;
2064             case 'b':
2065                 l->flags &= ~PERLIO_F_CRLF;
2066                 break;
2067             case 't':
2068                 l->flags |= PERLIO_F_CRLF;
2069                 break;
2070             default:
2071                 SETERRNO(EINVAL, LIB_INVARG);
2072                 return -1;
2073             }
2074         }
2075     }
2076     else {
2077         if (l->next) {
2078             l->flags |= l->next->flags &
2079                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2080                  PERLIO_F_APPEND);
2081         }
2082     }
2083 #if 0
2084     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2085                  (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2086                  l->flags, PerlIO_modestr(f, temp));
2087 #endif
2088     return 0;
2089 }
2090
2091 IV
2092 PerlIOBase_popped(pTHX_ PerlIO *f)
2093 {
2094     PERL_UNUSED_CONTEXT;
2095     PERL_UNUSED_ARG(f);
2096     return 0;
2097 }
2098
2099 SSize_t
2100 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2101 {
2102     /*
2103      * Save the position as current head considers it
2104      */
2105     const Off_t old = PerlIO_tell(f);
2106     PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2107     PerlIOSelf(f, PerlIOBuf)->posn = old;
2108     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2109 }
2110
2111 SSize_t
2112 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2113 {
2114     STDCHAR *buf = (STDCHAR *) vbuf;
2115     if (f) {
2116         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2117             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2118             SETERRNO(EBADF, SS_IVCHAN);
2119             return 0;
2120         }
2121         while (count > 0) {
2122          get_cnt:
2123           {
2124             SSize_t avail = PerlIO_get_cnt(f);
2125             SSize_t take = 0;
2126             if (avail > 0)
2127                 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2128             if (take > 0) {
2129                 STDCHAR *ptr = PerlIO_get_ptr(f);
2130                 Copy(ptr, buf, take, STDCHAR);
2131                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2132                 count -= take;
2133                 buf += take;
2134                 if (avail == 0)         /* set_ptrcnt could have reset avail */
2135                     goto get_cnt;
2136             }
2137             if (count > 0 && avail <= 0) {
2138                 if (PerlIO_fill(f) != 0)
2139                     break;
2140             }
2141           }
2142         }
2143         return (buf - (STDCHAR *) vbuf);
2144     }
2145     return 0;
2146 }
2147
2148 IV
2149 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2150 {
2151     PERL_UNUSED_CONTEXT;
2152     PERL_UNUSED_ARG(f);
2153     return 0;
2154 }
2155
2156 IV
2157 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2158 {
2159     PERL_UNUSED_CONTEXT;
2160     PERL_UNUSED_ARG(f);
2161     return -1;
2162 }
2163
2164 IV
2165 PerlIOBase_close(pTHX_ PerlIO *f)
2166 {
2167     IV code = -1;
2168     if (PerlIOValid(f)) {
2169         PerlIO *n = PerlIONext(f);
2170         code = PerlIO_flush(f);
2171         PerlIOBase(f)->flags &=
2172            ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2173         while (PerlIOValid(n)) {
2174             const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2175             if (tab && tab->Close) {
2176                 if ((*tab->Close)(aTHX_ n) != 0)
2177                     code = -1;
2178                 break;
2179             }
2180             else {
2181                 PerlIOBase(n)->flags &=
2182                     ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2183             }
2184             n = PerlIONext(n);
2185         }
2186     }
2187     else {
2188         SETERRNO(EBADF, SS_IVCHAN);
2189     }
2190     return code;
2191 }
2192
2193 IV
2194 PerlIOBase_eof(pTHX_ PerlIO *f)
2195 {
2196     PERL_UNUSED_CONTEXT;
2197     if (PerlIOValid(f)) {
2198         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2199     }
2200     return 1;
2201 }
2202
2203 IV
2204 PerlIOBase_error(pTHX_ PerlIO *f)
2205 {
2206     PERL_UNUSED_CONTEXT;
2207     if (PerlIOValid(f)) {
2208         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2209     }
2210     return 1;
2211 }
2212
2213 void
2214 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2215 {
2216     if (PerlIOValid(f)) {
2217         PerlIO * const n = PerlIONext(f);
2218         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2219         if (PerlIOValid(n))
2220             PerlIO_clearerr(n);
2221     }
2222 }
2223
2224 void
2225 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2226 {
2227     PERL_UNUSED_CONTEXT;
2228     if (PerlIOValid(f)) {
2229         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2230     }
2231 }
2232
2233 SV *
2234 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2235 {
2236     if (!arg)
2237         return NULL;
2238 #ifdef sv_dup
2239     if (param) {
2240         arg = sv_dup(arg, param);
2241         SvREFCNT_inc_simple_void_NN(arg);
2242         return arg;
2243     }
2244     else {
2245         return newSVsv(arg);
2246     }
2247 #else
2248     PERL_UNUSED_ARG(param);
2249     return newSVsv(arg);
2250 #endif
2251 }
2252
2253 PerlIO *
2254 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2255 {
2256     PerlIO * const nexto = PerlIONext(o);
2257     if (PerlIOValid(nexto)) {
2258         const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2259         if (tab && tab->Dup)
2260             f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2261         else
2262             f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2263     }
2264     if (f) {
2265         PerlIO_funcs * const self = PerlIOBase(o)->tab;
2266         SV *arg = NULL;
2267         char buf[8];
2268         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2269                      self->name, (void*)f, (void*)o, (void*)param);
2270         if (self->Getarg)
2271             arg = (*self->Getarg)(aTHX_ o, param, flags);
2272         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2273         if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2274             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2275         if (arg)
2276             SvREFCNT_dec(arg);
2277     }
2278     return f;
2279 }
2280
2281 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2282
2283 /* Must be called with PL_perlio_mutex locked. */
2284 static void
2285 S_more_refcounted_fds(pTHX_ const int new_fd) {
2286     dVAR;
2287     const int old_max = PL_perlio_fd_refcnt_size;
2288     const int new_max = 16 + (new_fd & ~15);
2289     int *new_array;
2290
2291     PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2292                  old_max, new_fd, new_max);
2293
2294     if (new_fd < old_max) {
2295         return;
2296     }
2297
2298     assert (new_max > new_fd);
2299
2300     /* Use plain realloc() since we need this memory to be really
2301      * global and visible to all the interpreters and/or threads. */
2302     new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2303
2304     if (!new_array) {
2305 #ifdef USE_ITHREADS
2306         MUTEX_UNLOCK(&PL_perlio_mutex);
2307 #endif
2308         /* Can't use PerlIO to write as it allocates memory */
2309         PerlLIO_write(PerlIO_fileno(Perl_error_log),
2310                       PL_no_mem, strlen(PL_no_mem));
2311         my_exit(1);
2312     }
2313
2314     PL_perlio_fd_refcnt_size = new_max;
2315     PL_perlio_fd_refcnt = new_array;
2316
2317     PerlIO_debug("Zeroing %p, %d\n",
2318                  (void*)(new_array + old_max),
2319                  new_max - old_max);
2320
2321     Zero(new_array + old_max, new_max - old_max, int);
2322 }
2323
2324
2325 void
2326 PerlIO_init(pTHX)
2327 {
2328     /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2329     PERL_UNUSED_CONTEXT;
2330 }
2331
2332 void
2333 PerlIOUnix_refcnt_inc(int fd)
2334 {
2335     dTHX;
2336     if (fd >= 0) {
2337         dVAR;
2338
2339 #ifdef USE_ITHREADS
2340         MUTEX_LOCK(&PL_perlio_mutex);
2341 #endif
2342         if (fd >= PL_perlio_fd_refcnt_size)
2343             S_more_refcounted_fds(aTHX_ fd);
2344
2345         PL_perlio_fd_refcnt[fd]++;
2346         if (PL_perlio_fd_refcnt[fd] <= 0) {
2347             Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2348                        fd, PL_perlio_fd_refcnt[fd]);
2349         }
2350         PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2351                      fd, PL_perlio_fd_refcnt[fd]);
2352
2353 #ifdef USE_ITHREADS
2354         MUTEX_UNLOCK(&PL_perlio_mutex);
2355 #endif
2356     } else {
2357         Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2358     }
2359 }
2360
2361 int
2362 PerlIOUnix_refcnt_dec(int fd)
2363 {
2364     dTHX;
2365     int cnt = 0;
2366     if (fd >= 0) {
2367         dVAR;
2368 #ifdef USE_ITHREADS
2369         MUTEX_LOCK(&PL_perlio_mutex);
2370 #endif
2371         if (fd >= PL_perlio_fd_refcnt_size) {
2372             Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2373                        fd, PL_perlio_fd_refcnt_size);
2374         }
2375         if (PL_perlio_fd_refcnt[fd] <= 0) {
2376             Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2377                        fd, PL_perlio_fd_refcnt[fd]);
2378         }
2379         cnt = --PL_perlio_fd_refcnt[fd];
2380         PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2381 #ifdef USE_ITHREADS
2382         MUTEX_UNLOCK(&PL_perlio_mutex);
2383 #endif
2384     } else {
2385         Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2386     }
2387     return cnt;
2388 }
2389
2390 void
2391 PerlIO_cleanup(pTHX)
2392 {
2393     dVAR;
2394     int i;
2395 #ifdef USE_ITHREADS
2396     PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2397 #else
2398     PerlIO_debug("Cleanup layers\n");
2399 #endif
2400
2401     /* Raise STDIN..STDERR refcount so we don't close them */
2402     for (i=0; i < 3; i++)
2403         PerlIOUnix_refcnt_inc(i);
2404     PerlIO_cleantable(aTHX_ &PL_perlio);
2405     /* Restore STDIN..STDERR refcount */
2406     for (i=0; i < 3; i++)
2407         PerlIOUnix_refcnt_dec(i);
2408
2409     if (PL_known_layers) {
2410         PerlIO_list_free(aTHX_ PL_known_layers);
2411         PL_known_layers = NULL;
2412     }
2413     if (PL_def_layerlist) {
2414         PerlIO_list_free(aTHX_ PL_def_layerlist);
2415         PL_def_layerlist = NULL;
2416     }
2417 }
2418
2419 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2420 {
2421     dVAR;
2422 #if 0
2423 /* XXX we can't rely on an interpreter being present at this late stage,
2424    XXX so we can't use a function like PerlLIO_write that relies on one
2425    being present (at least in win32) :-(.
2426    Disable for now.
2427 */
2428 #ifdef DEBUGGING
2429     {
2430         /* By now all filehandles should have been closed, so any
2431          * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2432          * errors. */
2433 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2434 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2435         char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2436         int i;
2437         for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2438             if (PL_perlio_fd_refcnt[i]) {
2439                 const STRLEN len =
2440                     my_snprintf(buf, sizeof(buf),
2441                                 "PerlIO_teardown: fd %d refcnt=%d\n",
2442                                 i, PL_perlio_fd_refcnt[i]);
2443                 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2444             }
2445         }
2446     }
2447 #endif
2448 #endif
2449     /* Not bothering with PL_perlio_mutex since by now
2450      * all the interpreters are gone. */
2451     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2452         && PL_perlio_fd_refcnt) {
2453         free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2454         PL_perlio_fd_refcnt = NULL;
2455         PL_perlio_fd_refcnt_size = 0;
2456     }
2457 }
2458
2459 /*--------------------------------------------------------------------------------------*/
2460 /*
2461  * Bottom-most level for UNIX-like case
2462  */
2463
2464 typedef struct {
2465     struct _PerlIO base;        /* The generic part */
2466     int fd;                     /* UNIX like file descriptor */
2467     int oflags;                 /* open/fcntl flags */
2468 } PerlIOUnix;
2469
2470 int
2471 PerlIOUnix_oflags(const char *mode)
2472 {
2473     int oflags = -1;
2474     if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2475         mode++;
2476     switch (*mode) {
2477     case 'r':
2478         oflags = O_RDONLY;
2479         if (*++mode == '+') {
2480             oflags = O_RDWR;
2481             mode++;
2482         }
2483         break;
2484
2485     case 'w':
2486         oflags = O_CREAT | O_TRUNC;
2487         if (*++mode == '+') {
2488             oflags |= O_RDWR;
2489             mode++;
2490         }
2491         else
2492             oflags |= O_WRONLY;
2493         break;
2494
2495     case 'a':
2496         oflags = O_CREAT | O_APPEND;
2497         if (*++mode == '+') {
2498             oflags |= O_RDWR;
2499             mode++;
2500         }
2501         else
2502             oflags |= O_WRONLY;
2503         break;
2504     }
2505     if (*mode == 'b') {
2506         oflags |= O_BINARY;
2507         oflags &= ~O_TEXT;
2508         mode++;
2509     }
2510     else if (*mode == 't') {
2511         oflags |= O_TEXT;
2512         oflags &= ~O_BINARY;
2513         mode++;
2514     }
2515     /*
2516      * Always open in binary mode
2517      */
2518     oflags |= O_BINARY;
2519     if (*mode || oflags == -1) {
2520         SETERRNO(EINVAL, LIB_INVARG);
2521         oflags = -1;
2522     }
2523     return oflags;
2524 }
2525
2526 IV
2527 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2528 {
2529     PERL_UNUSED_CONTEXT;
2530     return PerlIOSelf(f, PerlIOUnix)->fd;
2531 }
2532
2533 static void
2534 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2535 {
2536     PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2537 #if defined(WIN32)
2538     Stat_t st;
2539     if (PerlLIO_fstat(fd, &st) == 0) {
2540         if (!S_ISREG(st.st_mode)) {
2541             PerlIO_debug("%d is not regular file\n",fd);
2542             PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2543         }
2544         else {
2545             PerlIO_debug("%d _is_ a regular file\n",fd);
2546         }
2547     }
2548 #endif
2549     s->fd = fd;
2550     s->oflags = imode;
2551     PerlIOUnix_refcnt_inc(fd);
2552     PERL_UNUSED_CONTEXT;
2553 }
2554
2555 IV
2556 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2557 {
2558     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2559     if (*PerlIONext(f)) {
2560         /* We never call down so do any pending stuff now */
2561         PerlIO_flush(PerlIONext(f));
2562         /*
2563          * XXX could (or should) we retrieve the oflags from the open file
2564          * handle rather than believing the "mode" we are passed in? XXX
2565          * Should the value on NULL mode be 0 or -1?
2566          */
2567         PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2568                          mode ? PerlIOUnix_oflags(mode) : -1);
2569     }
2570     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2571
2572     return code;
2573 }
2574
2575 IV
2576 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2577 {
2578     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2579     Off_t new_loc;
2580     PERL_UNUSED_CONTEXT;
2581     if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2582 #ifdef  ESPIPE
2583         SETERRNO(ESPIPE, LIB_INVARG);
2584 #else
2585         SETERRNO(EINVAL, LIB_INVARG);
2586 #endif
2587         return -1;
2588     }
2589     new_loc = PerlLIO_lseek(fd, offset, whence);
2590     if (new_loc == (Off_t) - 1)
2591         return -1;
2592     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2593     return  0;
2594 }
2595
2596 PerlIO *
2597 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2598                 IV n, const char *mode, int fd, int imode,
2599                 int perm, PerlIO *f, int narg, SV **args)
2600 {
2601     if (PerlIOValid(f)) {
2602         if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2603             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2604     }
2605     if (narg > 0) {
2606         if (*mode == IoTYPE_NUMERIC)
2607             mode++;
2608         else {
2609             imode = PerlIOUnix_oflags(mode);
2610             perm = 0666;
2611         }
2612         if (imode != -1) {
2613             const char *path = SvPV_nolen_const(*args);
2614             fd = PerlLIO_open3(path, imode, perm);
2615         }
2616     }
2617     if (fd >= 0) {
2618         if (*mode == IoTYPE_IMPLICIT)
2619             mode++;
2620         if (!f) {
2621             f = PerlIO_allocate(aTHX);
2622         }
2623         if (!PerlIOValid(f)) {
2624             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2625                 return NULL;
2626             }
2627         }
2628         PerlIOUnix_setfd(aTHX_ f, fd, imode);
2629         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2630         if (*mode == IoTYPE_APPEND)
2631             PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2632         return f;
2633     }
2634     else {
2635         if (f) {
2636             NOOP;
2637             /*
2638              * FIXME: pop layers ???
2639              */
2640         }
2641         return NULL;
2642     }
2643 }
2644
2645 PerlIO *
2646 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2647 {
2648     const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2649     int fd = os->fd;
2650     if (flags & PERLIO_DUP_FD) {
2651         fd = PerlLIO_dup(fd);
2652     }
2653     if (fd >= 0) {
2654         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2655         if (f) {
2656             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2657             PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2658             return f;
2659         }
2660     }
2661     return NULL;
2662 }
2663
2664
2665 SSize_t
2666 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2667 {
2668     dVAR;
2669     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2670 #ifdef PERLIO_STD_SPECIAL
2671     if (fd == 0)
2672         return PERLIO_STD_IN(fd, vbuf, count);
2673 #endif
2674     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2675          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2676         return 0;
2677     }
2678     while (1) {
2679         const SSize_t len = PerlLIO_read(fd, vbuf, count);
2680         if (len >= 0 || errno != EINTR) {
2681             if (len < 0) {
2682                 if (errno != EAGAIN) {
2683                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2684                 }
2685             }
2686             else if (len == 0 && count != 0) {
2687                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2688                 SETERRNO(0,0);
2689             }
2690             return len;
2691         }
2692         PERL_ASYNC_CHECK();
2693     }
2694     /*NOTREACHED*/
2695 }
2696
2697 SSize_t
2698 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2699 {
2700     dVAR;
2701     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2702 #ifdef PERLIO_STD_SPECIAL
2703     if (fd == 1 || fd == 2)
2704         return PERLIO_STD_OUT(fd, vbuf, count);
2705 #endif
2706     while (1) {
2707         const SSize_t len = PerlLIO_write(fd, vbuf, count);
2708         if (len >= 0 || errno != EINTR) {
2709             if (len < 0) {
2710                 if (errno != EAGAIN) {
2711                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2712                 }
2713             }
2714             return len;
2715         }
2716         PERL_ASYNC_CHECK();
2717     }
2718     /*NOTREACHED*/
2719 }
2720
2721 Off_t
2722 PerlIOUnix_tell(pTHX_ PerlIO *f)
2723 {
2724     PERL_UNUSED_CONTEXT;
2725
2726     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2727 }
2728
2729
2730 IV
2731 PerlIOUnix_close(pTHX_ PerlIO *f)
2732 {
2733     dVAR;
2734     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2735     int code = 0;
2736     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2737         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2738             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2739             return 0;
2740         }
2741     }
2742     else {
2743         SETERRNO(EBADF,SS_IVCHAN);
2744         return -1;
2745     }
2746     while (PerlLIO_close(fd) != 0) {
2747         if (errno != EINTR) {
2748             code = -1;
2749             break;
2750         }
2751         PERL_ASYNC_CHECK();
2752     }
2753     if (code == 0) {
2754         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2755     }
2756     return code;
2757 }
2758
2759 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2760     sizeof(PerlIO_funcs),
2761     "unix",
2762     sizeof(PerlIOUnix),
2763     PERLIO_K_RAW,
2764     PerlIOUnix_pushed,
2765     PerlIOBase_popped,
2766     PerlIOUnix_open,
2767     PerlIOBase_binmode,         /* binmode */
2768     NULL,
2769     PerlIOUnix_fileno,
2770     PerlIOUnix_dup,
2771     PerlIOUnix_read,
2772     PerlIOBase_unread,
2773     PerlIOUnix_write,
2774     PerlIOUnix_seek,
2775     PerlIOUnix_tell,
2776     PerlIOUnix_close,
2777     PerlIOBase_noop_ok,         /* flush */
2778     PerlIOBase_noop_fail,       /* fill */
2779     PerlIOBase_eof,
2780     PerlIOBase_error,
2781     PerlIOBase_clearerr,
2782     PerlIOBase_setlinebuf,
2783     NULL,                       /* get_base */
2784     NULL,                       /* get_bufsiz */
2785     NULL,                       /* get_ptr */
2786     NULL,                       /* get_cnt */
2787     NULL,                       /* set_ptrcnt */
2788 };
2789
2790 /*--------------------------------------------------------------------------------------*/
2791 /*
2792  * stdio as a layer
2793  */
2794
2795 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2796 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2797    broken by the last second glibc 2.3 fix
2798  */
2799 #define STDIO_BUFFER_WRITABLE
2800 #endif
2801
2802
2803 typedef struct {
2804     struct _PerlIO base;
2805     FILE *stdio;                /* The stream */
2806 } PerlIOStdio;
2807
2808 IV
2809 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2810 {
2811     PERL_UNUSED_CONTEXT;
2812
2813     if (PerlIOValid(f)) {
2814         FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2815         if (s)
2816             return PerlSIO_fileno(s);
2817     }
2818     errno = EBADF;
2819     return -1;
2820 }
2821
2822 char *
2823 PerlIOStdio_mode(const char *mode, char *tmode)
2824 {
2825     char * const ret = tmode;
2826     if (mode) {
2827         while (*mode) {
2828             *tmode++ = *mode++;
2829         }
2830     }
2831 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2832     *tmode++ = 'b';
2833 #endif
2834     *tmode = '\0';
2835     return ret;
2836 }
2837
2838 IV
2839 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2840 {
2841     PerlIO *n;
2842     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2843         PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2844         if (toptab == tab) {
2845             /* Top is already stdio - pop self (duplicate) and use original */
2846             PerlIO_pop(aTHX_ f);
2847             return 0;
2848         } else {
2849             const int fd = PerlIO_fileno(n);
2850             char tmode[8];
2851             FILE *stdio;
2852             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
2853                             mode = PerlIOStdio_mode(mode, tmode)))) {
2854                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2855                 /* We never call down so do any pending stuff now */
2856                 PerlIO_flush(PerlIONext(f));
2857             }
2858             else {
2859                 return -1;
2860             }
2861         }
2862     }
2863     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2864 }
2865
2866
2867 PerlIO *
2868 PerlIO_importFILE(FILE *stdio, const char *mode)
2869 {
2870     dTHX;
2871     PerlIO *f = NULL;
2872     if (stdio) {
2873         PerlIOStdio *s;
2874         if (!mode || !*mode) {
2875             /* We need to probe to see how we can open the stream
2876                so start with read/write and then try write and read
2877                we dup() so that we can fclose without loosing the fd.
2878
2879                Note that the errno value set by a failing fdopen
2880                varies between stdio implementations.
2881              */
2882             const int fd = PerlLIO_dup(fileno(stdio));
2883             FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2884             if (!f2) {
2885                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2886             }
2887             if (!f2) {
2888                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2889             }
2890             if (!f2) {
2891                 /* Don't seem to be able to open */
2892                 PerlLIO_close(fd);
2893                 return f;
2894             }
2895             fclose(f2);
2896         }
2897         if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2898             s = PerlIOSelf(f, PerlIOStdio);
2899             s->stdio = stdio;
2900             PerlIOUnix_refcnt_inc(fileno(stdio));
2901         }
2902     }
2903     return f;
2904 }
2905
2906 PerlIO *
2907 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2908                  IV n, const char *mode, int fd, int imode,
2909                  int perm, PerlIO *f, int narg, SV **args)
2910 {
2911     char tmode[8];
2912     if (PerlIOValid(f)) {
2913         const char * const path = SvPV_nolen_const(*args);
2914         PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2915         FILE *stdio;
2916         PerlIOUnix_refcnt_dec(fileno(s->stdio));
2917         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2918                             s->stdio);
2919         if (!s->stdio)
2920             return NULL;
2921         s->stdio = stdio;
2922         PerlIOUnix_refcnt_inc(fileno(s->stdio));
2923         return f;
2924     }
2925     else {
2926         if (narg > 0) {
2927             const char * const path = SvPV_nolen_const(*args);
2928             if (*mode == IoTYPE_NUMERIC) {
2929                 mode++;
2930                 fd = PerlLIO_open3(path, imode, perm);
2931             }
2932             else {
2933                 FILE *stdio;
2934                 bool appended = FALSE;
2935 #ifdef __CYGWIN__
2936                 /* Cygwin wants its 'b' early. */
2937                 appended = TRUE;
2938                 mode = PerlIOStdio_mode(mode, tmode);
2939 #endif
2940                 stdio = PerlSIO_fopen(path, mode);
2941                 if (stdio) {
2942                     if (!f) {
2943                         f = PerlIO_allocate(aTHX);
2944                     }
2945                     if (!appended)
2946                         mode = PerlIOStdio_mode(mode, tmode);
2947                     f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2948                     if (f) {
2949                         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2950                         PerlIOUnix_refcnt_inc(fileno(stdio));
2951                     } else {
2952                         PerlSIO_fclose(stdio);
2953                     }
2954                     return f;
2955                 }
2956                 else {
2957                     return NULL;
2958                 }
2959             }
2960         }
2961         if (fd >= 0) {
2962             FILE *stdio = NULL;
2963             int init = 0;
2964             if (*mode == IoTYPE_IMPLICIT) {
2965                 init = 1;
2966                 mode++;
2967             }
2968             if (init) {
2969                 switch (fd) {
2970                 case 0:
2971                     stdio = PerlSIO_stdin;
2972                     break;
2973                 case 1:
2974                     stdio = PerlSIO_stdout;
2975                     break;
2976                 case 2:
2977                     stdio = PerlSIO_stderr;
2978                     break;
2979                 }
2980             }
2981             else {
2982                 stdio = PerlSIO_fdopen(fd, mode =
2983                                        PerlIOStdio_mode(mode, tmode));
2984             }
2985             if (stdio) {
2986                 if (!f) {
2987                     f = PerlIO_allocate(aTHX);
2988                 }
2989                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2990                     PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2991                     PerlIOUnix_refcnt_inc(fileno(stdio));
2992                 }
2993                 return f;
2994             }
2995         }
2996     }
2997     return NULL;
2998 }
2999
3000 PerlIO *
3001 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3002 {
3003     /* This assumes no layers underneath - which is what
3004        happens, but is not how I remember it. NI-S 2001/10/16
3005      */
3006     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3007         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3008         const int fd = fileno(stdio);
3009         char mode[8];
3010         if (flags & PERLIO_DUP_FD) {
3011             const int dfd = PerlLIO_dup(fileno(stdio));
3012             if (dfd >= 0) {
3013                 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3014                 goto set_this;
3015             }
3016             else {
3017                 NOOP;
3018                 /* FIXME: To avoid messy error recovery if dup fails
3019                    re-use the existing stdio as though flag was not set
3020                  */
3021             }
3022         }
3023         stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3024     set_this:
3025         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3026         if(stdio) {
3027             PerlIOUnix_refcnt_inc(fileno(stdio));
3028         }
3029     }
3030     return f;
3031 }
3032
3033 static int
3034 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3035 {
3036     PERL_UNUSED_CONTEXT;
3037
3038     /* XXX this could use PerlIO_canset_fileno() and
3039      * PerlIO_set_fileno() support from Configure
3040      */
3041 #  if defined(__UCLIBC__)
3042     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3043     f->__filedes = -1;
3044     return 1;
3045 #  elif defined(__GLIBC__)
3046     /* There may be a better way for GLIBC:
3047         - libio.h defines a flag to not close() on cleanup
3048      */
3049     f->_fileno = -1;
3050     return 1;
3051 #  elif defined(__sun__)
3052     PERL_UNUSED_ARG(f);
3053     return 0;
3054 #  elif defined(__hpux)
3055     f->__fileH = 0xff;
3056     f->__fileL = 0xff;
3057     return 1;
3058    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3059       your platform does not have special entry try this one.
3060       [For OSF only have confirmation for Tru64 (alpha)
3061       but assume other OSFs will be similar.]
3062     */
3063 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3064     f->_file = -1;
3065     return 1;
3066 #  elif defined(__FreeBSD__)
3067     /* There may be a better way on FreeBSD:
3068         - we could insert a dummy func in the _close function entry
3069         f->_close = (int (*)(void *)) dummy_close;
3070      */
3071     f->_file = -1;
3072     return 1;
3073 #  elif defined(__OpenBSD__)
3074     /* There may be a better way on OpenBSD:
3075         - we could insert a dummy func in the _close function entry
3076         f->_close = (int (*)(void *)) dummy_close;
3077      */
3078     f->_file = -1;
3079     return 1;
3080 #  elif defined(__EMX__)
3081     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3082     f->_handle = -1;
3083     return 1;
3084 #  elif defined(__CYGWIN__)
3085     /* There may be a better way on CYGWIN:
3086         - we could insert a dummy func in the _close function entry
3087         f->_close = (int (*)(void *)) dummy_close;
3088      */
3089     f->_file = -1;
3090     return 1;
3091 #  elif defined(WIN32)
3092 #    if defined(__BORLANDC__)
3093     f->fd = PerlLIO_dup(fileno(f));
3094 #    elif defined(UNDER_CE)
3095     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3096        structure at all
3097      */
3098 #    else
3099     f->_file = -1;
3100 #    endif
3101     return 1;
3102 #  else
3103 #if 0
3104     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3105        (which isn't thread safe) instead
3106      */
3107 #    error "Don't know how to set FILE.fileno on your platform"
3108 #endif
3109     PERL_UNUSED_ARG(f);
3110     return 0;
3111 #  endif
3112 }
3113
3114 IV
3115 PerlIOStdio_close(pTHX_ PerlIO *f)
3116 {
3117     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3118     if (!stdio) {
3119         errno = EBADF;
3120         return -1;
3121     }
3122     else {
3123         const int fd = fileno(stdio);
3124         int invalidate = 0;
3125         IV result = 0;
3126         int dupfd = -1;
3127         dSAVEDERRNO;
3128 #ifdef USE_ITHREADS
3129         dVAR;
3130 #endif
3131 #ifdef SOCKS5_VERSION_NAME
3132         /* Socks lib overrides close() but stdio isn't linked to
3133            that library (though we are) - so we must call close()
3134            on sockets on stdio's behalf.
3135          */
3136         int optval;
3137         Sock_size_t optlen = sizeof(int);
3138         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3139             invalidate = 1;
3140 #endif
3141         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3142            that a subsequent fileno() on it returns -1. Don't want to croak()
3143            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3144            trying to close an already closed handle which somehow it still has
3145            a reference to. (via.xs, I'm looking at you).  */
3146         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3147             /* File descriptor still in use */
3148             invalidate = 1;
3149         }
3150         if (invalidate) {
3151             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3152             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3153                 return 0;
3154             if (stdio == stdout || stdio == stderr)
3155                 return PerlIO_flush(f);
3156             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3157                Use Sarathy's trick from maint-5.6 to invalidate the
3158                fileno slot of the FILE *
3159             */
3160             result = PerlIO_flush(f);
3161             SAVE_ERRNO;
3162             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3163             if (!invalidate) {
3164 #ifdef USE_ITHREADS
3165                 MUTEX_LOCK(&PL_perlio_mutex);
3166                 /* Right. We need a mutex here because for a brief while we
3167                    will have the situation that fd is actually closed. Hence if
3168                    a second thread were to get into this block, its dup() would
3169                    likely return our fd as its dupfd. (after all, it is closed)
3170                    Then if we get to the dup2() first, we blat the fd back
3171                    (messing up its temporary as a side effect) only for it to
3172                    then close its dupfd (== our fd) in its close(dupfd) */
3173
3174                 /* There is, of course, a race condition, that any other thread
3175                    trying to input/output/whatever on this fd will be stuffed
3176                    for the duration of this little manoeuvrer. Perhaps we
3177                    should hold an IO mutex for the duration of every IO
3178                    operation if we know that invalidate doesn't work on this
3179                    platform, but that would suck, and could kill performance.
3180
3181                    Except that correctness trumps speed.
3182                    Advice from klortho #11912. */
3183 #endif
3184                 dupfd = PerlLIO_dup(fd);
3185 #ifdef USE_ITHREADS
3186                 if (dupfd < 0) {
3187                     MUTEX_UNLOCK(&PL_perlio_mutex);
3188                     /* Oh cXap. This isn't going to go well. Not sure if we can
3189                        recover from here, or if closing this particular FILE *
3190                        is a good idea now.  */
3191                 }
3192 #endif
3193             }
3194         } else {
3195             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3196         }
3197         result = PerlSIO_fclose(stdio);
3198         /* We treat error from stdio as success if we invalidated
3199            errno may NOT be expected EBADF
3200          */
3201         if (invalidate && result != 0) {
3202             RESTORE_ERRNO;
3203             result = 0;
3204         }
3205 #ifdef SOCKS5_VERSION_NAME
3206         /* in SOCKS' case, let close() determine return value */
3207         result = close(fd);
3208 #endif
3209         if (dupfd >= 0) {
3210             PerlLIO_dup2(dupfd,fd);
3211             PerlLIO_close(dupfd);
3212 #ifdef USE_ITHREADS
3213             MUTEX_UNLOCK(&PL_perlio_mutex);
3214 #endif
3215         }
3216         return result;
3217     }
3218 }
3219
3220 SSize_t
3221 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3222 {
3223     dVAR;
3224     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3225     SSize_t got = 0;
3226     for (;;) {
3227         if (count == 1) {
3228             STDCHAR *buf = (STDCHAR *) vbuf;
3229             /*
3230              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3231              * stdio does not do that for fread()
3232              */
3233             const int ch = PerlSIO_fgetc(s);
3234             if (ch != EOF) {
3235                 *buf = ch;
3236                 got = 1;
3237             }
3238         }
3239         else
3240             got = PerlSIO_fread(vbuf, 1, count, s);
3241         if (got == 0 && PerlSIO_ferror(s))
3242             got = -1;
3243         if (got >= 0 || errno != EINTR)
3244             break;
3245         PERL_ASYNC_CHECK();
3246         SETERRNO(0,0);  /* just in case */
3247     }
3248     return got;
3249 }
3250
3251 SSize_t
3252 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3253 {
3254     SSize_t unread = 0;
3255     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3256
3257 #ifdef STDIO_BUFFER_WRITABLE
3258     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3259         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3260         STDCHAR *base = PerlIO_get_base(f);
3261         SSize_t cnt   = PerlIO_get_cnt(f);
3262         STDCHAR *ptr  = PerlIO_get_ptr(f);
3263         SSize_t avail = ptr - base;
3264         if (avail > 0) {
3265             if (avail > count) {
3266                 avail = count;
3267             }
3268             ptr -= avail;
3269             Move(buf-avail,ptr,avail,STDCHAR);
3270             count -= avail;
3271             unread += avail;
3272             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3273             if (PerlSIO_feof(s) && unread >= 0)
3274                 PerlSIO_clearerr(s);
3275         }
3276     }
3277     else
3278 #endif
3279     if (PerlIO_has_cntptr(f)) {
3280         /* We can get pointer to buffer but not its base
3281            Do ungetc() but check chars are ending up in the
3282            buffer
3283          */
3284         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3285         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3286         while (count > 0) {
3287             const int ch = *--buf & 0xFF;
3288             if (ungetc(ch,s) != ch) {
3289                 /* ungetc did not work */
3290                 break;
3291             }
3292             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3293                 /* Did not change pointer as expected */
3294                 fgetc(s);  /* get char back again */
3295                 break;
3296             }
3297             /* It worked ! */
3298             count--;
3299             unread++;
3300         }
3301     }
3302
3303     if (count > 0) {
3304         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3305     }
3306     return unread;
3307 }
3308
3309 SSize_t
3310 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3311 {
3312     dVAR;
3313     SSize_t got;
3314     for (;;) {
3315         got = PerlSIO_fwrite(vbuf, 1, count,
3316                               PerlIOSelf(f, PerlIOStdio)->stdio);
3317         if (got >= 0 || errno != EINTR)
3318             break;
3319         PERL_ASYNC_CHECK();
3320         SETERRNO(0,0);  /* just in case */
3321     }
3322     return got;
3323 }
3324
3325 IV
3326 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3327 {
3328     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3329     PERL_UNUSED_CONTEXT;
3330
3331     return PerlSIO_fseek(stdio, offset, whence);
3332 }
3333
3334 Off_t
3335 PerlIOStdio_tell(pTHX_ PerlIO *f)
3336 {
3337     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3338     PERL_UNUSED_CONTEXT;
3339
3340     return PerlSIO_ftell(stdio);
3341 }
3342
3343 IV
3344 PerlIOStdio_flush(pTHX_ PerlIO *f)
3345 {
3346     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3347     PERL_UNUSED_CONTEXT;
3348
3349     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3350         return PerlSIO_fflush(stdio);
3351     }
3352     else {
3353         NOOP;
3354 #if 0
3355         /*
3356          * FIXME: This discards ungetc() and pre-read stuff which is not
3357          * right if this is just a "sync" from a layer above Suspect right
3358          * design is to do _this_ but not have layer above flush this
3359          * layer read-to-read
3360          */
3361         /*
3362          * Not writeable - sync by attempting a seek
3363          */
3364         dSAVE_ERRNO;
3365         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3366             RESTORE_ERRNO;
3367 #endif
3368     }
3369     return 0;
3370 }
3371
3372 IV
3373 PerlIOStdio_eof(pTHX_ PerlIO *f)
3374 {
3375     PERL_UNUSED_CONTEXT;
3376
3377     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3378 }
3379
3380 IV
3381 PerlIOStdio_error(pTHX_ PerlIO *f)
3382 {
3383     PERL_UNUSED_CONTEXT;
3384
3385     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3386 }
3387
3388 void
3389 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3390 {
3391     PERL_UNUSED_CONTEXT;
3392
3393     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3394 }
3395
3396 void
3397 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3398 {
3399     PERL_UNUSED_CONTEXT;
3400
3401 #ifdef HAS_SETLINEBUF
3402     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3403 #else
3404     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3405 #endif
3406 }
3407
3408 #ifdef FILE_base
3409 STDCHAR *
3410 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3411 {
3412     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3413     return (STDCHAR*)PerlSIO_get_base(stdio);
3414 }
3415
3416 Size_t
3417 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3418 {
3419     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3420     return PerlSIO_get_bufsiz(stdio);
3421 }
3422 #endif
3423
3424 #ifdef USE_STDIO_PTR
3425 STDCHAR *
3426 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3427 {
3428     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3429     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3430 }
3431
3432 SSize_t
3433 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3434 {
3435     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3436     return PerlSIO_get_cnt(stdio);
3437 }
3438
3439 void
3440 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3441 {
3442     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3443     if (ptr != NULL) {
3444 #ifdef STDIO_PTR_LVALUE
3445         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3446 #ifdef STDIO_PTR_LVAL_SETS_CNT
3447         assert(PerlSIO_get_cnt(stdio) == (cnt));
3448 #endif
3449 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3450         /*
3451          * Setting ptr _does_ change cnt - we are done
3452          */
3453         return;
3454 #endif
3455 #else                           /* STDIO_PTR_LVALUE */
3456         PerlProc_abort();
3457 #endif                          /* STDIO_PTR_LVALUE */
3458     }
3459     /*
3460      * Now (or only) set cnt
3461      */
3462 #ifdef STDIO_CNT_LVALUE
3463     PerlSIO_set_cnt(stdio, cnt);
3464 #else                           /* STDIO_CNT_LVALUE */
3465 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3466     PerlSIO_set_ptr(stdio,
3467                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3468                                               cnt));
3469 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3470     PerlProc_abort();
3471 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3472 #endif                          /* STDIO_CNT_LVALUE */
3473 }
3474
3475
3476 #endif
3477
3478 IV
3479 PerlIOStdio_fill(pTHX_ PerlIO *f)
3480 {
3481     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3482     int c;
3483     PERL_UNUSED_CONTEXT;
3484
3485     /*
3486      * fflush()ing read-only streams can cause trouble on some stdio-s
3487      */
3488     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3489         if (PerlSIO_fflush(stdio) != 0)
3490             return EOF;
3491     }
3492     for (;;) {
3493         c = PerlSIO_fgetc(stdio);
3494         if (c != EOF)
3495             break;
3496         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3497             return EOF;
3498         PERL_ASYNC_CHECK();
3499         SETERRNO(0,0);
3500     }
3501
3502 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3503
3504 #ifdef STDIO_BUFFER_WRITABLE
3505     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3506         /* Fake ungetc() to the real buffer in case system's ungetc
3507            goes elsewhere
3508          */
3509         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3510         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3511         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3512         if (ptr == base+1) {
3513             *--ptr = (STDCHAR) c;
3514             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3515             if (PerlSIO_feof(stdio))
3516                 PerlSIO_clearerr(stdio);
3517             return 0;
3518         }
3519     }
3520     else
3521 #endif
3522     if (PerlIO_has_cntptr(f)) {
3523         STDCHAR ch = c;
3524         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3525             return 0;
3526         }
3527     }
3528 #endif
3529
3530 #if defined(VMS)
3531     /* An ungetc()d char is handled separately from the regular
3532      * buffer, so we stuff it in the buffer ourselves.
3533      * Should never get called as should hit code above
3534      */
3535     *(--((*stdio)->_ptr)) = (unsigned char) c;
3536     (*stdio)->_cnt++;
3537 #else
3538     /* If buffer snoop scheme above fails fall back to
3539        using ungetc().
3540      */
3541     if (PerlSIO_ungetc(c, stdio) != c)
3542         return EOF;
3543 #endif
3544     return 0;
3545 }
3546
3547
3548
3549 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3550     sizeof(PerlIO_funcs),
3551     "stdio",
3552     sizeof(PerlIOStdio),
3553     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3554     PerlIOStdio_pushed,
3555     PerlIOBase_popped,
3556     PerlIOStdio_open,
3557     PerlIOBase_binmode,         /* binmode */
3558     NULL,
3559     PerlIOStdio_fileno,
3560     PerlIOStdio_dup,
3561     PerlIOStdio_read,
3562     PerlIOStdio_unread,
3563     PerlIOStdio_write,
3564     PerlIOStdio_seek,
3565     PerlIOStdio_tell,
3566     PerlIOStdio_close,
3567     PerlIOStdio_flush,
3568     PerlIOStdio_fill,
3569     PerlIOStdio_eof,
3570     PerlIOStdio_error,
3571     PerlIOStdio_clearerr,
3572     PerlIOStdio_setlinebuf,
3573 #ifdef FILE_base
3574     PerlIOStdio_get_base,
3575     PerlIOStdio_get_bufsiz,
3576 #else
3577     NULL,
3578     NULL,
3579 #endif
3580 #ifdef USE_STDIO_PTR
3581     PerlIOStdio_get_ptr,
3582     PerlIOStdio_get_cnt,
3583 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3584     PerlIOStdio_set_ptrcnt,
3585 #   else
3586     NULL,
3587 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3588 #else
3589     NULL,
3590     NULL,
3591     NULL,
3592 #endif /* USE_STDIO_PTR */
3593 };
3594
3595 /* Note that calls to PerlIO_exportFILE() are reversed using
3596  * PerlIO_releaseFILE(), not importFILE. */
3597 FILE *
3598 PerlIO_exportFILE(PerlIO * f, const char *mode)
3599 {
3600     dTHX;
3601     FILE *stdio = NULL;
3602     if (PerlIOValid(f)) {
3603         char buf[8];
3604         PerlIO_flush(f);
3605         if (!mode || !*mode) {
3606             mode = PerlIO_modestr(f, buf);
3607         }
3608         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3609         if (stdio) {
3610             PerlIOl *l = *f;
3611             PerlIO *f2;
3612             /* De-link any lower layers so new :stdio sticks */
3613             *f = NULL;
3614             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3615                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3616                 s->stdio = stdio;
3617                 PerlIOUnix_refcnt_inc(fileno(stdio));
3618                 /* Link previous lower layers under new one */
3619                 *PerlIONext(f) = l;
3620             }
3621             else {
3622                 /* restore layers list */
3623                 *f = l;
3624             }
3625         }
3626     }
3627     return stdio;
3628 }
3629
3630
3631 FILE *
3632 PerlIO_findFILE(PerlIO *f)
3633 {
3634     PerlIOl *l = *f;
3635     FILE *stdio;
3636     while (l) {
3637         if (l->tab == &PerlIO_stdio) {
3638             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3639             return s->stdio;
3640         }
3641         l = *PerlIONext(&l);
3642     }
3643     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3644     /* However, we're not really exporting a FILE * to someone else (who
3645        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3646        So we need to undo its refernce count increase on the underlying file
3647        descriptor. We have to do this, because if the loop above returns you
3648        the FILE *, then *it* didn't increase any reference count. So there's
3649        only one way to be consistent. */
3650     stdio = PerlIO_exportFILE(f, NULL);
3651     if (stdio) {
3652         const int fd = fileno(stdio);
3653         if (fd >= 0)
3654             PerlIOUnix_refcnt_dec(fd);
3655     }
3656     return stdio;
3657 }
3658
3659 /* Use this to reverse PerlIO_exportFILE calls. */
3660 void
3661 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3662 {
3663     dVAR;
3664     PerlIOl *l;
3665     while ((l = *p)) {
3666         if (l->tab == &PerlIO_stdio) {
3667             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3668             if (s->stdio == f) {
3669                 dTHX;
3670                 const int fd = fileno(f);
3671                 if (fd >= 0)
3672                     PerlIOUnix_refcnt_dec(fd);
3673                 PerlIO_pop(aTHX_ p);
3674                 return;
3675             }
3676         }
3677         p = PerlIONext(p);
3678     }
3679     return;
3680 }
3681
3682 /*--------------------------------------------------------------------------------------*/
3683 /*
3684  * perlio buffer layer
3685  */
3686
3687 IV
3688 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3689 {
3690     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3691     const int fd = PerlIO_fileno(f);
3692     if (fd >= 0 && PerlLIO_isatty(fd)) {
3693         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3694     }
3695     if (*PerlIONext(f)) {
3696         const Off_t posn = PerlIO_tell(PerlIONext(f));
3697         if (posn != (Off_t) - 1) {
3698             b->posn = posn;
3699         }
3700     }
3701     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3702 }
3703
3704 PerlIO *
3705 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3706                IV n, const char *mode, int fd, int imode, int perm,
3707                PerlIO *f, int narg, SV **args)
3708 {
3709     if (PerlIOValid(f)) {
3710         PerlIO *next = PerlIONext(f);
3711         PerlIO_funcs *tab =
3712              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3713         if (tab && tab->Open)
3714              next =
3715                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3716                                next, narg, args);
3717         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3718             return NULL;
3719         }
3720     }
3721     else {
3722         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3723         int init = 0;
3724         if (*mode == IoTYPE_IMPLICIT) {
3725             init = 1;
3726             /*
3727              * mode++;
3728              */
3729         }
3730         if (tab && tab->Open)
3731              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3732                               f, narg, args);
3733         else
3734              SETERRNO(EINVAL, LIB_INVARG);
3735         if (f) {
3736             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3737                 /*
3738                  * if push fails during open, open fails. close will pop us.
3739                  */
3740                 PerlIO_close (f);
3741                 return NULL;
3742             } else {
3743                 fd = PerlIO_fileno(f);
3744                 if (init && fd == 2) {
3745                     /*
3746                      * Initial stderr is unbuffered
3747                      */
3748                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3749                 }
3750 #ifdef PERLIO_USING_CRLF
3751 #  ifdef PERLIO_IS_BINMODE_FD
3752                 if (PERLIO_IS_BINMODE_FD(fd))
3753                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3754                 else
3755 #  endif
3756                 /*
3757                  * do something about failing setmode()? --jhi
3758                  */
3759                 PerlLIO_setmode(fd, O_BINARY);
3760 #endif
3761             }
3762         }
3763     }
3764     return f;
3765 }
3766
3767 /*
3768  * This "flush" is akin to sfio's sync in that it handles files in either
3769  * read or write state.  For write state, we put the postponed data through
3770  * the next layers.  For read state, we seek() the next layers to the
3771  * offset given by current position in the buffer, and discard the buffer
3772  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3773  * in any case?).  Then the pass the stick further in chain.
3774  */
3775 IV
3776 PerlIOBuf_flush(pTHX_ PerlIO *f)
3777 {
3778     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3779     int code = 0;
3780     PerlIO *n = PerlIONext(f);
3781     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3782         /*
3783          * write() the buffer
3784          */
3785         const STDCHAR *buf = b->buf;
3786         const STDCHAR *p = buf;
3787         while (p < b->ptr) {
3788             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3789             if (count > 0) {
3790                 p += count;
3791             }
3792             else if (count < 0 || PerlIO_error(n)) {
3793                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3794                 code = -1;
3795                 break;
3796             }
3797         }
3798         b->posn += (p - buf);
3799     }
3800     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3801         STDCHAR *buf = PerlIO_get_base(f);
3802         /*
3803          * Note position change
3804          */
3805         b->posn += (b->ptr - buf);
3806         if (b->ptr < b->end) {
3807             /* We did not consume all of it - try and seek downstream to
3808                our logical position
3809              */
3810             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3811                 /* Reload n as some layers may pop themselves on seek */
3812                 b->posn = PerlIO_tell(n = PerlIONext(f));
3813             }
3814             else {
3815                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3816                    data is lost for good - so return saying "ok" having undone
3817                    the position adjust
3818                  */
3819                 b->posn -= (b->ptr - buf);
3820                 return code;
3821             }
3822         }
3823     }
3824     b->ptr = b->end = b->buf;
3825     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3826     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3827     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3828         code = -1;
3829     return code;
3830 }
3831
3832 /* This discards the content of the buffer after b->ptr, and rereads
3833  * the buffer from the position off in the layer downstream; here off
3834  * is at offset corresponding to b->ptr - b->buf.
3835  */
3836 IV
3837 PerlIOBuf_fill(pTHX_ PerlIO *f)
3838 {
3839     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3840     PerlIO *n = PerlIONext(f);
3841     SSize_t avail;
3842     /*
3843      * Down-stream flush is defined not to loose read data so is harmless.
3844      * we would not normally be fill'ing if there was data left in anycase.
3845      */
3846     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
3847         return -1;
3848     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3849         PerlIOBase_flush_linebuf(aTHX);
3850
3851     if (!b->buf)
3852         PerlIO_get_base(f);     /* allocate via vtable */
3853
3854     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3855
3856     b->ptr = b->end = b->buf;
3857
3858     if (!PerlIOValid(n)) {
3859         PerlIOBase(f)->flags |= PERLIO_F_EOF;
3860         return -1;
3861     }
3862
3863     if (PerlIO_fast_gets(n)) {
3864         /*
3865          * Layer below is also buffered. We do _NOT_ want to call its
3866          * ->Read() because that will loop till it gets what we asked for
3867          * which may hang on a pipe etc. Instead take anything it has to
3868          * hand, or ask it to fill _once_.
3869          */
3870         avail = PerlIO_get_cnt(n);
3871         if (avail <= 0) {
3872             avail = PerlIO_fill(n);
3873             if (avail == 0)
3874                 avail = PerlIO_get_cnt(n);
3875             else {
3876                 if (!PerlIO_error(n) && PerlIO_eof(n))
3877                     avail = 0;
3878             }
3879         }
3880         if (avail > 0) {
3881             STDCHAR *ptr = PerlIO_get_ptr(n);
3882             const SSize_t cnt = avail;
3883             if (avail > (SSize_t)b->bufsiz)
3884                 avail = b->bufsiz;
3885             Copy(ptr, b->buf, avail, STDCHAR);
3886             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3887         }
3888     }
3889     else {
3890         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3891     }
3892     if (avail <= 0) {
3893         if (avail == 0)
3894             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3895         else
3896             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3897         return -1;
3898     }
3899     b->end = b->buf + avail;
3900     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3901     return 0;
3902 }
3903
3904 SSize_t
3905 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3906 {
3907     if (PerlIOValid(f)) {
3908         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3909         if (!b->ptr)
3910             PerlIO_get_base(f);
3911         return PerlIOBase_read(aTHX_ f, vbuf, count);
3912     }
3913     return 0;
3914 }
3915
3916 SSize_t
3917 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3918 {
3919     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3920     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3921     SSize_t unread = 0;
3922     SSize_t avail;
3923     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3924         PerlIO_flush(f);
3925     if (!b->buf)
3926         PerlIO_get_base(f);
3927     if (b->buf) {
3928         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3929             /*
3930              * Buffer is already a read buffer, we can overwrite any chars
3931              * which have been read back to buffer start
3932              */
3933             avail = (b->ptr - b->buf);
3934         }
3935         else {
3936             /*
3937              * Buffer is idle, set it up so whole buffer is available for
3938              * unread
3939              */
3940             avail = b->bufsiz;
3941             b->end = b->buf + avail;
3942             b->ptr = b->end;
3943             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3944             /*
3945              * Buffer extends _back_ from where we are now
3946              */
3947             b->posn -= b->bufsiz;
3948         }
3949         if (avail > (SSize_t) count) {
3950             /*
3951              * If we have space for more than count, just move count
3952              */
3953             avail = count;
3954         }
3955         if (avail > 0) {
3956             b->ptr -= avail;
3957             buf -= avail;
3958             /*
3959              * In simple stdio-like ungetc() case chars will be already
3960              * there
3961              */
3962             if (buf != b->ptr) {
3963                 Copy(buf, b->ptr, avail, STDCHAR);
3964             }
3965             count -= avail;
3966             unread += avail;
3967             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3968         }
3969     }
3970     if (count > 0) {
3971         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3972     }
3973     return unread;
3974 }
3975
3976 SSize_t
3977 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3978 {
3979     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3980     const STDCHAR *buf = (const STDCHAR *) vbuf;
3981     const STDCHAR *flushptr = buf;
3982     Size_t written = 0;
3983     if (!b->buf)
3984         PerlIO_get_base(f);
3985     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3986         return 0;
3987     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3988         if (PerlIO_flush(f) != 0) {
3989             return 0;
3990         }
3991     }
3992     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3993         flushptr = buf + count;
3994         while (flushptr > buf && *(flushptr - 1) != '\n')
3995             --flushptr;
3996     }
3997     while (count > 0) {
3998         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3999         if ((SSize_t) count < avail)
4000             avail = count;
4001         if (flushptr > buf && flushptr <= buf + avail)
4002             avail = flushptr - buf;
4003         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4004         if (avail) {
4005             Copy(buf, b->ptr, avail, STDCHAR);
4006             count -= avail;
4007             buf += avail;
4008             written += avail;
4009             b->ptr += avail;
4010             if (buf == flushptr)
4011                 PerlIO_flush(f);
4012         }
4013         if (b->ptr >= (b->buf + b->bufsiz))
4014             PerlIO_flush(f);
4015     }
4016     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4017         PerlIO_flush(f);
4018     return written;
4019 }
4020
4021 IV
4022 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4023 {
4024     IV code;
4025     if ((code = PerlIO_flush(f)) == 0) {
4026         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4027         code = PerlIO_seek(PerlIONext(f), offset, whence);
4028         if (code == 0) {
4029             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4030             b->posn = PerlIO_tell(PerlIONext(f));
4031         }
4032     }
4033     return code;
4034 }
4035
4036 Off_t
4037 PerlIOBuf_tell(pTHX_ PerlIO *f)
4038 {
4039     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4040     /*
4041      * b->posn is file position where b->buf was read, or will be written
4042      */
4043     Off_t posn = b->posn;
4044     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4045         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4046 #if 1
4047         /* As O_APPEND files are normally shared in some sense it is better
4048            to flush :
4049          */
4050         PerlIO_flush(f);
4051 #else
4052         /* when file is NOT shared then this is sufficient */
4053         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4054 #endif
4055         posn = b->posn = PerlIO_tell(PerlIONext(f));
4056     }
4057     if (b->buf) {
4058         /*
4059          * If buffer is valid adjust position by amount in buffer
4060          */
4061         posn += (b->ptr - b->buf);
4062     }
4063     return posn;
4064 }
4065
4066 IV
4067 PerlIOBuf_popped(pTHX_ PerlIO *f)
4068 {
4069     const IV code = PerlIOBase_popped(aTHX_ f);
4070     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4071     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4072         Safefree(b->buf);
4073     }
4074     b->ptr = b->end = b->buf = NULL;
4075     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4076     return code;
4077 }
4078
4079 IV
4080 PerlIOBuf_close(pTHX_ PerlIO *f)
4081 {
4082     const IV code = PerlIOBase_close(aTHX_ f);
4083     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4084     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4085         Safefree(b->buf);
4086     }
4087     b->ptr = b->end = b->buf = NULL;
4088     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4089     return code;
4090 }
4091
4092 STDCHAR *
4093 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4094 {
4095     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4096     if (!b->buf)
4097         PerlIO_get_base(f);
4098     return b->ptr;
4099 }
4100
4101 SSize_t
4102 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4103 {
4104     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4105     if (!b->buf)
4106         PerlIO_get_base(f);
4107     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4108         return (b->end - b->ptr);
4109     return 0;
4110 }
4111
4112 STDCHAR *
4113 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4114 {
4115     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4116     PERL_UNUSED_CONTEXT;
4117
4118     if (!b->buf) {
4119         if (!b->bufsiz)
4120             b->bufsiz = 4096;
4121         b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4122         if (!b->buf) {
4123             b->buf = (STDCHAR *) & b->oneword;
4124             b->bufsiz = sizeof(b->oneword);
4125         }
4126         b->end = b->ptr = b->buf;
4127     }
4128     return b->buf;
4129 }
4130
4131 Size_t
4132 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4133 {
4134     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4135     if (!b->buf)
4136         PerlIO_get_base(f);
4137     return (b->end - b->buf);
4138 }
4139
4140 void
4141 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4142 {
4143     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4144 #ifndef DEBUGGING
4145     PERL_UNUSED_ARG(cnt);
4146 #endif
4147     if (!b->buf)
4148         PerlIO_get_base(f);
4149     b->ptr = ptr;
4150     assert(PerlIO_get_cnt(f) == cnt);
4151     assert(b->ptr >= b->buf);
4152     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4153 }
4154
4155 PerlIO *
4156 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4157 {
4158  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4159 }
4160
4161
4162
4163 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4164     sizeof(PerlIO_funcs),
4165     "perlio",
4166     sizeof(PerlIOBuf),
4167     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4168     PerlIOBuf_pushed,
4169     PerlIOBuf_popped,
4170     PerlIOBuf_open,
4171     PerlIOBase_binmode,         /* binmode */
4172     NULL,
4173     PerlIOBase_fileno,
4174     PerlIOBuf_dup,
4175     PerlIOBuf_read,
4176     PerlIOBuf_unread,
4177     PerlIOBuf_write,
4178     PerlIOBuf_seek,
4179     PerlIOBuf_tell,
4180     PerlIOBuf_close,
4181     PerlIOBuf_flush,
4182     PerlIOBuf_fill,
4183     PerlIOBase_eof,
4184     PerlIOBase_error,
4185     PerlIOBase_clearerr,
4186     PerlIOBase_setlinebuf,
4187     PerlIOBuf_get_base,
4188     PerlIOBuf_bufsiz,
4189     PerlIOBuf_get_ptr,
4190     PerlIOBuf_get_cnt,
4191     PerlIOBuf_set_ptrcnt,
4192 };
4193
4194 /*--------------------------------------------------------------------------------------*/
4195 /*
4196  * Temp layer to hold unread chars when cannot do it any other way
4197  */
4198
4199 IV
4200 PerlIOPending_fill(pTHX_ PerlIO *f)
4201 {
4202     /*
4203      * Should never happen
4204      */
4205     PerlIO_flush(f);
4206     return 0;
4207 }
4208
4209 IV
4210 PerlIOPending_close(pTHX_ PerlIO *f)
4211 {
4212     /*
4213      * A tad tricky - flush pops us, then we close new top
4214      */
4215     PerlIO_flush(f);
4216     return PerlIO_close(f);
4217 }
4218
4219 IV
4220 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4221 {
4222     /*
4223      * A tad tricky - flush pops us, then we seek new top
4224      */
4225     PerlIO_flush(f);
4226     return PerlIO_seek(f, offset, whence);
4227 }
4228
4229
4230 IV
4231 PerlIOPending_flush(pTHX_ PerlIO *f)
4232 {
4233     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4234     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4235         Safefree(b->buf);
4236         b->buf = NULL;
4237     }
4238     PerlIO_pop(aTHX_ f);
4239     return 0;
4240 }
4241
4242 void
4243 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4244 {
4245     if (cnt <= 0) {
4246         PerlIO_flush(f);
4247     }
4248     else {
4249         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4250     }
4251 }
4252
4253 IV
4254 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4255 {
4256     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4257     PerlIOl * const l = PerlIOBase(f);
4258     /*
4259      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4260      * etc. get muddled when it changes mid-string when we auto-pop.
4261      */
4262     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4263         (PerlIOBase(PerlIONext(f))->
4264          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4265     return code;
4266 }
4267
4268 SSize_t
4269 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4270 {
4271     SSize_t avail = PerlIO_get_cnt(f);
4272     SSize_t got = 0;
4273     if ((SSize_t)count < avail)
4274         avail = count;
4275     if (avail > 0)
4276         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4277     if (got >= 0 && got < (SSize_t)count) {
4278         const SSize_t more =
4279             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4280         if (more >= 0 || got == 0)
4281             got += more;
4282     }
4283     return got;
4284 }
4285
4286 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4287     sizeof(PerlIO_funcs),
4288     "pending",
4289     sizeof(PerlIOBuf),
4290     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4291     PerlIOPending_pushed,
4292     PerlIOBuf_popped,
4293     NULL,
4294     PerlIOBase_binmode,         /* binmode */
4295     NULL,
4296     PerlIOBase_fileno,
4297     PerlIOBuf_dup,
4298     PerlIOPending_read,
4299     PerlIOBuf_unread,
4300     PerlIOBuf_write,
4301     PerlIOPending_seek,
4302     PerlIOBuf_tell,
4303     PerlIOPending_close,
4304     PerlIOPending_flush,
4305     PerlIOPending_fill,
4306     PerlIOBase_eof,
4307     PerlIOBase_error,
4308     PerlIOBase_clearerr,
4309     PerlIOBase_setlinebuf,
4310     PerlIOBuf_get_base,
4311     PerlIOBuf_bufsiz,
4312     PerlIOBuf_get_ptr,
4313     PerlIOBuf_get_cnt,
4314     PerlIOPending_set_ptrcnt,
4315 };
4316
4317
4318
4319 /*--------------------------------------------------------------------------------------*/
4320 /*
4321  * crlf - translation On read translate CR,LF to "\n" we do this by
4322  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4323  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4324  *
4325  * c->nl points on the first byte of CR LF pair when it is temporarily
4326  * replaced by LF, or to the last CR of the buffer.  In the former case
4327  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4328  * that it ends at c->nl; these two cases can be distinguished by
4329  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4330  * _unread() and _flush() calls.
4331  * It only matters for read operations.
4332  */
4333
4334 typedef struct {
4335     PerlIOBuf base;             /* PerlIOBuf stuff */
4336     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4337                                  * buffer */
4338 } PerlIOCrlf;
4339
4340 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4341  * Otherwise the :crlf layer would always revert back to
4342  * raw mode.
4343  */
4344 static void
4345 S_inherit_utf8_flag(PerlIO *f)
4346 {
4347     PerlIO *g = PerlIONext(f);
4348     if (PerlIOValid(g)) {
4349         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4350             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4351         }
4352     }
4353 }
4354
4355 IV
4356 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4357 {
4358     IV code;
4359     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4360     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4361 #if 0
4362     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4363                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4364                  PerlIOBase(f)->flags);
4365 #endif
4366     {
4367       /* Enable the first CRLF capable layer you can find, but if none
4368        * found, the one we just pushed is fine.  This results in at
4369        * any given moment at most one CRLF-capable layer being enabled
4370        * in the whole layer stack. */
4371          PerlIO *g = PerlIONext(f);
4372          while (PerlIOValid(g)) {
4373               PerlIOl *b = PerlIOBase(g);
4374               if (b && b->tab == &PerlIO_crlf) {
4375                    if (!(b->flags & PERLIO_F_CRLF))
4376                         b->flags |= PERLIO_F_CRLF;
4377                    S_inherit_utf8_flag(g);
4378                    PerlIO_pop(aTHX_ f);
4379                    return code;
4380               }
4381               g = PerlIONext(g);
4382          }
4383     }
4384     S_inherit_utf8_flag(f);
4385     return code;
4386 }
4387
4388
4389 SSize_t
4390 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4391 {
4392     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4393     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4394         *(c->nl) = 0xd;
4395         c->nl = NULL;
4396     }
4397     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4398         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4399     else {
4400         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4401         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4402         SSize_t unread = 0;
4403         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4404             PerlIO_flush(f);
4405         if (!b->buf)
4406             PerlIO_get_base(f);
4407         if (b->buf) {
4408             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4409                 b->end = b->ptr = b->buf + b->bufsiz;
4410                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4411                 b->posn -= b->bufsiz;
4412             }
4413             while (count > 0 && b->ptr > b->buf) {
4414                 const int ch = *--buf;
4415                 if (ch == '\n') {
4416                     if (b->ptr - 2 >= b->buf) {
4417                         *--(b->ptr) = 0xa;
4418                         *--(b->ptr) = 0xd;
4419                         unread++;
4420                         count--;
4421                     }
4422                     else {
4423                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4424                         *--(b->ptr) = 0xa;      /* Works even if 0xa == '\r' */
4425                         unread++;
4426                         count--;
4427                     }
4428                 }
4429                 else {
4430                     *--(b->ptr) = ch;
4431                     unread++;
4432                     count--;
4433                 }
4434             }
4435         }
4436         return unread;
4437     }
4438 }
4439
4440 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4441 SSize_t
4442 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4443 {
4444     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4445     if (!b->buf)
4446         PerlIO_get_base(f);
4447     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4448         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4449         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4450             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4451           scan:
4452             while (nl < b->end && *nl != 0xd)
4453                 nl++;
4454             if (nl < b->end && *nl == 0xd) {
4455               test:
4456                 if (nl + 1 < b->end) {
4457                     if (nl[1] == 0xa) {
4458                         *nl = '\n';
4459                         c->nl = nl;
4460                     }
4461                     else {
4462                         /*
4463                          * Not CR,LF but just CR
4464                          */
4465                         nl++;
4466                         goto scan;
4467                     }
4468                 }
4469                 else {
4470                     /*
4471                      * Blast - found CR as last char in buffer
4472                      */
4473
4474                     if (b->ptr < nl) {
4475                         /*
4476                          * They may not care, defer work as long as
4477                          * possible
4478                          */
4479                         c->nl = nl;
4480                         return (nl - b->ptr);
4481                     }
4482                     else {
4483                         int code;
4484                         b->ptr++;       /* say we have read it as far as
4485                                          * flush() is concerned */
4486                         b->buf++;       /* Leave space in front of buffer */
4487                         /* Note as we have moved buf up flush's
4488                            posn += ptr-buf
4489                            will naturally make posn point at CR
4490                          */
4491                         b->bufsiz--;    /* Buffer is thus smaller */
4492                         code = PerlIO_fill(f);  /* Fetch some more */
4493                         b->bufsiz++;    /* Restore size for next time */
4494                         b->buf--;       /* Point at space */
4495                         b->ptr = nl = b->buf;   /* Which is what we hand
4496                                                  * off */
4497                         *nl = 0xd;      /* Fill in the CR */
4498                         if (code == 0)
4499                             goto test;  /* fill() call worked */
4500                         /*
4501                          * CR at EOF - just fall through
4502                          */
4503                         /* Should we clear EOF though ??? */
4504                     }
4505                 }
4506             }
4507         }
4508         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4509     }
4510     return 0;
4511 }
4512
4513 void
4514 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4515 {
4516     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4517     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4518     if (!b->buf)
4519         PerlIO_get_base(f);
4520     if (!ptr) {
4521         if (c->nl) {
4522             ptr = c->nl + 1;
4523             if (ptr == b->end && *c->nl == 0xd) {
4524                 /* Defered CR at end of buffer case - we lied about count */
4525                 ptr--;
4526             }
4527         }
4528         else {
4529             ptr = b->end;
4530         }
4531         ptr -= cnt;
4532     }
4533     else {
4534         NOOP;
4535 #if 0
4536         /*
4537          * Test code - delete when it works ...
4538          */
4539         IV flags = PerlIOBase(f)->flags;
4540         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4541         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4542           /* Defered CR at end of buffer case - we lied about count */
4543           chk--;
4544         }
4545         chk -= cnt;
4546
4547         if (ptr != chk ) {
4548             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4549                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4550                        flags, c->nl, b->end, cnt);
4551         }
4552 #endif
4553     }
4554     if (c->nl) {
4555         if (ptr > c->nl) {
4556             /*
4557              * They have taken what we lied about
4558              */
4559             *(c->nl) = 0xd;
4560             c->nl = NULL;
4561             ptr++;
4562         }
4563     }
4564     b->ptr = ptr;
4565     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4566 }
4567
4568 SSize_t
4569 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4570 {
4571     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4572         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4573     else {
4574         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4575         const STDCHAR *buf = (const STDCHAR *) vbuf;
4576         const STDCHAR * const ebuf = buf + count;
4577         if (!b->buf)
4578             PerlIO_get_base(f);
4579         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4580             return 0;
4581         while (buf < ebuf) {
4582             const STDCHAR * const eptr = b->buf + b->bufsiz;
4583             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4584             while (buf < ebuf && b->ptr < eptr) {
4585                 if (*buf == '\n') {
4586                     if ((b->ptr + 2) > eptr) {
4587                         /*
4588                          * Not room for both
4589                          */
4590                         PerlIO_flush(f);
4591                         break;
4592                     }
4593                     else {
4594                         *(b->ptr)++ = 0xd;      /* CR */
4595                         *(b->ptr)++ = 0xa;      /* LF */
4596                         buf++;
4597                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4598                             PerlIO_flush(f);
4599                             break;
4600                         }
4601                     }
4602                 }
4603                 else {
4604                     *(b->ptr)++ = *buf++;
4605                 }
4606                 if (b->ptr >= eptr) {
4607                     PerlIO_flush(f);
4608                     break;
4609                 }
4610             }
4611         }
4612         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4613             PerlIO_flush(f);
4614         return (buf - (STDCHAR *) vbuf);
4615     }
4616 }
4617
4618 IV
4619 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4620 {
4621     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4622     if (c->nl) {
4623         *(c->nl) = 0xd;
4624         c->nl = NULL;
4625     }
4626     return PerlIOBuf_flush(aTHX_ f);
4627 }
4628
4629 IV
4630 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4631 {
4632     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4633         /* In text mode - flush any pending stuff and flip it */
4634         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4635 #ifndef PERLIO_USING_CRLF
4636         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4637         PerlIO_pop(aTHX_ f);
4638 #endif
4639     }
4640     return 0;
4641 }
4642
4643 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4644     sizeof(PerlIO_funcs),
4645     "crlf",
4646     sizeof(PerlIOCrlf),
4647     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4648     PerlIOCrlf_pushed,
4649     PerlIOBuf_popped,         /* popped */
4650     PerlIOBuf_open,
4651     PerlIOCrlf_binmode,       /* binmode */
4652     NULL,
4653     PerlIOBase_fileno,
4654     PerlIOBuf_dup,
4655     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4656     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4657     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4658     PerlIOBuf_seek,
4659     PerlIOBuf_tell,
4660     PerlIOBuf_close,
4661     PerlIOCrlf_flush,
4662     PerlIOBuf_fill,
4663     PerlIOBase_eof,
4664     PerlIOBase_error,
4665     PerlIOBase_clearerr,
4666     PerlIOBase_setlinebuf,
4667     PerlIOBuf_get_base,
4668     PerlIOBuf_bufsiz,
4669     PerlIOBuf_get_ptr,
4670     PerlIOCrlf_get_cnt,
4671     PerlIOCrlf_set_ptrcnt,
4672 };
4673
4674 #ifdef HAS_MMAP
4675 /*--------------------------------------------------------------------------------------*/
4676 /*
4677  * mmap as "buffer" layer
4678  */
4679
4680 typedef struct {
4681     PerlIOBuf base;             /* PerlIOBuf stuff */
4682     Mmap_t mptr;                /* Mapped address */
4683     Size_t len;                 /* mapped length */
4684     STDCHAR *bbuf;              /* malloced buffer if map fails */
4685 } PerlIOMmap;
4686
4687 IV
4688 PerlIOMmap_map(pTHX_ PerlIO *f)
4689 {
4690     dVAR;
4691     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4692     const IV flags = PerlIOBase(f)->flags;
4693     IV code = 0;
4694     if (m->len)
4695         abort();
4696     if (flags & PERLIO_F_CANREAD) {
4697         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4698         const int fd = PerlIO_fileno(f);
4699         Stat_t st;
4700         code = Fstat(fd, &st);
4701         if (code == 0 && S_ISREG(st.st_mode)) {
4702             SSize_t len = st.st_size - b->posn;
4703             if (len > 0) {
4704                 Off_t posn;
4705                 if (PL_mmap_page_size <= 0)
4706                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4707                              PL_mmap_page_size);
4708                 if (b->posn < 0) {
4709                     /*
4710                      * This is a hack - should never happen - open should
4711                      * have set it !
4712                      */
4713                     b->posn = PerlIO_tell(PerlIONext(f));
4714                 }
4715                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4716                 len = st.st_size - posn;
4717                 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4718                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4719 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4720                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4721 #endif
4722 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4723                     madvise(m->mptr, len, MADV_WILLNEED);
4724 #endif
4725                     PerlIOBase(f)->flags =
4726                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4727                     b->end = ((STDCHAR *) m->mptr) + len;
4728                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4729                     b->ptr = b->buf;
4730                     m->len = len;
4731                 }
4732                 else {
4733                     b->buf = NULL;
4734                 }
4735             }
4736             else {
4737                 PerlIOBase(f)->flags =
4738                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4739                 b->buf = NULL;
4740                 b->ptr = b->end = b->ptr;
4741                 code = -1;
4742             }
4743         }
4744     }
4745     return code;
4746 }
4747
4748 IV
4749 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4750 {
4751     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4752     IV code = 0;
4753     if (m->len) {
4754         PerlIOBuf * const b = &m->base;
4755         if (b->buf) {
4756             /* The munmap address argument is tricky: depending on the
4757              * standard it is either "void *" or "caddr_t" (which is
4758              * usually "char *" (signed or unsigned).  If we cast it
4759              * to "void *", those that have it caddr_t and an uptight
4760              * C++ compiler, will freak out.  But casting it as char*
4761              * should work.  Maybe.  (Using Mmap_t figured out by
4762              * Configure doesn't always work, apparently.) */
4763             code = munmap((char*)m->mptr, m->len);
4764             b->buf = NULL;
4765             m->len = 0;
4766             m->mptr = NULL;
4767             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4768                 code = -1;
4769         }
4770         b->ptr = b->end = b->buf;
4771         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4772     }
4773     return code;
4774 }
4775
4776 STDCHAR *
4777 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4778 {
4779     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4780     PerlIOBuf * const b = &m->base;
4781     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4782         /*
4783          * Already have a readbuffer in progress
4784          */
4785         return b->buf;
4786     }
4787     if (b->buf) {
4788         /*
4789          * We have a write buffer or flushed PerlIOBuf read buffer
4790          */
4791         m->bbuf = b->buf;       /* save it in case we need it again */
4792         b->buf = NULL;          /* Clear to trigger below */
4793     }
4794     if (!b->buf) {
4795         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
4796         if (!b->buf) {
4797             /*
4798              * Map did not work - recover PerlIOBuf buffer if we have one
4799              */
4800             b->buf = m->bbuf;
4801         }
4802     }
4803     b->ptr = b->end = b->buf;
4804     if (b->buf)
4805         return b->buf;
4806     return PerlIOBuf_get_base(aTHX_ f);
4807 }
4808
4809 SSize_t
4810 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4811 {
4812     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4813     PerlIOBuf * const b = &m->base;
4814     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4815         PerlIO_flush(f);
4816     if (b->ptr && (b->ptr - count) >= b->buf
4817         && memEQ(b->ptr - count, vbuf, count)) {
4818         b->ptr -= count;
4819         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4820         return count;
4821     }
4822     if (m->len) {
4823         /*
4824          * Loose the unwritable mapped buffer
4825          */
4826         PerlIO_flush(f);
4827         /*
4828          * If flush took the "buffer" see if we have one from before
4829          */
4830         if (!b->buf && m->bbuf)
4831             b->buf = m->bbuf;
4832         if (!b->buf) {
4833             PerlIOBuf_get_base(aTHX_ f);
4834             m->bbuf = b->buf;
4835         }
4836     }
4837     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4838 }
4839
4840 SSize_t
4841 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4842 {
4843     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4844     PerlIOBuf * const b = &m->base;
4845
4846     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4847         /*
4848          * No, or wrong sort of, buffer
4849          */
4850         if (m->len) {
4851             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4852                 return 0;
4853         }
4854         /*
4855          * If unmap took the "buffer" see if we have one from before
4856          */
4857         if (!b->buf && m->bbuf)
4858             b->buf = m->bbuf;
4859         if (!b->buf) {
4860             PerlIOBuf_get_base(aTHX_ f);
4861             m->bbuf = b->buf;
4862         }
4863     }
4864     return PerlIOBuf_write(aTHX_ f, vbuf, count);
4865 }
4866
4867 IV
4868 PerlIOMmap_flush(pTHX_ PerlIO *f)
4869 {
4870     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4871     PerlIOBuf * const b = &m->base;
4872     IV code = PerlIOBuf_flush(aTHX_ f);
4873     /*
4874      * Now we are "synced" at PerlIOBuf level
4875      */
4876     if (b->buf) {
4877         if (m->len) {
4878             /*
4879              * Unmap the buffer
4880              */
4881             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4882                 code = -1;
4883         }
4884         else {
4885             /*
4886              * We seem to have a PerlIOBuf buffer which was not mapped
4887              * remember it in case we need one later
4888              */
4889             m->bbuf = b->buf;
4890         }
4891     }
4892     return code;
4893 }
4894
4895 IV
4896 PerlIOMmap_fill(pTHX_ PerlIO *f)
4897 {
4898     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4899     IV code = PerlIO_flush(f);
4900     if (code == 0 && !b->buf) {
4901         code = PerlIOMmap_map(aTHX_ f);
4902     }
4903     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4904         code = PerlIOBuf_fill(aTHX_ f);
4905     }
4906     return code;
4907 }
4908
4909 IV
4910 PerlIOMmap_close(pTHX_ PerlIO *f)
4911 {
4912     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4913     PerlIOBuf * const b = &m->base;
4914     IV code = PerlIO_flush(f);
4915     if (m->bbuf) {
4916         b->buf = m->bbuf;
4917         m->bbuf = NULL;
4918         b->ptr = b->end = b->buf;
4919     }
4920     if (PerlIOBuf_close(aTHX_ f) != 0)
4921         code = -1;
4922     return code;
4923 }
4924
4925 PerlIO *
4926 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4927 {
4928  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4929 }
4930
4931
4932 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4933     sizeof(PerlIO_funcs),
4934     "mmap",
4935     sizeof(PerlIOMmap),
4936     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4937     PerlIOBuf_pushed,
4938     PerlIOBuf_popped,
4939     PerlIOBuf_open,
4940     PerlIOBase_binmode,         /* binmode */
4941     NULL,
4942     PerlIOBase_fileno,
4943     PerlIOMmap_dup,
4944     PerlIOBuf_read,
4945     PerlIOMmap_unread,
4946     PerlIOMmap_write,
4947     PerlIOBuf_seek,
4948     PerlIOBuf_tell,
4949     PerlIOBuf_close,
4950     PerlIOMmap_flush,
4951     PerlIOMmap_fill,
4952     PerlIOBase_eof,
4953     PerlIOBase_error,
4954     PerlIOBase_clearerr,
4955     PerlIOBase_setlinebuf,
4956     PerlIOMmap_get_base,
4957     PerlIOBuf_bufsiz,
4958     PerlIOBuf_get_ptr,
4959     PerlIOBuf_get_cnt,
4960     PerlIOBuf_set_ptrcnt,
4961 };
4962
4963 #endif                          /* HAS_MMAP */
4964
4965 PerlIO *
4966 Perl_PerlIO_stdin(pTHX)
4967 {
4968     dVAR;
4969     if (!PL_perlio) {
4970         PerlIO_stdstreams(aTHX);
4971     }
4972     return &PL_perlio[1];
4973 }
4974
4975 PerlIO *
4976 Perl_PerlIO_stdout(pTHX)
4977 {
4978     dVAR;
4979     if (!PL_perlio) {
4980         PerlIO_stdstreams(aTHX);
4981     }
4982     return &PL_perlio[2];
4983 }
4984
4985 PerlIO *
4986 Perl_PerlIO_stderr(pTHX)
4987 {
4988     dVAR;
4989     if (!PL_perlio) {
4990         PerlIO_stdstreams(aTHX);
4991     }
4992     return &PL_perlio[3];
4993 }
4994
4995 /*--------------------------------------------------------------------------------------*/
4996
4997 char *
4998 PerlIO_getname(PerlIO *f, char *buf)
4999 {
5000     dTHX;
5001 #ifdef VMS
5002     char *name = NULL;
5003     bool exported = FALSE;
5004     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5005     if (!stdio) {
5006         stdio = PerlIO_exportFILE(f,0);
5007         exported = TRUE;
5008     }
5009     if (stdio) {
5010         name = fgetname(stdio, buf);
5011         if (exported) PerlIO_releaseFILE(f,stdio);
5012     }
5013     return name;
5014 #else
5015     PERL_UNUSED_ARG(f);
5016     PERL_UNUSED_ARG(buf);
5017     Perl_croak(aTHX_ "Don't know how to get file name");
5018     return NULL;
5019 #endif
5020 }
5021
5022
5023 /*--------------------------------------------------------------------------------------*/
5024 /*
5025  * Functions which can be called on any kind of PerlIO implemented in
5026  * terms of above
5027  */
5028
5029 #undef PerlIO_fdopen
5030 PerlIO *
5031 PerlIO_fdopen(int fd, const char *mode)
5032 {
5033     dTHX;
5034     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5035 }
5036
5037 #undef PerlIO_open
5038 PerlIO *
5039 PerlIO_open(const char *path, const char *mode)
5040 {
5041     dTHX;
5042     SV *name = sv_2mortal(newSVpv(path, 0));
5043     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5044 }
5045
5046 #undef Perlio_reopen
5047 PerlIO *
5048 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5049 {
5050     dTHX;
5051     SV *name = sv_2mortal(newSVpv(path,0));
5052     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5053 }
5054
5055 #undef PerlIO_getc
5056 int
5057 PerlIO_getc(PerlIO *f)
5058 {
5059     dTHX;
5060     STDCHAR buf[1];
5061     if ( 1 == PerlIO_read(f, buf, 1) ) {
5062         return (unsigned char) buf[0];
5063     }
5064     return EOF;
5065 }
5066
5067 #undef PerlIO_ungetc
5068 int
5069 PerlIO_ungetc(PerlIO *f, int ch)
5070 {
5071     dTHX;
5072     if (ch != EOF) {
5073         STDCHAR buf = ch;
5074         if (PerlIO_unread(f, &buf, 1) == 1)
5075             return ch;
5076     }
5077     return EOF;
5078 }
5079
5080 #undef PerlIO_putc
5081 int
5082 PerlIO_putc(PerlIO *f, int ch)
5083 {
5084     dTHX;
5085     STDCHAR buf = ch;
5086     return PerlIO_write(f, &buf, 1);
5087 }
5088
5089 #undef PerlIO_puts
5090 int
5091 PerlIO_puts(PerlIO *f, const char *s)
5092 {
5093     dTHX;
5094     return PerlIO_write(f, s, strlen(s));
5095 }
5096
5097 #undef PerlIO_rewind
5098 void
5099 PerlIO_rewind(PerlIO *f)
5100 {
5101     dTHX;
5102     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5103     PerlIO_clearerr(f);
5104 }
5105
5106 #undef PerlIO_vprintf
5107 int
5108 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5109 {
5110     dTHX;
5111     SV * sv;
5112     const char *s;
5113     STRLEN len;
5114     SSize_t wrote;
5115 #ifdef NEED_VA_COPY
5116     va_list apc;
5117     Perl_va_copy(ap, apc);
5118     sv = vnewSVpvf(fmt, &apc);
5119 #else
5120     sv = vnewSVpvf(fmt, &ap);
5121 #endif
5122     s = SvPV_const(sv, len);
5123     wrote = PerlIO_write(f, s, len);
5124     SvREFCNT_dec(sv);
5125     return wrote;
5126 }
5127
5128 #undef PerlIO_printf
5129 int
5130 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5131 {
5132     va_list ap;
5133     int result;
5134     va_start(ap, fmt);
5135     result = PerlIO_vprintf(f, fmt, ap);
5136     va_end(ap);
5137     return result;
5138 }
5139
5140 #undef PerlIO_stdoutf
5141 int
5142 PerlIO_stdoutf(const char *fmt, ...)
5143 {
5144     dTHX;
5145     va_list ap;
5146     int result;
5147     va_start(ap, fmt);
5148     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5149     va_end(ap);
5150     return result;
5151 }
5152
5153 #undef PerlIO_tmpfile
5154 PerlIO *
5155 PerlIO_tmpfile(void)
5156 {
5157      dTHX;
5158      PerlIO *f = NULL;
5159 #ifdef WIN32
5160      const int fd = win32_tmpfd();
5161      if (fd >= 0)
5162           f = PerlIO_fdopen(fd, "w+b");
5163 #else /* WIN32 */
5164 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5165      int fd = -1;
5166      char tempname[] = "/tmp/PerlIO_XXXXXX";
5167      const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5168      SV * const sv = tmpdir && *tmpdir ? newSVpv(tmpdir, 0) : NULL;
5169      /*
5170       * I have no idea how portable mkstemp() is ... NI-S
5171       */
5172      if (sv) {
5173          /* if TMPDIR is set and not empty, we try that first */
5174          sv_catpv(sv, tempname + 4);
5175          fd = mkstemp(SvPVX(sv));
5176      }
5177      if (fd < 0) {
5178          /* else we try /tmp */
5179          fd = mkstemp(tempname);
5180      }
5181      if (fd >= 0) {
5182           f = PerlIO_fdopen(fd, "w+");
5183           if (f)
5184                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5185           PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5186      }
5187      if (sv)
5188          SvREFCNT_dec(sv);
5189 #    else       /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5190      FILE * const stdio = PerlSIO_tmpfile();
5191
5192      if (stdio)
5193           f = PerlIO_fdopen(fileno(stdio), "w+");
5194
5195 #    endif /* else HAS_MKSTEMP */
5196 #endif /* else WIN32 */
5197      return f;
5198 }
5199
5200 #undef HAS_FSETPOS
5201 #undef HAS_FGETPOS
5202
5203 #endif                          /* USE_SFIO */
5204 #endif                          /* PERLIO_IS_STDIO */
5205
5206 /*======================================================================================*/
5207 /*
5208  * Now some functions in terms of above which may be needed even if we are
5209  * not in true PerlIO mode
5210  */
5211 const char *
5212 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5213 {
5214     dVAR;
5215     const char *direction = NULL;
5216     SV *layers;
5217     /*
5218      * Need to supply default layer info from open.pm
5219      */
5220
5221     if (!PL_curcop)
5222         return NULL;
5223
5224     if (mode && mode[0] != 'r') {
5225         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5226             direction = "open>";
5227     } else {
5228         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5229             direction = "open<";
5230     }
5231     if (!direction)
5232         return NULL;
5233
5234     layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5235                                       0, direction, 5, 0, 0);
5236
5237     assert(layers);
5238     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5239 }
5240
5241
5242 #ifndef HAS_FSETPOS
5243 #undef PerlIO_setpos
5244 int
5245 PerlIO_setpos(PerlIO *f, SV *pos)
5246 {
5247     dTHX;
5248     if (SvOK(pos)) {
5249         STRLEN len;
5250         const Off_t * const posn = (Off_t *) SvPV(pos, len);
5251         if (f && len == sizeof(Off_t))
5252             return PerlIO_seek(f, *posn, SEEK_SET);
5253     }
5254     SETERRNO(EINVAL, SS_IVCHAN);
5255     return -1;
5256 }
5257 #else
5258 #undef PerlIO_setpos
5259 int
5260 PerlIO_setpos(PerlIO *f, SV *pos)
5261 {
5262     dTHX;
5263     if (SvOK(pos)) {
5264         STRLEN len;
5265         Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5266         if (f && len == sizeof(Fpos_t)) {
5267 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5268             return fsetpos64(f, fpos);
5269 #else
5270             return fsetpos(f, fpos);
5271 #endif
5272         }
5273     }
5274     SETERRNO(EINVAL, SS_IVCHAN);
5275     return -1;
5276 }
5277 #endif
5278
5279 #ifndef HAS_FGETPOS
5280 #undef PerlIO_getpos
5281 int
5282 PerlIO_getpos(PerlIO *f, SV *pos)
5283 {
5284     dTHX;
5285     Off_t posn = PerlIO_tell(f);
5286     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5287     return (posn == (Off_t) - 1) ? -1 : 0;
5288 }
5289 #else
5290 #undef PerlIO_getpos
5291 int
5292 PerlIO_getpos(PerlIO *f, SV *pos)
5293 {
5294     dTHX;
5295     Fpos_t fpos;
5296     int code;
5297 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5298     code = fgetpos64(f, &fpos);
5299 #else
5300     code = fgetpos(f, &fpos);
5301 #endif
5302     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5303     return code;
5304 }
5305 #endif
5306
5307 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5308
5309 int
5310 vprintf(char *pat, char *args)
5311 {
5312     _doprnt(pat, args, stdout);
5313     return 0;                   /* wrong, but perl doesn't use the return
5314                                  * value */
5315 }
5316
5317 int
5318 vfprintf(FILE *fd, char *pat, char *args)
5319 {
5320     _doprnt(pat, args, fd);
5321     return 0;                   /* wrong, but perl doesn't use the return
5322                                  * value */
5323 }
5324
5325 #endif
5326
5327 #ifndef PerlIO_vsprintf
5328 int
5329 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5330 {
5331     dTHX;
5332     const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5333     PERL_UNUSED_CONTEXT;
5334
5335 #ifndef PERL_MY_VSNPRINTF_GUARDED
5336     if (val < 0 || (n > 0 ? val >= n : 0)) {
5337         Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5338     }
5339 #endif
5340     return val;
5341 }
5342 #endif
5343
5344 #ifndef PerlIO_sprintf
5345 int
5346 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5347 {
5348     va_list ap;
5349     int result;
5350     va_start(ap, fmt);
5351     result = PerlIO_vsprintf(s, n, fmt, ap);
5352     va_end(ap);
5353     return result;
5354 }
5355 #endif
5356
5357 /*
5358  * Local variables:
5359  * c-indentation-style: bsd
5360  * c-basic-offset: 4
5361  * indent-tabs-mode: t
5362  * End:
5363  *
5364  * ex: set ts=8 sts=4 sw=4 noet:
5365  */