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