perlio.c

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