perlio.c

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