perlio.c

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