perlio.c

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