perlio.c

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