perlio.c

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