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