perlio.c

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