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             /* diag_listed_as: refcnt_inc: fd %d%s */
2416             Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2417                        fd, PL_perlio_fd_refcnt[fd]);
2418         }
2419         PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2420                      fd, PL_perlio_fd_refcnt[fd]);
2421
2422 #ifdef USE_ITHREADS
2423         MUTEX_UNLOCK(&PL_perlio_mutex);
2424 #endif
2425     } else {
2426         /* diag_listed_as: refcnt_inc: fd %d%s */
2427         Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2428     }
2429 }
2430
2431 int
2432 PerlIOUnix_refcnt_dec(int fd)
2433 {
2434     dTHX;
2435     int cnt = 0;
2436     if (fd >= 0) {
2437         dVAR;
2438 #ifdef USE_ITHREADS
2439         MUTEX_LOCK(&PL_perlio_mutex);
2440 #endif
2441         if (fd >= PL_perlio_fd_refcnt_size) {
2442             /* diag_listed_as: refcnt_dec: fd %d%s */
2443             Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2444                        fd, PL_perlio_fd_refcnt_size);
2445         }
2446         if (PL_perlio_fd_refcnt[fd] <= 0) {
2447             /* diag_listed_as: refcnt_dec: fd %d%s */
2448             Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2449                        fd, PL_perlio_fd_refcnt[fd]);
2450         }
2451         cnt = --PL_perlio_fd_refcnt[fd];
2452         PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2453 #ifdef USE_ITHREADS
2454         MUTEX_UNLOCK(&PL_perlio_mutex);
2455 #endif
2456     } else {
2457         /* diag_listed_as: refcnt_dec: fd %d%s */
2458         Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2459     }
2460     return cnt;
2461 }
2462
2463 int
2464 PerlIOUnix_refcnt(int fd)
2465 {
2466     dTHX;
2467     int cnt = 0;
2468     if (fd >= 0) {
2469         dVAR;
2470 #ifdef USE_ITHREADS
2471         MUTEX_LOCK(&PL_perlio_mutex);
2472 #endif
2473         if (fd >= PL_perlio_fd_refcnt_size) {
2474             /* diag_listed_as: refcnt: fd %d%s */
2475             Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2476                        fd, PL_perlio_fd_refcnt_size);
2477         }
2478         if (PL_perlio_fd_refcnt[fd] <= 0) {
2479             /* diag_listed_as: refcnt: fd %d%s */
2480             Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2481                        fd, PL_perlio_fd_refcnt[fd]);
2482         }
2483         cnt = PL_perlio_fd_refcnt[fd];
2484 #ifdef USE_ITHREADS
2485         MUTEX_UNLOCK(&PL_perlio_mutex);
2486 #endif
2487     } else {
2488         /* diag_listed_as: refcnt: fd %d%s */
2489         Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2490     }
2491     return cnt;
2492 }
2493
2494 void
2495 PerlIO_cleanup(pTHX)
2496 {
2497     dVAR;
2498     int i;
2499 #ifdef USE_ITHREADS
2500     PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2501 #else
2502     PerlIO_debug("Cleanup layers\n");
2503 #endif
2504
2505     /* Raise STDIN..STDERR refcount so we don't close them */
2506     for (i=0; i < 3; i++)
2507         PerlIOUnix_refcnt_inc(i);
2508     PerlIO_cleantable(aTHX_ &PL_perlio);
2509     /* Restore STDIN..STDERR refcount */
2510     for (i=0; i < 3; i++)
2511         PerlIOUnix_refcnt_dec(i);
2512
2513     if (PL_known_layers) {
2514         PerlIO_list_free(aTHX_ PL_known_layers);
2515         PL_known_layers = NULL;
2516     }
2517     if (PL_def_layerlist) {
2518         PerlIO_list_free(aTHX_ PL_def_layerlist);
2519         PL_def_layerlist = NULL;
2520     }
2521 }
2522
2523 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2524 {
2525     dVAR;
2526 #if 0
2527 /* XXX we can't rely on an interpreter being present at this late stage,
2528    XXX so we can't use a function like PerlLIO_write that relies on one
2529    being present (at least in win32) :-(.
2530    Disable for now.
2531 */
2532 #ifdef DEBUGGING
2533     {
2534         /* By now all filehandles should have been closed, so any
2535          * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2536          * errors. */
2537 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2538 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2539         char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2540         int i;
2541         for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2542             if (PL_perlio_fd_refcnt[i]) {
2543                 const STRLEN len =
2544                     my_snprintf(buf, sizeof(buf),
2545                                 "PerlIO_teardown: fd %d refcnt=%d\n",
2546                                 i, PL_perlio_fd_refcnt[i]);
2547                 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2548             }
2549         }
2550     }
2551 #endif
2552 #endif
2553     /* Not bothering with PL_perlio_mutex since by now
2554      * all the interpreters are gone. */
2555     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2556         && PL_perlio_fd_refcnt) {
2557         free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2558         PL_perlio_fd_refcnt = NULL;
2559         PL_perlio_fd_refcnt_size = 0;
2560     }
2561 }
2562
2563 /*--------------------------------------------------------------------------------------*/
2564 /*
2565  * Bottom-most level for UNIX-like case
2566  */
2567
2568 typedef struct {
2569     struct _PerlIO base;        /* The generic part */
2570     int fd;                     /* UNIX like file descriptor */
2571     int oflags;                 /* open/fcntl flags */
2572 } PerlIOUnix;
2573
2574 static void
2575 S_lockcnt_dec(pTHX_ const void* f)
2576 {
2577     PerlIO_lockcnt((PerlIO*)f)--;
2578 }
2579
2580
2581 /* call the signal handler, and if that handler happens to clear
2582  * this handle, free what we can and return true */
2583
2584 static bool
2585 S_perlio_async_run(pTHX_ PerlIO* f) {
2586     ENTER;
2587     SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2588     PerlIO_lockcnt(f)++;
2589     PERL_ASYNC_CHECK();
2590     if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2591         return 0;
2592     /* we've just run some perl-level code that could have done
2593      * anything, including closing the file or clearing this layer.
2594      * If so, free any lower layers that have already been
2595      * cleared, then return an error. */
2596     while (PerlIOValid(f) &&
2597             (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2598     {
2599         const PerlIOl *l = *f;
2600         *f = l->next;
2601         Safefree(l);
2602     }
2603     return 1;
2604 }
2605
2606 int
2607 PerlIOUnix_oflags(const char *mode)
2608 {
2609     int oflags = -1;
2610     if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2611         mode++;
2612     switch (*mode) {
2613     case 'r':
2614         oflags = O_RDONLY;
2615         if (*++mode == '+') {
2616             oflags = O_RDWR;
2617             mode++;
2618         }
2619         break;
2620
2621     case 'w':
2622         oflags = O_CREAT | O_TRUNC;
2623         if (*++mode == '+') {
2624             oflags |= O_RDWR;
2625             mode++;
2626         }
2627         else
2628             oflags |= O_WRONLY;
2629         break;
2630
2631     case 'a':
2632         oflags = O_CREAT | O_APPEND;
2633         if (*++mode == '+') {
2634             oflags |= O_RDWR;
2635             mode++;
2636         }
2637         else
2638             oflags |= O_WRONLY;
2639         break;
2640     }
2641     if (*mode == 'b') {
2642         oflags |= O_BINARY;
2643         oflags &= ~O_TEXT;
2644         mode++;
2645     }
2646     else if (*mode == 't') {
2647         oflags |= O_TEXT;
2648         oflags &= ~O_BINARY;
2649         mode++;
2650     }
2651     /*
2652      * Always open in binary mode
2653      */
2654     oflags |= O_BINARY;
2655     if (*mode || oflags == -1) {
2656         SETERRNO(EINVAL, LIB_INVARG);
2657         oflags = -1;
2658     }
2659     return oflags;
2660 }
2661
2662 IV
2663 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2664 {
2665     PERL_UNUSED_CONTEXT;
2666     return PerlIOSelf(f, PerlIOUnix)->fd;
2667 }
2668
2669 static void
2670 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2671 {
2672     PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2673 #if defined(WIN32)
2674     Stat_t st;
2675     if (PerlLIO_fstat(fd, &st) == 0) {
2676         if (!S_ISREG(st.st_mode)) {
2677             PerlIO_debug("%d is not regular file\n",fd);
2678             PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2679         }
2680         else {
2681             PerlIO_debug("%d _is_ a regular file\n",fd);
2682         }
2683     }
2684 #endif
2685     s->fd = fd;
2686     s->oflags = imode;
2687     PerlIOUnix_refcnt_inc(fd);
2688     PERL_UNUSED_CONTEXT;
2689 }
2690
2691 IV
2692 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2693 {
2694     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2695     if (*PerlIONext(f)) {
2696         /* We never call down so do any pending stuff now */
2697         PerlIO_flush(PerlIONext(f));
2698         /*
2699          * XXX could (or should) we retrieve the oflags from the open file
2700          * handle rather than believing the "mode" we are passed in? XXX
2701          * Should the value on NULL mode be 0 or -1?
2702          */
2703         PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2704                          mode ? PerlIOUnix_oflags(mode) : -1);
2705     }
2706     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2707
2708     return code;
2709 }
2710
2711 IV
2712 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2713 {
2714     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2715     Off_t new_loc;
2716     PERL_UNUSED_CONTEXT;
2717     if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2718 #ifdef  ESPIPE
2719         SETERRNO(ESPIPE, LIB_INVARG);
2720 #else
2721         SETERRNO(EINVAL, LIB_INVARG);
2722 #endif
2723         return -1;
2724     }
2725     new_loc = PerlLIO_lseek(fd, offset, whence);
2726     if (new_loc == (Off_t) - 1)
2727         return -1;
2728     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2729     return  0;
2730 }
2731
2732 PerlIO *
2733 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2734                 IV n, const char *mode, int fd, int imode,
2735                 int perm, PerlIO *f, int narg, SV **args)
2736 {
2737     if (PerlIOValid(f)) {
2738         if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2739             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2740     }
2741     if (narg > 0) {
2742         if (*mode == IoTYPE_NUMERIC)
2743             mode++;
2744         else {
2745             imode = PerlIOUnix_oflags(mode);
2746 #ifdef VMS
2747             perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2748 #else
2749             perm = 0666;
2750 #endif
2751         }
2752         if (imode != -1) {
2753             const char *path = SvPV_nolen_const(*args);
2754             fd = PerlLIO_open3(path, imode, perm);
2755         }
2756     }
2757     if (fd >= 0) {
2758         if (*mode == IoTYPE_IMPLICIT)
2759             mode++;
2760         if (!f) {
2761             f = PerlIO_allocate(aTHX);
2762         }
2763         if (!PerlIOValid(f)) {
2764             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2765                 return NULL;
2766             }
2767         }
2768         PerlIOUnix_setfd(aTHX_ f, fd, imode);
2769         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2770         if (*mode == IoTYPE_APPEND)
2771             PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2772         return f;
2773     }
2774     else {
2775         if (f) {
2776             NOOP;
2777             /*
2778              * FIXME: pop layers ???
2779              */
2780         }
2781         return NULL;
2782     }
2783 }
2784
2785 PerlIO *
2786 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2787 {
2788     const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2789     int fd = os->fd;
2790     if (flags & PERLIO_DUP_FD) {
2791         fd = PerlLIO_dup(fd);
2792     }
2793     if (fd >= 0) {
2794         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2795         if (f) {
2796             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2797             PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2798             return f;
2799         }
2800     }
2801     return NULL;
2802 }
2803
2804
2805 SSize_t
2806 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2807 {
2808     dVAR;
2809     int fd;
2810     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2811         return -1;
2812     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2813 #ifdef PERLIO_STD_SPECIAL
2814     if (fd == 0)
2815         return PERLIO_STD_IN(fd, vbuf, count);
2816 #endif
2817     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2818          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2819         return 0;
2820     }
2821     while (1) {
2822         const SSize_t len = PerlLIO_read(fd, vbuf, count);
2823         if (len >= 0 || errno != EINTR) {
2824             if (len < 0) {
2825                 if (errno != EAGAIN) {
2826                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2827                 }
2828             }
2829             else if (len == 0 && count != 0) {
2830                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2831                 SETERRNO(0,0);
2832             }
2833             return len;
2834         }
2835         /* EINTR */
2836         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2837             return -1;
2838     }
2839     /*NOTREACHED*/
2840 }
2841
2842 SSize_t
2843 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2844 {
2845     dVAR;
2846     int fd;
2847     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2848         return -1;
2849     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2850 #ifdef PERLIO_STD_SPECIAL
2851     if (fd == 1 || fd == 2)
2852         return PERLIO_STD_OUT(fd, vbuf, count);
2853 #endif
2854     while (1) {
2855         const SSize_t len = PerlLIO_write(fd, vbuf, count);
2856         if (len >= 0 || errno != EINTR) {
2857             if (len < 0) {
2858                 if (errno != EAGAIN) {
2859                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2860                 }
2861             }
2862             return len;
2863         }
2864         /* EINTR */
2865         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2866             return -1;
2867     }
2868     /*NOTREACHED*/
2869 }
2870
2871 Off_t
2872 PerlIOUnix_tell(pTHX_ PerlIO *f)
2873 {
2874     PERL_UNUSED_CONTEXT;
2875
2876     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2877 }
2878
2879
2880 IV
2881 PerlIOUnix_close(pTHX_ PerlIO *f)
2882 {
2883     dVAR;
2884     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2885     int code = 0;
2886     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2887         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2888             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2889             return 0;
2890         }
2891     }
2892     else {
2893         SETERRNO(EBADF,SS_IVCHAN);
2894         return -1;
2895     }
2896     while (PerlLIO_close(fd) != 0) {
2897         if (errno != EINTR) {
2898             code = -1;
2899             break;
2900         }
2901         /* EINTR */
2902         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2903             return -1;
2904     }
2905     if (code == 0) {
2906         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2907     }
2908     return code;
2909 }
2910
2911 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2912     sizeof(PerlIO_funcs),
2913     "unix",
2914     sizeof(PerlIOUnix),
2915     PERLIO_K_RAW,
2916     PerlIOUnix_pushed,
2917     PerlIOBase_popped,
2918     PerlIOUnix_open,
2919     PerlIOBase_binmode,         /* binmode */
2920     NULL,
2921     PerlIOUnix_fileno,
2922     PerlIOUnix_dup,
2923     PerlIOUnix_read,
2924     PerlIOBase_unread,
2925     PerlIOUnix_write,
2926     PerlIOUnix_seek,
2927     PerlIOUnix_tell,
2928     PerlIOUnix_close,
2929     PerlIOBase_noop_ok,         /* flush */
2930     PerlIOBase_noop_fail,       /* fill */
2931     PerlIOBase_eof,
2932     PerlIOBase_error,
2933     PerlIOBase_clearerr,
2934     PerlIOBase_setlinebuf,
2935     NULL,                       /* get_base */
2936     NULL,                       /* get_bufsiz */
2937     NULL,                       /* get_ptr */
2938     NULL,                       /* get_cnt */
2939     NULL,                       /* set_ptrcnt */
2940 };
2941
2942 /*--------------------------------------------------------------------------------------*/
2943 /*
2944  * stdio as a layer
2945  */
2946
2947 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2948 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2949    broken by the last second glibc 2.3 fix
2950  */
2951 #define STDIO_BUFFER_WRITABLE
2952 #endif
2953
2954
2955 typedef struct {
2956     struct _PerlIO base;
2957     FILE *stdio;                /* The stream */
2958 } PerlIOStdio;
2959
2960 IV
2961 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2962 {
2963     PERL_UNUSED_CONTEXT;
2964
2965     if (PerlIOValid(f)) {
2966         FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2967         if (s)
2968             return PerlSIO_fileno(s);
2969     }
2970     errno = EBADF;
2971     return -1;
2972 }
2973
2974 char *
2975 PerlIOStdio_mode(const char *mode, char *tmode)
2976 {
2977     char * const ret = tmode;
2978     if (mode) {
2979         while (*mode) {
2980             *tmode++ = *mode++;
2981         }
2982     }
2983 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2984     *tmode++ = 'b';
2985 #endif
2986     *tmode = '\0';
2987     return ret;
2988 }
2989
2990 IV
2991 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2992 {
2993     PerlIO *n;
2994     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2995         PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2996         if (toptab == tab) {
2997             /* Top is already stdio - pop self (duplicate) and use original */
2998             PerlIO_pop(aTHX_ f);
2999             return 0;
3000         } else {
3001             const int fd = PerlIO_fileno(n);
3002             char tmode[8];
3003             FILE *stdio;
3004             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
3005                             mode = PerlIOStdio_mode(mode, tmode)))) {
3006                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3007                 /* We never call down so do any pending stuff now */
3008                 PerlIO_flush(PerlIONext(f));
3009             }
3010             else {
3011                 return -1;
3012             }
3013         }
3014     }
3015     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3016 }
3017
3018
3019 PerlIO *
3020 PerlIO_importFILE(FILE *stdio, const char *mode)
3021 {
3022     dTHX;
3023     PerlIO *f = NULL;
3024     if (stdio) {
3025         PerlIOStdio *s;
3026         if (!mode || !*mode) {
3027             /* We need to probe to see how we can open the stream
3028                so start with read/write and then try write and read
3029                we dup() so that we can fclose without loosing the fd.
3030
3031                Note that the errno value set by a failing fdopen
3032                varies between stdio implementations.
3033              */
3034             const int fd = PerlLIO_dup(fileno(stdio));
3035             FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3036             if (!f2) {
3037                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3038             }
3039             if (!f2) {
3040                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3041             }
3042             if (!f2) {
3043                 /* Don't seem to be able to open */
3044                 PerlLIO_close(fd);
3045                 return f;
3046             }
3047             fclose(f2);
3048         }
3049         if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3050             s = PerlIOSelf(f, PerlIOStdio);
3051             s->stdio = stdio;
3052             PerlIOUnix_refcnt_inc(fileno(stdio));
3053         }
3054     }
3055     return f;
3056 }
3057
3058 PerlIO *
3059 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3060                  IV n, const char *mode, int fd, int imode,
3061                  int perm, PerlIO *f, int narg, SV **args)
3062 {
3063     char tmode[8];
3064     if (PerlIOValid(f)) {
3065         const char * const path = SvPV_nolen_const(*args);
3066         PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3067         FILE *stdio;
3068         PerlIOUnix_refcnt_dec(fileno(s->stdio));
3069         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3070                             s->stdio);
3071         if (!s->stdio)
3072             return NULL;
3073         s->stdio = stdio;
3074         PerlIOUnix_refcnt_inc(fileno(s->stdio));
3075         return f;
3076     }
3077     else {
3078         if (narg > 0) {
3079             const char * const path = SvPV_nolen_const(*args);
3080             if (*mode == IoTYPE_NUMERIC) {
3081                 mode++;
3082                 fd = PerlLIO_open3(path, imode, perm);
3083             }
3084             else {
3085                 FILE *stdio;
3086                 bool appended = FALSE;
3087 #ifdef __CYGWIN__
3088                 /* Cygwin wants its 'b' early. */
3089                 appended = TRUE;
3090                 mode = PerlIOStdio_mode(mode, tmode);
3091 #endif
3092                 stdio = PerlSIO_fopen(path, mode);
3093                 if (stdio) {
3094                     if (!f) {
3095                         f = PerlIO_allocate(aTHX);
3096                     }
3097                     if (!appended)
3098                         mode = PerlIOStdio_mode(mode, tmode);
3099                     f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3100                     if (f) {
3101                         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3102                         PerlIOUnix_refcnt_inc(fileno(stdio));
3103                     } else {
3104                         PerlSIO_fclose(stdio);
3105                     }
3106                     return f;
3107                 }
3108                 else {
3109                     return NULL;
3110                 }
3111             }
3112         }
3113         if (fd >= 0) {
3114             FILE *stdio = NULL;
3115             int init = 0;
3116             if (*mode == IoTYPE_IMPLICIT) {
3117                 init = 1;
3118                 mode++;
3119             }
3120             if (init) {
3121                 switch (fd) {
3122                 case 0:
3123                     stdio = PerlSIO_stdin;
3124                     break;
3125                 case 1:
3126                     stdio = PerlSIO_stdout;
3127                     break;
3128                 case 2:
3129                     stdio = PerlSIO_stderr;
3130                     break;
3131                 }
3132             }
3133             else {
3134                 stdio = PerlSIO_fdopen(fd, mode =
3135                                        PerlIOStdio_mode(mode, tmode));
3136             }
3137             if (stdio) {
3138                 if (!f) {
3139                     f = PerlIO_allocate(aTHX);
3140                 }
3141                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3142                     PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3143                     PerlIOUnix_refcnt_inc(fileno(stdio));
3144                 }
3145                 return f;
3146             }
3147         }
3148     }
3149     return NULL;
3150 }
3151
3152 PerlIO *
3153 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3154 {
3155     /* This assumes no layers underneath - which is what
3156        happens, but is not how I remember it. NI-S 2001/10/16
3157      */
3158     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3159         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3160         const int fd = fileno(stdio);
3161         char mode[8];
3162         if (flags & PERLIO_DUP_FD) {
3163             const int dfd = PerlLIO_dup(fileno(stdio));
3164             if (dfd >= 0) {
3165                 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3166                 goto set_this;
3167             }
3168             else {
3169                 NOOP;
3170                 /* FIXME: To avoid messy error recovery if dup fails
3171                    re-use the existing stdio as though flag was not set
3172                  */
3173             }
3174         }
3175         stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3176     set_this:
3177         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3178         if(stdio) {
3179             PerlIOUnix_refcnt_inc(fileno(stdio));
3180         }
3181     }
3182     return f;
3183 }
3184
3185 static int
3186 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3187 {
3188     PERL_UNUSED_CONTEXT;
3189
3190     /* XXX this could use PerlIO_canset_fileno() and
3191      * PerlIO_set_fileno() support from Configure
3192      */
3193 #  if defined(__UCLIBC__)
3194     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3195     f->__filedes = -1;
3196     return 1;
3197 #  elif defined(__GLIBC__)
3198     /* There may be a better way for GLIBC:
3199         - libio.h defines a flag to not close() on cleanup
3200      */
3201     f->_fileno = -1;
3202     return 1;
3203 #  elif defined(__sun__)
3204     PERL_UNUSED_ARG(f);
3205     return 0;
3206 #  elif defined(__hpux)
3207     f->__fileH = 0xff;
3208     f->__fileL = 0xff;
3209     return 1;
3210    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3211       your platform does not have special entry try this one.
3212       [For OSF only have confirmation for Tru64 (alpha)
3213       but assume other OSFs will be similar.]
3214     */
3215 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3216     f->_file = -1;
3217     return 1;
3218 #  elif defined(__FreeBSD__)
3219     /* There may be a better way on FreeBSD:
3220         - we could insert a dummy func in the _close function entry
3221         f->_close = (int (*)(void *)) dummy_close;
3222      */
3223     f->_file = -1;
3224     return 1;
3225 #  elif defined(__OpenBSD__)
3226     /* There may be a better way on OpenBSD:
3227         - we could insert a dummy func in the _close function entry
3228         f->_close = (int (*)(void *)) dummy_close;
3229      */
3230     f->_file = -1;
3231     return 1;
3232 #  elif defined(__EMX__)
3233     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3234     f->_handle = -1;
3235     return 1;
3236 #  elif defined(__CYGWIN__)
3237     /* There may be a better way on CYGWIN:
3238         - we could insert a dummy func in the _close function entry
3239         f->_close = (int (*)(void *)) dummy_close;
3240      */
3241     f->_file = -1;
3242     return 1;
3243 #  elif defined(WIN32)
3244 #    if defined(__BORLANDC__)
3245     f->fd = PerlLIO_dup(fileno(f));
3246 #    elif defined(UNDER_CE)
3247     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3248        structure at all
3249      */
3250 #    else
3251     f->_file = -1;
3252 #    endif
3253     return 1;
3254 #  else
3255 #if 0
3256     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3257        (which isn't thread safe) instead
3258      */
3259 #    error "Don't know how to set FILE.fileno on your platform"
3260 #endif
3261     PERL_UNUSED_ARG(f);
3262     return 0;
3263 #  endif
3264 }
3265
3266 IV
3267 PerlIOStdio_close(pTHX_ PerlIO *f)
3268 {
3269     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3270     if (!stdio) {
3271         errno = EBADF;
3272         return -1;
3273     }
3274     else {
3275         const int fd = fileno(stdio);
3276         int invalidate = 0;
3277         IV result = 0;
3278         int dupfd = -1;
3279         dSAVEDERRNO;
3280 #ifdef USE_ITHREADS
3281         dVAR;
3282 #endif
3283 #ifdef SOCKS5_VERSION_NAME
3284         /* Socks lib overrides close() but stdio isn't linked to
3285            that library (though we are) - so we must call close()
3286            on sockets on stdio's behalf.
3287          */
3288         int optval;
3289         Sock_size_t optlen = sizeof(int);
3290         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3291             invalidate = 1;
3292 #endif
3293         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3294            that a subsequent fileno() on it returns -1. Don't want to croak()
3295            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3296            trying to close an already closed handle which somehow it still has
3297            a reference to. (via.xs, I'm looking at you).  */
3298         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3299             /* File descriptor still in use */
3300             invalidate = 1;
3301         }
3302         if (invalidate) {
3303             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3304             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3305                 return 0;
3306             if (stdio == stdout || stdio == stderr)
3307                 return PerlIO_flush(f);
3308             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3309                Use Sarathy's trick from maint-5.6 to invalidate the
3310                fileno slot of the FILE *
3311             */
3312             result = PerlIO_flush(f);
3313             SAVE_ERRNO;
3314             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3315             if (!invalidate) {
3316 #ifdef USE_ITHREADS
3317                 MUTEX_LOCK(&PL_perlio_mutex);
3318                 /* Right. We need a mutex here because for a brief while we
3319                    will have the situation that fd is actually closed. Hence if
3320                    a second thread were to get into this block, its dup() would
3321                    likely return our fd as its dupfd. (after all, it is closed)
3322                    Then if we get to the dup2() first, we blat the fd back
3323                    (messing up its temporary as a side effect) only for it to
3324                    then close its dupfd (== our fd) in its close(dupfd) */
3325
3326                 /* There is, of course, a race condition, that any other thread
3327                    trying to input/output/whatever on this fd will be stuffed
3328                    for the duration of this little manoeuvrer. Perhaps we
3329                    should hold an IO mutex for the duration of every IO
3330                    operation if we know that invalidate doesn't work on this
3331                    platform, but that would suck, and could kill performance.
3332
3333                    Except that correctness trumps speed.
3334                    Advice from klortho #11912. */
3335 #endif
3336                 dupfd = PerlLIO_dup(fd);
3337 #ifdef USE_ITHREADS
3338                 if (dupfd < 0) {
3339                     MUTEX_UNLOCK(&PL_perlio_mutex);
3340                     /* Oh cXap. This isn't going to go well. Not sure if we can
3341                        recover from here, or if closing this particular FILE *
3342                        is a good idea now.  */
3343                 }
3344 #endif
3345             }
3346         } else {
3347             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3348         }
3349         result = PerlSIO_fclose(stdio);
3350         /* We treat error from stdio as success if we invalidated
3351            errno may NOT be expected EBADF
3352          */
3353         if (invalidate && result != 0) {
3354             RESTORE_ERRNO;
3355             result = 0;
3356         }
3357 #ifdef SOCKS5_VERSION_NAME
3358         /* in SOCKS' case, let close() determine return value */
3359         result = close(fd);
3360 #endif
3361         if (dupfd >= 0) {
3362             PerlLIO_dup2(dupfd,fd);
3363             PerlLIO_close(dupfd);
3364 #ifdef USE_ITHREADS
3365             MUTEX_UNLOCK(&PL_perlio_mutex);
3366 #endif
3367         }
3368         return result;
3369     }
3370 }
3371
3372 SSize_t
3373 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3374 {
3375     dVAR;
3376     FILE * s;
3377     SSize_t got = 0;
3378     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3379         return -1;
3380     s = PerlIOSelf(f, PerlIOStdio)->stdio;
3381     for (;;) {
3382         if (count == 1) {
3383             STDCHAR *buf = (STDCHAR *) vbuf;
3384             /*
3385              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3386              * stdio does not do that for fread()
3387              */
3388             const int ch = PerlSIO_fgetc(s);
3389             if (ch != EOF) {
3390                 *buf = ch;
3391                 got = 1;
3392             }
3393         }
3394         else
3395             got = PerlSIO_fread(vbuf, 1, count, s);
3396         if (got == 0 && PerlSIO_ferror(s))
3397             got = -1;
3398         if (got >= 0 || errno != EINTR)
3399             break;
3400         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3401             return -1;
3402         SETERRNO(0,0);  /* just in case */
3403     }
3404     return got;
3405 }
3406
3407 SSize_t
3408 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3409 {
3410     SSize_t unread = 0;
3411     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3412
3413 #ifdef STDIO_BUFFER_WRITABLE
3414     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3415         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3416         STDCHAR *base = PerlIO_get_base(f);
3417         SSize_t cnt   = PerlIO_get_cnt(f);
3418         STDCHAR *ptr  = PerlIO_get_ptr(f);
3419         SSize_t avail = ptr - base;
3420         if (avail > 0) {
3421             if (avail > count) {
3422                 avail = count;
3423             }
3424             ptr -= avail;
3425             Move(buf-avail,ptr,avail,STDCHAR);
3426             count -= avail;
3427             unread += avail;
3428             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3429             if (PerlSIO_feof(s) && unread >= 0)
3430                 PerlSIO_clearerr(s);
3431         }
3432     }
3433     else
3434 #endif
3435     if (PerlIO_has_cntptr(f)) {
3436         /* We can get pointer to buffer but not its base
3437            Do ungetc() but check chars are ending up in the
3438            buffer
3439          */
3440         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3441         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3442         while (count > 0) {
3443             const int ch = *--buf & 0xFF;
3444             if (ungetc(ch,s) != ch) {
3445                 /* ungetc did not work */
3446                 break;
3447             }
3448             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3449                 /* Did not change pointer as expected */
3450                 fgetc(s);  /* get char back again */
3451                 break;
3452             }
3453             /* It worked ! */
3454             count--;
3455             unread++;
3456         }
3457     }
3458
3459     if (count > 0) {
3460         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3461     }
3462     return unread;
3463 }
3464
3465 SSize_t
3466 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3467 {
3468     dVAR;
3469     SSize_t got;
3470     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3471         return -1;
3472     for (;;) {
3473         got = PerlSIO_fwrite(vbuf, 1, count,
3474                               PerlIOSelf(f, PerlIOStdio)->stdio);
3475         if (got >= 0 || errno != EINTR)
3476             break;
3477         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3478             return -1;
3479         SETERRNO(0,0);  /* just in case */
3480     }
3481     return got;
3482 }
3483
3484 IV
3485 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3486 {
3487     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3488     PERL_UNUSED_CONTEXT;
3489
3490     return PerlSIO_fseek(stdio, offset, whence);
3491 }
3492
3493 Off_t
3494 PerlIOStdio_tell(pTHX_ PerlIO *f)
3495 {
3496     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3497     PERL_UNUSED_CONTEXT;
3498
3499     return PerlSIO_ftell(stdio);
3500 }
3501
3502 IV
3503 PerlIOStdio_flush(pTHX_ PerlIO *f)
3504 {
3505     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3506     PERL_UNUSED_CONTEXT;
3507
3508     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3509         return PerlSIO_fflush(stdio);
3510     }
3511     else {
3512         NOOP;
3513 #if 0
3514         /*
3515          * FIXME: This discards ungetc() and pre-read stuff which is not
3516          * right if this is just a "sync" from a layer above Suspect right
3517          * design is to do _this_ but not have layer above flush this
3518          * layer read-to-read
3519          */
3520         /*
3521          * Not writeable - sync by attempting a seek
3522          */
3523         dSAVE_ERRNO;
3524         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3525             RESTORE_ERRNO;
3526 #endif
3527     }
3528     return 0;
3529 }
3530
3531 IV
3532 PerlIOStdio_eof(pTHX_ PerlIO *f)
3533 {
3534     PERL_UNUSED_CONTEXT;
3535
3536     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3537 }
3538
3539 IV
3540 PerlIOStdio_error(pTHX_ PerlIO *f)
3541 {
3542     PERL_UNUSED_CONTEXT;
3543
3544     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3545 }
3546
3547 void
3548 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3549 {
3550     PERL_UNUSED_CONTEXT;
3551
3552     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3553 }
3554
3555 void
3556 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3557 {
3558     PERL_UNUSED_CONTEXT;
3559
3560 #ifdef HAS_SETLINEBUF
3561     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3562 #else
3563     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3564 #endif
3565 }
3566
3567 #ifdef FILE_base
3568 STDCHAR *
3569 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3570 {
3571     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3572     return (STDCHAR*)PerlSIO_get_base(stdio);
3573 }
3574
3575 Size_t
3576 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3577 {
3578     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3579     return PerlSIO_get_bufsiz(stdio);
3580 }
3581 #endif
3582
3583 #ifdef USE_STDIO_PTR
3584 STDCHAR *
3585 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3586 {
3587     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3588     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3589 }
3590
3591 SSize_t
3592 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3593 {
3594     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3595     return PerlSIO_get_cnt(stdio);
3596 }
3597
3598 void
3599 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3600 {
3601     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3602     if (ptr != NULL) {
3603 #ifdef STDIO_PTR_LVALUE
3604         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3605 #ifdef STDIO_PTR_LVAL_SETS_CNT
3606         assert(PerlSIO_get_cnt(stdio) == (cnt));
3607 #endif
3608 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3609         /*
3610          * Setting ptr _does_ change cnt - we are done
3611          */
3612         return;
3613 #endif
3614 #else                           /* STDIO_PTR_LVALUE */
3615         PerlProc_abort();
3616 #endif                          /* STDIO_PTR_LVALUE */
3617     }
3618     /*
3619      * Now (or only) set cnt
3620      */
3621 #ifdef STDIO_CNT_LVALUE
3622     PerlSIO_set_cnt(stdio, cnt);
3623 #else                           /* STDIO_CNT_LVALUE */
3624 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3625     PerlSIO_set_ptr(stdio,
3626                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3627                                               cnt));
3628 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3629     PerlProc_abort();
3630 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3631 #endif                          /* STDIO_CNT_LVALUE */
3632 }
3633
3634
3635 #endif
3636
3637 IV
3638 PerlIOStdio_fill(pTHX_ PerlIO *f)
3639 {
3640     FILE * stdio;
3641     int c;
3642     PERL_UNUSED_CONTEXT;
3643     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3644         return -1;
3645     stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3646
3647     /*
3648      * fflush()ing read-only streams can cause trouble on some stdio-s
3649      */
3650     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3651         if (PerlSIO_fflush(stdio) != 0)
3652             return EOF;
3653     }
3654     for (;;) {
3655         c = PerlSIO_fgetc(stdio);
3656         if (c != EOF)
3657             break;
3658         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3659             return EOF;
3660         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3661             return -1;
3662         SETERRNO(0,0);
3663     }
3664
3665 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3666
3667 #ifdef STDIO_BUFFER_WRITABLE
3668     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3669         /* Fake ungetc() to the real buffer in case system's ungetc
3670            goes elsewhere
3671          */
3672         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3673         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3674         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3675         if (ptr == base+1) {
3676             *--ptr = (STDCHAR) c;
3677             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3678             if (PerlSIO_feof(stdio))
3679                 PerlSIO_clearerr(stdio);
3680             return 0;
3681         }
3682     }
3683     else
3684 #endif
3685     if (PerlIO_has_cntptr(f)) {
3686         STDCHAR ch = c;
3687         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3688             return 0;
3689         }
3690     }
3691 #endif
3692
3693 #if defined(VMS)
3694     /* An ungetc()d char is handled separately from the regular
3695      * buffer, so we stuff it in the buffer ourselves.
3696      * Should never get called as should hit code above
3697      */
3698     *(--((*stdio)->_ptr)) = (unsigned char) c;
3699     (*stdio)->_cnt++;
3700 #else
3701     /* If buffer snoop scheme above fails fall back to
3702        using ungetc().
3703      */
3704     if (PerlSIO_ungetc(c, stdio) != c)
3705         return EOF;
3706 #endif
3707     return 0;
3708 }
3709
3710
3711
3712 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3713     sizeof(PerlIO_funcs),
3714     "stdio",
3715     sizeof(PerlIOStdio),
3716     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3717     PerlIOStdio_pushed,
3718     PerlIOBase_popped,
3719     PerlIOStdio_open,
3720     PerlIOBase_binmode,         /* binmode */
3721     NULL,
3722     PerlIOStdio_fileno,
3723     PerlIOStdio_dup,
3724     PerlIOStdio_read,
3725     PerlIOStdio_unread,
3726     PerlIOStdio_write,
3727     PerlIOStdio_seek,
3728     PerlIOStdio_tell,
3729     PerlIOStdio_close,
3730     PerlIOStdio_flush,
3731     PerlIOStdio_fill,
3732     PerlIOStdio_eof,
3733     PerlIOStdio_error,
3734     PerlIOStdio_clearerr,
3735     PerlIOStdio_setlinebuf,
3736 #ifdef FILE_base
3737     PerlIOStdio_get_base,
3738     PerlIOStdio_get_bufsiz,
3739 #else
3740     NULL,
3741     NULL,
3742 #endif
3743 #ifdef USE_STDIO_PTR
3744     PerlIOStdio_get_ptr,
3745     PerlIOStdio_get_cnt,
3746 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3747     PerlIOStdio_set_ptrcnt,
3748 #   else
3749     NULL,
3750 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3751 #else
3752     NULL,
3753     NULL,
3754     NULL,
3755 #endif /* USE_STDIO_PTR */
3756 };
3757
3758 /* Note that calls to PerlIO_exportFILE() are reversed using
3759  * PerlIO_releaseFILE(), not importFILE. */
3760 FILE *
3761 PerlIO_exportFILE(PerlIO * f, const char *mode)
3762 {
3763     dTHX;
3764     FILE *stdio = NULL;
3765     if (PerlIOValid(f)) {
3766         char buf[8];
3767         PerlIO_flush(f);
3768         if (!mode || !*mode) {
3769             mode = PerlIO_modestr(f, buf);
3770         }
3771         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3772         if (stdio) {
3773             PerlIOl *l = *f;
3774             PerlIO *f2;
3775             /* De-link any lower layers so new :stdio sticks */
3776             *f = NULL;
3777             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3778                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3779                 s->stdio = stdio;
3780                 PerlIOUnix_refcnt_inc(fileno(stdio));
3781                 /* Link previous lower layers under new one */
3782                 *PerlIONext(f) = l;
3783             }
3784             else {
3785                 /* restore layers list */
3786                 *f = l;
3787             }
3788         }
3789     }
3790     return stdio;
3791 }
3792
3793
3794 FILE *
3795 PerlIO_findFILE(PerlIO *f)
3796 {
3797     PerlIOl *l = *f;
3798     FILE *stdio;
3799     while (l) {
3800         if (l->tab == &PerlIO_stdio) {
3801             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3802             return s->stdio;
3803         }
3804         l = *PerlIONext(&l);
3805     }
3806     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3807     /* However, we're not really exporting a FILE * to someone else (who
3808        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3809        So we need to undo its reference count increase on the underlying file
3810        descriptor. We have to do this, because if the loop above returns you
3811        the FILE *, then *it* didn't increase any reference count. So there's
3812        only one way to be consistent. */
3813     stdio = PerlIO_exportFILE(f, NULL);
3814     if (stdio) {
3815         const int fd = fileno(stdio);
3816         if (fd >= 0)
3817             PerlIOUnix_refcnt_dec(fd);
3818     }
3819     return stdio;
3820 }
3821
3822 /* Use this to reverse PerlIO_exportFILE calls. */
3823 void
3824 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3825 {
3826     dVAR;
3827     PerlIOl *l;
3828     while ((l = *p)) {
3829         if (l->tab == &PerlIO_stdio) {
3830             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3831             if (s->stdio == f) {
3832                 dTHX;
3833                 const int fd = fileno(f);
3834                 if (fd >= 0)
3835                     PerlIOUnix_refcnt_dec(fd);
3836                 PerlIO_pop(aTHX_ p);
3837                 return;
3838             }
3839         }
3840         p = PerlIONext(p);
3841     }
3842     return;
3843 }
3844
3845 /*--------------------------------------------------------------------------------------*/
3846 /*
3847  * perlio buffer layer
3848  */
3849
3850 IV
3851 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3852 {
3853     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3854     const int fd = PerlIO_fileno(f);
3855     if (fd >= 0 && PerlLIO_isatty(fd)) {
3856         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3857     }
3858     if (*PerlIONext(f)) {
3859         const Off_t posn = PerlIO_tell(PerlIONext(f));
3860         if (posn != (Off_t) - 1) {
3861             b->posn = posn;
3862         }
3863     }
3864     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3865 }
3866
3867 PerlIO *
3868 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3869                IV n, const char *mode, int fd, int imode, int perm,
3870                PerlIO *f, int narg, SV **args)
3871 {
3872     if (PerlIOValid(f)) {
3873         PerlIO *next = PerlIONext(f);
3874         PerlIO_funcs *tab =
3875              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3876         if (tab && tab->Open)
3877              next =
3878                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3879                                next, narg, args);
3880         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3881             return NULL;
3882         }
3883     }
3884     else {
3885         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3886         int init = 0;
3887         if (*mode == IoTYPE_IMPLICIT) {
3888             init = 1;
3889             /*
3890              * mode++;
3891              */
3892         }
3893         if (tab && tab->Open)
3894              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3895                               f, narg, args);
3896         else
3897              SETERRNO(EINVAL, LIB_INVARG);
3898         if (f) {
3899             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3900                 /*
3901                  * if push fails during open, open fails. close will pop us.
3902                  */
3903                 PerlIO_close (f);
3904                 return NULL;
3905             } else {
3906                 fd = PerlIO_fileno(f);
3907                 if (init && fd == 2) {
3908                     /*
3909                      * Initial stderr is unbuffered
3910                      */
3911                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3912                 }
3913 #ifdef PERLIO_USING_CRLF
3914 #  ifdef PERLIO_IS_BINMODE_FD
3915                 if (PERLIO_IS_BINMODE_FD(fd))
3916                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3917                 else
3918 #  endif
3919                 /*
3920                  * do something about failing setmode()? --jhi
3921                  */
3922                 PerlLIO_setmode(fd, O_BINARY);
3923 #endif
3924 #ifdef VMS
3925 #include <rms.h>
3926                 /* Enable line buffering with record-oriented regular files
3927                  * so we don't introduce an extraneous record boundary when
3928                  * the buffer fills up.
3929                  */
3930                 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3931                     Stat_t st;
3932                     if (PerlLIO_fstat(fd, &st) == 0
3933                         && S_ISREG(st.st_mode)
3934                         && (st.st_fab_rfm == FAB$C_VAR
3935                             || st.st_fab_rfm == FAB$C_VFC)) {
3936                         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3937                     }
3938                 }
3939 #endif
3940             }
3941         }
3942     }
3943     return f;
3944 }
3945
3946 /*
3947  * This "flush" is akin to sfio's sync in that it handles files in either
3948  * read or write state.  For write state, we put the postponed data through
3949  * the next layers.  For read state, we seek() the next layers to the
3950  * offset given by current position in the buffer, and discard the buffer
3951  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3952  * in any case?).  Then the pass the stick further in chain.
3953  */
3954 IV
3955 PerlIOBuf_flush(pTHX_ PerlIO *f)
3956 {
3957     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3958     int code = 0;
3959     PerlIO *n = PerlIONext(f);
3960     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3961         /*
3962          * write() the buffer
3963          */
3964         const STDCHAR *buf = b->buf;
3965         const STDCHAR *p = buf;
3966         while (p < b->ptr) {
3967             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3968             if (count > 0) {
3969                 p += count;
3970             }
3971             else if (count < 0 || PerlIO_error(n)) {
3972                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3973                 code = -1;
3974                 break;
3975             }
3976         }
3977         b->posn += (p - buf);
3978     }
3979     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3980         STDCHAR *buf = PerlIO_get_base(f);
3981         /*
3982          * Note position change
3983          */
3984         b->posn += (b->ptr - buf);
3985         if (b->ptr < b->end) {
3986             /* We did not consume all of it - try and seek downstream to
3987                our logical position
3988              */
3989             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3990                 /* Reload n as some layers may pop themselves on seek */
3991                 b->posn = PerlIO_tell(n = PerlIONext(f));
3992             }
3993             else {
3994                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3995                    data is lost for good - so return saying "ok" having undone
3996                    the position adjust
3997                  */
3998                 b->posn -= (b->ptr - buf);
3999                 return code;
4000             }
4001         }
4002     }
4003     b->ptr = b->end = b->buf;
4004     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4005     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4006     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4007         code = -1;
4008     return code;
4009 }
4010
4011 /* This discards the content of the buffer after b->ptr, and rereads
4012  * the buffer from the position off in the layer downstream; here off
4013  * is at offset corresponding to b->ptr - b->buf.
4014  */
4015 IV
4016 PerlIOBuf_fill(pTHX_ PerlIO *f)
4017 {
4018     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4019     PerlIO *n = PerlIONext(f);
4020     SSize_t avail;
4021     /*
4022      * Down-stream flush is defined not to loose read data so is harmless.
4023      * we would not normally be fill'ing if there was data left in anycase.
4024      */
4025     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
4026         return -1;
4027     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4028         PerlIOBase_flush_linebuf(aTHX);
4029
4030     if (!b->buf)
4031         PerlIO_get_base(f);     /* allocate via vtable */
4032
4033     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4034
4035     b->ptr = b->end = b->buf;
4036
4037     if (!PerlIOValid(n)) {
4038         PerlIOBase(f)->flags |= PERLIO_F_EOF;
4039         return -1;
4040     }
4041
4042     if (PerlIO_fast_gets(n)) {
4043         /*
4044          * Layer below is also buffered. We do _NOT_ want to call its
4045          * ->Read() because that will loop till it gets what we asked for
4046          * which may hang on a pipe etc. Instead take anything it has to
4047          * hand, or ask it to fill _once_.
4048          */
4049         avail = PerlIO_get_cnt(n);
4050         if (avail <= 0) {
4051             avail = PerlIO_fill(n);
4052             if (avail == 0)
4053                 avail = PerlIO_get_cnt(n);
4054             else {
4055                 if (!PerlIO_error(n) && PerlIO_eof(n))
4056                     avail = 0;
4057             }
4058         }
4059         if (avail > 0) {
4060             STDCHAR *ptr = PerlIO_get_ptr(n);
4061             const SSize_t cnt = avail;
4062             if (avail > (SSize_t)b->bufsiz)
4063                 avail = b->bufsiz;
4064             Copy(ptr, b->buf, avail, STDCHAR);
4065             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4066         }
4067     }
4068     else {
4069         avail = PerlIO_read(n, b->ptr, b->bufsiz);
4070     }
4071     if (avail <= 0) {
4072         if (avail == 0)
4073             PerlIOBase(f)->flags |= PERLIO_F_EOF;
4074         else
4075             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4076         return -1;
4077     }
4078     b->end = b->buf + avail;
4079     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4080     return 0;
4081 }
4082
4083 SSize_t
4084 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4085 {
4086     if (PerlIOValid(f)) {
4087         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4088         if (!b->ptr)
4089             PerlIO_get_base(f);
4090         return PerlIOBase_read(aTHX_ f, vbuf, count);
4091     }
4092     return 0;
4093 }
4094
4095 SSize_t
4096 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4097 {
4098     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4099     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4100     SSize_t unread = 0;
4101     SSize_t avail;
4102     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4103         PerlIO_flush(f);
4104     if (!b->buf)
4105         PerlIO_get_base(f);
4106     if (b->buf) {
4107         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4108             /*
4109              * Buffer is already a read buffer, we can overwrite any chars
4110              * which have been read back to buffer start
4111              */
4112             avail = (b->ptr - b->buf);
4113         }
4114         else {
4115             /*
4116              * Buffer is idle, set it up so whole buffer is available for
4117              * unread
4118              */
4119             avail = b->bufsiz;
4120             b->end = b->buf + avail;
4121             b->ptr = b->end;
4122             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4123             /*
4124              * Buffer extends _back_ from where we are now
4125              */
4126             b->posn -= b->bufsiz;
4127         }
4128         if (avail > (SSize_t) count) {
4129             /*
4130              * If we have space for more than count, just move count
4131              */
4132             avail = count;
4133         }
4134         if (avail > 0) {
4135             b->ptr -= avail;
4136             buf -= avail;
4137             /*
4138              * In simple stdio-like ungetc() case chars will be already
4139              * there
4140              */
4141             if (buf != b->ptr) {
4142                 Copy(buf, b->ptr, avail, STDCHAR);
4143             }
4144             count -= avail;
4145             unread += avail;
4146             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4147         }
4148     }
4149     if (count > 0) {
4150         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4151     }
4152     return unread;
4153 }
4154
4155 SSize_t
4156 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4157 {
4158     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4159     const STDCHAR *buf = (const STDCHAR *) vbuf;
4160     const STDCHAR *flushptr = buf;
4161     Size_t written = 0;
4162     if (!b->buf)
4163         PerlIO_get_base(f);
4164     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4165         return 0;
4166     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4167         if (PerlIO_flush(f) != 0) {
4168             return 0;
4169         }
4170     }
4171     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4172         flushptr = buf + count;
4173         while (flushptr > buf && *(flushptr - 1) != '\n')
4174             --flushptr;
4175     }
4176     while (count > 0) {
4177         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4178         if ((SSize_t) count < avail)
4179             avail = count;
4180         if (flushptr > buf && flushptr <= buf + avail)
4181             avail = flushptr - buf;
4182         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4183         if (avail) {
4184             Copy(buf, b->ptr, avail, STDCHAR);
4185             count -= avail;
4186             buf += avail;
4187             written += avail;
4188             b->ptr += avail;
4189             if (buf == flushptr)
4190                 PerlIO_flush(f);
4191         }
4192         if (b->ptr >= (b->buf + b->bufsiz))
4193             if (PerlIO_flush(f) == -1)
4194                 return -1;
4195     }
4196     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4197         PerlIO_flush(f);
4198     return written;
4199 }
4200
4201 IV
4202 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4203 {
4204     IV code;
4205     if ((code = PerlIO_flush(f)) == 0) {
4206         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4207         code = PerlIO_seek(PerlIONext(f), offset, whence);
4208         if (code == 0) {
4209             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4210             b->posn = PerlIO_tell(PerlIONext(f));
4211         }
4212     }
4213     return code;
4214 }
4215
4216 Off_t
4217 PerlIOBuf_tell(pTHX_ PerlIO *f)
4218 {
4219     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4220     /*
4221      * b->posn is file position where b->buf was read, or will be written
4222      */
4223     Off_t posn = b->posn;
4224     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4225         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4226 #if 1
4227         /* As O_APPEND files are normally shared in some sense it is better
4228            to flush :
4229          */
4230         PerlIO_flush(f);
4231 #else
4232         /* when file is NOT shared then this is sufficient */
4233         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4234 #endif
4235         posn = b->posn = PerlIO_tell(PerlIONext(f));
4236     }
4237     if (b->buf) {
4238         /*
4239          * If buffer is valid adjust position by amount in buffer
4240          */
4241         posn += (b->ptr - b->buf);
4242     }
4243     return posn;
4244 }
4245
4246 IV
4247 PerlIOBuf_popped(pTHX_ PerlIO *f)
4248 {
4249     const IV code = PerlIOBase_popped(aTHX_ f);
4250     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4251     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4252         Safefree(b->buf);
4253     }
4254     b->ptr = b->end = b->buf = NULL;
4255     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4256     return code;
4257 }
4258
4259 IV
4260 PerlIOBuf_close(pTHX_ PerlIO *f)
4261 {
4262     const IV code = PerlIOBase_close(aTHX_ f);
4263     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4264     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4265         Safefree(b->buf);
4266     }
4267     b->ptr = b->end = b->buf = NULL;
4268     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4269     return code;
4270 }
4271
4272 STDCHAR *
4273 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4274 {
4275     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4276     if (!b->buf)
4277         PerlIO_get_base(f);
4278     return b->ptr;
4279 }
4280
4281 SSize_t
4282 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4283 {
4284     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4285     if (!b->buf)
4286         PerlIO_get_base(f);
4287     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4288         return (b->end - b->ptr);
4289     return 0;
4290 }
4291
4292 STDCHAR *
4293 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4294 {
4295     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4296     PERL_UNUSED_CONTEXT;
4297
4298     if (!b->buf) {
4299         if (!b->bufsiz)
4300             b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4301         Newxz(b->buf,b->bufsiz, STDCHAR);
4302         if (!b->buf) {
4303             b->buf = (STDCHAR *) & b->oneword;
4304             b->bufsiz = sizeof(b->oneword);
4305         }
4306         b->end = b->ptr = b->buf;
4307     }
4308     return b->buf;
4309 }
4310
4311 Size_t
4312 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4313 {
4314     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4315     if (!b->buf)
4316         PerlIO_get_base(f);
4317     return (b->end - b->buf);
4318 }
4319
4320 void
4321 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4322 {
4323     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4324 #ifndef DEBUGGING
4325     PERL_UNUSED_ARG(cnt);
4326 #endif
4327     if (!b->buf)
4328         PerlIO_get_base(f);
4329     b->ptr = ptr;
4330     assert(PerlIO_get_cnt(f) == cnt);
4331     assert(b->ptr >= b->buf);
4332     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4333 }
4334
4335 PerlIO *
4336 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4337 {
4338  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4339 }
4340
4341
4342
4343 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4344     sizeof(PerlIO_funcs),
4345     "perlio",
4346     sizeof(PerlIOBuf),
4347     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4348     PerlIOBuf_pushed,
4349     PerlIOBuf_popped,
4350     PerlIOBuf_open,
4351     PerlIOBase_binmode,         /* binmode */
4352     NULL,
4353     PerlIOBase_fileno,
4354     PerlIOBuf_dup,
4355     PerlIOBuf_read,
4356     PerlIOBuf_unread,
4357     PerlIOBuf_write,
4358     PerlIOBuf_seek,
4359     PerlIOBuf_tell,
4360     PerlIOBuf_close,
4361     PerlIOBuf_flush,
4362     PerlIOBuf_fill,
4363     PerlIOBase_eof,
4364     PerlIOBase_error,
4365     PerlIOBase_clearerr,
4366     PerlIOBase_setlinebuf,
4367     PerlIOBuf_get_base,
4368     PerlIOBuf_bufsiz,
4369     PerlIOBuf_get_ptr,
4370     PerlIOBuf_get_cnt,
4371     PerlIOBuf_set_ptrcnt,
4372 };
4373
4374 /*--------------------------------------------------------------------------------------*/
4375 /*
4376  * Temp layer to hold unread chars when cannot do it any other way
4377  */
4378
4379 IV
4380 PerlIOPending_fill(pTHX_ PerlIO *f)
4381 {
4382     /*
4383      * Should never happen
4384      */
4385     PerlIO_flush(f);
4386     return 0;
4387 }
4388
4389 IV
4390 PerlIOPending_close(pTHX_ PerlIO *f)
4391 {
4392     /*
4393      * A tad tricky - flush pops us, then we close new top
4394      */
4395     PerlIO_flush(f);
4396     return PerlIO_close(f);
4397 }
4398
4399 IV
4400 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4401 {
4402     /*
4403      * A tad tricky - flush pops us, then we seek new top
4404      */
4405     PerlIO_flush(f);
4406     return PerlIO_seek(f, offset, whence);
4407 }
4408
4409
4410 IV
4411 PerlIOPending_flush(pTHX_ PerlIO *f)
4412 {
4413     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4414     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4415         Safefree(b->buf);
4416         b->buf = NULL;
4417     }
4418     PerlIO_pop(aTHX_ f);
4419     return 0;
4420 }
4421
4422 void
4423 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4424 {
4425     if (cnt <= 0) {
4426         PerlIO_flush(f);
4427     }
4428     else {
4429         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4430     }
4431 }
4432
4433 IV
4434 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4435 {
4436     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4437     PerlIOl * const l = PerlIOBase(f);
4438     /*
4439      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4440      * etc. get muddled when it changes mid-string when we auto-pop.
4441      */
4442     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4443         (PerlIOBase(PerlIONext(f))->
4444          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4445     return code;
4446 }
4447
4448 SSize_t
4449 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4450 {
4451     SSize_t avail = PerlIO_get_cnt(f);
4452     SSize_t got = 0;
4453     if ((SSize_t)count < avail)
4454         avail = count;
4455     if (avail > 0)
4456         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4457     if (got >= 0 && got < (SSize_t)count) {
4458         const SSize_t more =
4459             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4460         if (more >= 0 || got == 0)
4461             got += more;
4462     }
4463     return got;
4464 }
4465
4466 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4467     sizeof(PerlIO_funcs),
4468     "pending",
4469     sizeof(PerlIOBuf),
4470     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4471     PerlIOPending_pushed,
4472     PerlIOBuf_popped,
4473     NULL,
4474     PerlIOBase_binmode,         /* binmode */
4475     NULL,
4476     PerlIOBase_fileno,
4477     PerlIOBuf_dup,
4478     PerlIOPending_read,
4479     PerlIOBuf_unread,
4480     PerlIOBuf_write,
4481     PerlIOPending_seek,
4482     PerlIOBuf_tell,
4483     PerlIOPending_close,
4484     PerlIOPending_flush,
4485     PerlIOPending_fill,
4486     PerlIOBase_eof,
4487     PerlIOBase_error,
4488     PerlIOBase_clearerr,
4489     PerlIOBase_setlinebuf,
4490     PerlIOBuf_get_base,
4491     PerlIOBuf_bufsiz,
4492     PerlIOBuf_get_ptr,
4493     PerlIOBuf_get_cnt,
4494     PerlIOPending_set_ptrcnt,
4495 };
4496
4497
4498
4499 /*--------------------------------------------------------------------------------------*/
4500 /*
4501  * crlf - translation On read translate CR,LF to "\n" we do this by
4502  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4503  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4504  *
4505  * c->nl points on the first byte of CR LF pair when it is temporarily
4506  * replaced by LF, or to the last CR of the buffer.  In the former case
4507  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4508  * that it ends at c->nl; these two cases can be distinguished by
4509  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4510  * _unread() and _flush() calls.
4511  * It only matters for read operations.
4512  */
4513
4514 typedef struct {
4515     PerlIOBuf base;             /* PerlIOBuf stuff */
4516     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4517                                  * buffer */
4518 } PerlIOCrlf;
4519
4520 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4521  * Otherwise the :crlf layer would always revert back to
4522  * raw mode.
4523  */
4524 static void
4525 S_inherit_utf8_flag(PerlIO *f)
4526 {
4527     PerlIO *g = PerlIONext(f);
4528     if (PerlIOValid(g)) {
4529         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4530             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4531         }
4532     }
4533 }
4534
4535 IV
4536 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4537 {
4538     IV code;
4539     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4540     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4541 #if 0
4542     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4543                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4544                  PerlIOBase(f)->flags);
4545 #endif
4546     {
4547       /* If the old top layer is a CRLF layer, reactivate it (if
4548        * necessary) and remove this new layer from the stack */
4549          PerlIO *g = PerlIONext(f);
4550          if (PerlIOValid(g)) {
4551               PerlIOl *b = PerlIOBase(g);
4552               if (b && b->tab == &PerlIO_crlf) {
4553                    if (!(b->flags & PERLIO_F_CRLF))
4554                         b->flags |= PERLIO_F_CRLF;
4555                    S_inherit_utf8_flag(g);
4556                    PerlIO_pop(aTHX_ f);
4557                    return code;
4558               }
4559          }
4560     }
4561     S_inherit_utf8_flag(f);
4562     return code;
4563 }
4564
4565
4566 SSize_t
4567 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4568 {
4569     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4570     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4571         *(c->nl) = 0xd;
4572         c->nl = NULL;
4573     }
4574     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4575         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4576     else {
4577         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4578         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4579         SSize_t unread = 0;
4580         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4581             PerlIO_flush(f);
4582         if (!b->buf)
4583             PerlIO_get_base(f);
4584         if (b->buf) {
4585             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4586                 b->end = b->ptr = b->buf + b->bufsiz;
4587                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4588                 b->posn -= b->bufsiz;
4589             }
4590             while (count > 0 && b->ptr > b->buf) {
4591                 const int ch = *--buf;
4592                 if (ch == '\n') {
4593                     if (b->ptr - 2 >= b->buf) {
4594                         *--(b->ptr) = 0xa;
4595                         *--(b->ptr) = 0xd;
4596                         unread++;
4597                         count--;
4598                     }
4599                     else {
4600                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4601                         *--(b->ptr) = 0xa;      /* Works even if 0xa == '\r' */
4602                         unread++;
4603                         count--;
4604                     }
4605                 }
4606                 else {
4607                     *--(b->ptr) = ch;
4608                     unread++;
4609                     count--;
4610                 }
4611             }
4612         }
4613         return unread;
4614     }
4615 }
4616
4617 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4618 SSize_t
4619 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4620 {
4621     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4622     if (!b->buf)
4623         PerlIO_get_base(f);
4624     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4625         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4626         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4627             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4628           scan:
4629             while (nl < b->end && *nl != 0xd)
4630                 nl++;
4631             if (nl < b->end && *nl == 0xd) {
4632               test:
4633                 if (nl + 1 < b->end) {
4634                     if (nl[1] == 0xa) {
4635                         *nl = '\n';
4636                         c->nl = nl;
4637                     }
4638                     else {
4639                         /*
4640                          * Not CR,LF but just CR
4641                          */
4642                         nl++;
4643                         goto scan;
4644                     }
4645                 }
4646                 else {
4647                     /*
4648                      * Blast - found CR as last char in buffer
4649                      */
4650
4651                     if (b->ptr < nl) {
4652                         /*
4653                          * They may not care, defer work as long as
4654                          * possible
4655                          */
4656                         c->nl = nl;
4657                         return (nl - b->ptr);
4658                     }
4659                     else {
4660                         int code;
4661                         b->ptr++;       /* say we have read it as far as
4662                                          * flush() is concerned */
4663                         b->buf++;       /* Leave space in front of buffer */
4664                         /* Note as we have moved buf up flush's
4665                            posn += ptr-buf
4666                            will naturally make posn point at CR
4667                          */
4668                         b->bufsiz--;    /* Buffer is thus smaller */
4669                         code = PerlIO_fill(f);  /* Fetch some more */
4670                         b->bufsiz++;    /* Restore size for next time */
4671                         b->buf--;       /* Point at space */
4672                         b->ptr = nl = b->buf;   /* Which is what we hand
4673                                                  * off */
4674                         *nl = 0xd;      /* Fill in the CR */
4675                         if (code == 0)
4676                             goto test;  /* fill() call worked */
4677                         /*
4678                          * CR at EOF - just fall through
4679                          */
4680                         /* Should we clear EOF though ??? */
4681                     }
4682                 }
4683             }
4684         }
4685         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4686     }
4687     return 0;
4688 }
4689
4690 void
4691 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4692 {
4693     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4694     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4695     if (!b->buf)
4696         PerlIO_get_base(f);
4697     if (!ptr) {
4698         if (c->nl) {
4699             ptr = c->nl + 1;
4700             if (ptr == b->end && *c->nl == 0xd) {
4701                 /* Deferred CR at end of buffer case - we lied about count */
4702                 ptr--;
4703             }
4704         }
4705         else {
4706             ptr = b->end;
4707         }
4708         ptr -= cnt;
4709     }
4710     else {
4711         NOOP;
4712 #if 0
4713         /*
4714          * Test code - delete when it works ...
4715          */
4716         IV flags = PerlIOBase(f)->flags;
4717         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4718         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4719           /* Deferred CR at end of buffer case - we lied about count */
4720           chk--;
4721         }
4722         chk -= cnt;
4723
4724         if (ptr != chk ) {
4725             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4726                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4727                        flags, c->nl, b->end, cnt);
4728         }
4729 #endif
4730     }
4731     if (c->nl) {
4732         if (ptr > c->nl) {
4733             /*
4734              * They have taken what we lied about
4735              */
4736             *(c->nl) = 0xd;
4737             c->nl = NULL;
4738             ptr++;
4739         }
4740     }
4741     b->ptr = ptr;
4742     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4743 }
4744
4745 SSize_t
4746 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4747 {
4748     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4749         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4750     else {
4751         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4752         const STDCHAR *buf = (const STDCHAR *) vbuf;
4753         const STDCHAR * const ebuf = buf + count;
4754         if (!b->buf)
4755             PerlIO_get_base(f);
4756         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4757             return 0;
4758         while (buf < ebuf) {
4759             const STDCHAR * const eptr = b->buf + b->bufsiz;
4760             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4761             while (buf < ebuf && b->ptr < eptr) {
4762                 if (*buf == '\n') {
4763                     if ((b->ptr + 2) > eptr) {
4764                         /*
4765                          * Not room for both
4766                          */
4767                         PerlIO_flush(f);
4768                         break;
4769                     }
4770                     else {
4771                         *(b->ptr)++ = 0xd;      /* CR */
4772                         *(b->ptr)++ = 0xa;      /* LF */
4773                         buf++;
4774                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4775                             PerlIO_flush(f);
4776                             break;
4777                         }
4778                     }
4779                 }
4780                 else {
4781                     *(b->ptr)++ = *buf++;
4782                 }
4783                 if (b->ptr >= eptr) {
4784                     PerlIO_flush(f);
4785                     break;
4786                 }
4787             }
4788         }
4789         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4790             PerlIO_flush(f);
4791         return (buf - (STDCHAR *) vbuf);
4792     }
4793 }
4794
4795 IV
4796 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4797 {
4798     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4799     if (c->nl) {
4800         *(c->nl) = 0xd;
4801         c->nl = NULL;
4802     }
4803     return PerlIOBuf_flush(aTHX_ f);
4804 }
4805
4806 IV
4807 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4808 {
4809     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4810         /* In text mode - flush any pending stuff and flip it */
4811         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4812 #ifndef PERLIO_USING_CRLF
4813         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4814         PerlIO_pop(aTHX_ f);
4815 #endif
4816     }
4817     return 0;
4818 }
4819
4820 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4821     sizeof(PerlIO_funcs),
4822     "crlf",
4823     sizeof(PerlIOCrlf),
4824     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4825     PerlIOCrlf_pushed,
4826     PerlIOBuf_popped,         /* popped */
4827     PerlIOBuf_open,
4828     PerlIOCrlf_binmode,       /* binmode */
4829     NULL,
4830     PerlIOBase_fileno,
4831     PerlIOBuf_dup,
4832     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4833     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4834     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4835     PerlIOBuf_seek,
4836     PerlIOBuf_tell,
4837     PerlIOBuf_close,
4838     PerlIOCrlf_flush,
4839     PerlIOBuf_fill,
4840     PerlIOBase_eof,
4841     PerlIOBase_error,
4842     PerlIOBase_clearerr,
4843     PerlIOBase_setlinebuf,
4844     PerlIOBuf_get_base,
4845     PerlIOBuf_bufsiz,
4846     PerlIOBuf_get_ptr,
4847     PerlIOCrlf_get_cnt,
4848     PerlIOCrlf_set_ptrcnt,
4849 };
4850
4851 #ifdef HAS_MMAP
4852 /*--------------------------------------------------------------------------------------*/
4853 /*
4854  * mmap as "buffer" layer
4855  */
4856
4857 typedef struct {
4858     PerlIOBuf base;             /* PerlIOBuf stuff */
4859     Mmap_t mptr;                /* Mapped address */
4860     Size_t len;                 /* mapped length */
4861     STDCHAR *bbuf;              /* malloced buffer if map fails */
4862 } PerlIOMmap;
4863
4864 IV
4865 PerlIOMmap_map(pTHX_ PerlIO *f)
4866 {
4867     dVAR;
4868     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4869     const IV flags = PerlIOBase(f)->flags;
4870     IV code = 0;
4871     if (m->len)
4872         abort();
4873     if (flags & PERLIO_F_CANREAD) {
4874         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4875         const int fd = PerlIO_fileno(f);
4876         Stat_t st;
4877         code = Fstat(fd, &st);
4878         if (code == 0 && S_ISREG(st.st_mode)) {
4879             SSize_t len = st.st_size - b->posn;
4880             if (len > 0) {
4881                 Off_t posn;
4882                 if (PL_mmap_page_size <= 0)
4883                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4884                              PL_mmap_page_size);
4885                 if (b->posn < 0) {
4886                     /*
4887                      * This is a hack - should never happen - open should
4888                      * have set it !
4889                      */
4890                     b->posn = PerlIO_tell(PerlIONext(f));
4891                 }
4892                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4893                 len = st.st_size - posn;
4894                 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4895                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4896 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4897                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4898 #endif
4899 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4900                     madvise(m->mptr, len, MADV_WILLNEED);
4901 #endif
4902                     PerlIOBase(f)->flags =
4903                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4904                     b->end = ((STDCHAR *) m->mptr) + len;
4905                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4906                     b->ptr = b->buf;
4907                     m->len = len;
4908                 }
4909                 else {
4910                     b->buf = NULL;
4911                 }
4912             }
4913             else {
4914                 PerlIOBase(f)->flags =
4915                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4916                 b->buf = NULL;
4917                 b->ptr = b->end = b->ptr;
4918                 code = -1;
4919             }
4920         }
4921     }
4922     return code;
4923 }
4924
4925 IV
4926 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4927 {
4928     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4929     IV code = 0;
4930     if (m->len) {
4931         PerlIOBuf * const b = &m->base;
4932         if (b->buf) {
4933             /* The munmap address argument is tricky: depending on the
4934              * standard it is either "void *" or "caddr_t" (which is
4935              * usually "char *" (signed or unsigned).  If we cast it
4936              * to "void *", those that have it caddr_t and an uptight
4937              * C++ compiler, will freak out.  But casting it as char*
4938              * should work.  Maybe.  (Using Mmap_t figured out by
4939              * Configure doesn't always work, apparently.) */
4940             code = munmap((char*)m->mptr, m->len);
4941             b->buf = NULL;
4942             m->len = 0;
4943             m->mptr = NULL;
4944             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4945                 code = -1;
4946         }
4947         b->ptr = b->end = b->buf;
4948         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4949     }
4950     return code;
4951 }
4952
4953 STDCHAR *
4954 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4955 {
4956     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4957     PerlIOBuf * const b = &m->base;
4958     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4959         /*
4960          * Already have a readbuffer in progress
4961          */
4962         return b->buf;
4963     }
4964     if (b->buf) {
4965         /*
4966          * We have a write buffer or flushed PerlIOBuf read buffer
4967          */
4968         m->bbuf = b->buf;       /* save it in case we need it again */
4969         b->buf = NULL;          /* Clear to trigger below */
4970     }
4971     if (!b->buf) {
4972         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
4973         if (!b->buf) {
4974             /*
4975              * Map did not work - recover PerlIOBuf buffer if we have one
4976              */
4977             b->buf = m->bbuf;
4978         }
4979     }
4980     b->ptr = b->end = b->buf;
4981     if (b->buf)
4982         return b->buf;
4983     return PerlIOBuf_get_base(aTHX_ f);
4984 }
4985
4986 SSize_t
4987 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4988 {
4989     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4990     PerlIOBuf * const b = &m->base;
4991     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4992         PerlIO_flush(f);
4993     if (b->ptr && (b->ptr - count) >= b->buf
4994         && memEQ(b->ptr - count, vbuf, count)) {
4995         b->ptr -= count;
4996         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4997         return count;
4998     }
4999     if (m->len) {
5000         /*
5001          * Loose the unwritable mapped buffer
5002          */
5003         PerlIO_flush(f);
5004         /*
5005          * If flush took the "buffer" see if we have one from before
5006          */
5007         if (!b->buf && m->bbuf)
5008             b->buf = m->bbuf;
5009         if (!b->buf) {
5010             PerlIOBuf_get_base(aTHX_ f);
5011             m->bbuf = b->buf;
5012         }
5013     }
5014     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
5015 }
5016
5017 SSize_t
5018 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
5019 {
5020     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5021     PerlIOBuf * const b = &m->base;
5022
5023     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
5024         /*
5025          * No, or wrong sort of, buffer
5026          */
5027         if (m->len) {
5028             if (PerlIOMmap_unmap(aTHX_ f) != 0)
5029                 return 0;
5030         }
5031         /*
5032          * If unmap took the "buffer" see if we have one from before
5033          */
5034         if (!b->buf && m->bbuf)
5035             b->buf = m->bbuf;
5036         if (!b->buf) {
5037             PerlIOBuf_get_base(aTHX_ f);
5038             m->bbuf = b->buf;
5039         }
5040     }
5041     return PerlIOBuf_write(aTHX_ f, vbuf, count);
5042 }
5043
5044 IV
5045 PerlIOMmap_flush(pTHX_ PerlIO *f)
5046 {
5047     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5048     PerlIOBuf * const b = &m->base;
5049     IV code = PerlIOBuf_flush(aTHX_ f);
5050     /*
5051      * Now we are "synced" at PerlIOBuf level
5052      */
5053     if (b->buf) {
5054         if (m->len) {
5055             /*
5056              * Unmap the buffer
5057              */
5058             if (PerlIOMmap_unmap(aTHX_ f) != 0)
5059                 code = -1;
5060         }
5061         else {
5062             /*
5063              * We seem to have a PerlIOBuf buffer which was not mapped
5064              * remember it in case we need one later
5065              */
5066             m->bbuf = b->buf;
5067         }
5068     }
5069     return code;
5070 }
5071
5072 IV
5073 PerlIOMmap_fill(pTHX_ PerlIO *f)
5074 {
5075     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
5076     IV code = PerlIO_flush(f);
5077     if (code == 0 && !b->buf) {
5078         code = PerlIOMmap_map(aTHX_ f);
5079     }
5080     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
5081         code = PerlIOBuf_fill(aTHX_ f);
5082     }
5083     return code;
5084 }
5085
5086 IV
5087 PerlIOMmap_close(pTHX_ PerlIO *f)
5088 {
5089     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5090     PerlIOBuf * const b = &m->base;
5091     IV code = PerlIO_flush(f);
5092     if (m->bbuf) {
5093         b->buf = m->bbuf;
5094         m->bbuf = NULL;
5095         b->ptr = b->end = b->buf;
5096     }
5097     if (PerlIOBuf_close(aTHX_ f) != 0)
5098         code = -1;
5099     return code;
5100 }
5101
5102 PerlIO *
5103 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
5104 {
5105  return PerlIOBase_dup(aTHX_ f, o, param, flags);
5106 }
5107
5108
5109 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
5110     sizeof(PerlIO_funcs),
5111     "mmap",
5112     sizeof(PerlIOMmap),
5113     PERLIO_K_BUFFERED|PERLIO_K_RAW,
5114     PerlIOBuf_pushed,
5115     PerlIOBuf_popped,
5116     PerlIOBuf_open,
5117     PerlIOBase_binmode,         /* binmode */
5118     NULL,
5119     PerlIOBase_fileno,
5120     PerlIOMmap_dup,
5121     PerlIOBuf_read,
5122     PerlIOMmap_unread,
5123     PerlIOMmap_write,
5124     PerlIOBuf_seek,
5125     PerlIOBuf_tell,
5126     PerlIOBuf_close,
5127     PerlIOMmap_flush,
5128     PerlIOMmap_fill,
5129     PerlIOBase_eof,
5130     PerlIOBase_error,
5131     PerlIOBase_clearerr,
5132     PerlIOBase_setlinebuf,
5133     PerlIOMmap_get_base,
5134     PerlIOBuf_bufsiz,
5135     PerlIOBuf_get_ptr,
5136     PerlIOBuf_get_cnt,
5137     PerlIOBuf_set_ptrcnt,
5138 };
5139
5140 #endif                          /* HAS_MMAP */
5141
5142 PerlIO *
5143 Perl_PerlIO_stdin(pTHX)
5144 {
5145     dVAR;
5146     if (!PL_perlio) {
5147         PerlIO_stdstreams(aTHX);
5148     }
5149     return (PerlIO*)&PL_perlio[1];
5150 }
5151
5152 PerlIO *
5153 Perl_PerlIO_stdout(pTHX)
5154 {
5155     dVAR;
5156     if (!PL_perlio) {
5157         PerlIO_stdstreams(aTHX);
5158     }
5159     return (PerlIO*)&PL_perlio[2];
5160 }
5161
5162 PerlIO *
5163 Perl_PerlIO_stderr(pTHX)
5164 {
5165     dVAR;
5166     if (!PL_perlio) {
5167         PerlIO_stdstreams(aTHX);
5168     }
5169     return (PerlIO*)&PL_perlio[3];
5170 }
5171
5172 /*--------------------------------------------------------------------------------------*/
5173
5174 char *
5175 PerlIO_getname(PerlIO *f, char *buf)
5176 {
5177     dTHX;
5178 #ifdef VMS
5179     char *name = NULL;
5180     bool exported = FALSE;
5181     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5182     if (!stdio) {
5183         stdio = PerlIO_exportFILE(f,0);
5184         exported = TRUE;
5185     }
5186     if (stdio) {
5187         name = fgetname(stdio, buf);
5188         if (exported) PerlIO_releaseFILE(f,stdio);
5189     }
5190     return name;
5191 #else
5192     PERL_UNUSED_ARG(f);
5193     PERL_UNUSED_ARG(buf);
5194     Perl_croak(aTHX_ "Don't know how to get file name");
5195     return NULL;
5196 #endif
5197 }
5198
5199
5200 /*--------------------------------------------------------------------------------------*/
5201 /*
5202  * Functions which can be called on any kind of PerlIO implemented in
5203  * terms of above
5204  */
5205
5206 #undef PerlIO_fdopen
5207 PerlIO *
5208 PerlIO_fdopen(int fd, const char *mode)
5209 {
5210     dTHX;
5211     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5212 }
5213
5214 #undef PerlIO_open
5215 PerlIO *
5216 PerlIO_open(const char *path, const char *mode)
5217 {
5218     dTHX;
5219     SV *name = sv_2mortal(newSVpv(path, 0));
5220     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5221 }
5222
5223 #undef Perlio_reopen
5224 PerlIO *
5225 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5226 {
5227     dTHX;
5228     SV *name = sv_2mortal(newSVpv(path,0));
5229     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5230 }
5231
5232 #undef PerlIO_getc
5233 int
5234 PerlIO_getc(PerlIO *f)
5235 {
5236     dTHX;
5237     STDCHAR buf[1];
5238     if ( 1 == PerlIO_read(f, buf, 1) ) {
5239         return (unsigned char) buf[0];
5240     }
5241     return EOF;
5242 }
5243
5244 #undef PerlIO_ungetc
5245 int
5246 PerlIO_ungetc(PerlIO *f, int ch)
5247 {
5248     dTHX;
5249     if (ch != EOF) {
5250         STDCHAR buf = ch;
5251         if (PerlIO_unread(f, &buf, 1) == 1)
5252             return ch;
5253     }
5254     return EOF;
5255 }
5256
5257 #undef PerlIO_putc
5258 int
5259 PerlIO_putc(PerlIO *f, int ch)
5260 {
5261     dTHX;
5262     STDCHAR buf = ch;
5263     return PerlIO_write(f, &buf, 1);
5264 }
5265
5266 #undef PerlIO_puts
5267 int
5268 PerlIO_puts(PerlIO *f, const char *s)
5269 {
5270     dTHX;
5271     return PerlIO_write(f, s, strlen(s));
5272 }
5273
5274 #undef PerlIO_rewind
5275 void
5276 PerlIO_rewind(PerlIO *f)
5277 {
5278     dTHX;
5279     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5280     PerlIO_clearerr(f);
5281 }
5282
5283 #undef PerlIO_vprintf
5284 int
5285 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5286 {
5287     dTHX;
5288     SV * sv;
5289     const char *s;
5290     STRLEN len;
5291     SSize_t wrote;
5292 #ifdef NEED_VA_COPY
5293     va_list apc;
5294     Perl_va_copy(ap, apc);
5295     sv = vnewSVpvf(fmt, &apc);
5296 #else
5297     sv = vnewSVpvf(fmt, &ap);
5298 #endif
5299     s = SvPV_const(sv, len);
5300     wrote = PerlIO_write(f, s, len);
5301     SvREFCNT_dec(sv);
5302     return wrote;
5303 }
5304
5305 #undef PerlIO_printf
5306 int
5307 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5308 {
5309     va_list ap;
5310     int result;
5311     va_start(ap, fmt);
5312     result = PerlIO_vprintf(f, fmt, ap);
5313     va_end(ap);
5314     return result;
5315 }
5316
5317 #undef PerlIO_stdoutf
5318 int
5319 PerlIO_stdoutf(const char *fmt, ...)
5320 {
5321     dTHX;
5322     va_list ap;
5323     int result;
5324     va_start(ap, fmt);
5325     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5326     va_end(ap);
5327     return result;
5328 }
5329
5330 #undef PerlIO_tmpfile
5331 PerlIO *
5332 PerlIO_tmpfile(void)
5333 {
5334      dTHX;
5335      PerlIO *f = NULL;
5336 #ifdef WIN32
5337      const int fd = win32_tmpfd();
5338      if (fd >= 0)
5339           f = PerlIO_fdopen(fd, "w+b");
5340 #else /* WIN32 */
5341 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5342      int fd = -1;
5343      char tempname[] = "/tmp/PerlIO_XXXXXX";
5344      const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5345      SV * sv = NULL;
5346      /*
5347       * I have no idea how portable mkstemp() is ... NI-S
5348       */
5349      if (tmpdir && *tmpdir) {
5350          /* if TMPDIR is set and not empty, we try that first */
5351          sv = newSVpv(tmpdir, 0);
5352          sv_catpv(sv, tempname + 4);
5353          fd = mkstemp(SvPVX(sv));
5354      }
5355      if (fd < 0) {
5356          sv = NULL;
5357          /* else we try /tmp */
5358          fd = mkstemp(tempname);
5359      }
5360      if (fd >= 0) {
5361           f = PerlIO_fdopen(fd, "w+");
5362           if (f)
5363                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5364           PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5365      }
5366      SvREFCNT_dec(sv);
5367 #    else       /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5368      FILE * const stdio = PerlSIO_tmpfile();
5369
5370      if (stdio)
5371           f = PerlIO_fdopen(fileno(stdio), "w+");
5372
5373 #    endif /* else HAS_MKSTEMP */
5374 #endif /* else WIN32 */
5375      return f;
5376 }
5377
5378 #undef HAS_FSETPOS
5379 #undef HAS_FGETPOS
5380
5381 #endif                          /* USE_SFIO */
5382 #endif                          /* PERLIO_IS_STDIO */
5383
5384 /*======================================================================================*/
5385 /*
5386  * Now some functions in terms of above which may be needed even if we are
5387  * not in true PerlIO mode
5388  */
5389 const char *
5390 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5391 {
5392     dVAR;
5393     const char *direction = NULL;
5394     SV *layers;
5395     /*
5396      * Need to supply default layer info from open.pm
5397      */
5398
5399     if (!PL_curcop)
5400         return NULL;
5401
5402     if (mode && mode[0] != 'r') {
5403         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5404             direction = "open>";
5405     } else {
5406         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5407             direction = "open<";
5408     }
5409     if (!direction)
5410         return NULL;
5411
5412     layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5413
5414     assert(layers);
5415     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5416 }
5417
5418
5419 #ifndef HAS_FSETPOS
5420 #undef PerlIO_setpos
5421 int
5422 PerlIO_setpos(PerlIO *f, SV *pos)
5423 {
5424     dTHX;
5425     if (SvOK(pos)) {
5426         STRLEN len;
5427         const Off_t * const posn = (Off_t *) SvPV(pos, len);
5428         if (f && len == sizeof(Off_t))
5429             return PerlIO_seek(f, *posn, SEEK_SET);
5430     }
5431     SETERRNO(EINVAL, SS_IVCHAN);
5432     return -1;
5433 }
5434 #else
5435 #undef PerlIO_setpos
5436 int
5437 PerlIO_setpos(PerlIO *f, SV *pos)
5438 {
5439     dTHX;
5440     if (SvOK(pos)) {
5441         STRLEN len;
5442         Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5443         if (f && len == sizeof(Fpos_t)) {
5444 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5445             return fsetpos64(f, fpos);
5446 #else
5447             return fsetpos(f, fpos);
5448 #endif
5449         }
5450     }
5451     SETERRNO(EINVAL, SS_IVCHAN);
5452     return -1;
5453 }
5454 #endif
5455
5456 #ifndef HAS_FGETPOS
5457 #undef PerlIO_getpos
5458 int
5459 PerlIO_getpos(PerlIO *f, SV *pos)
5460 {
5461     dTHX;
5462     Off_t posn = PerlIO_tell(f);
5463     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5464     return (posn == (Off_t) - 1) ? -1 : 0;
5465 }
5466 #else
5467 #undef PerlIO_getpos
5468 int
5469 PerlIO_getpos(PerlIO *f, SV *pos)
5470 {
5471     dTHX;
5472     Fpos_t fpos;
5473     int code;
5474 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5475     code = fgetpos64(f, &fpos);
5476 #else
5477     code = fgetpos(f, &fpos);
5478 #endif
5479     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5480     return code;
5481 }
5482 #endif
5483
5484 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5485
5486 int
5487 vprintf(char *pat, char *args)
5488 {
5489     _doprnt(pat, args, stdout);
5490     return 0;                   /* wrong, but perl doesn't use the return
5491                                  * value */
5492 }
5493
5494 int
5495 vfprintf(FILE *fd, char *pat, char *args)
5496 {
5497     _doprnt(pat, args, fd);
5498     return 0;                   /* wrong, but perl doesn't use the return
5499                                  * value */
5500 }
5501
5502 #endif
5503
5504 #ifndef PerlIO_vsprintf
5505 int
5506 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5507 {
5508     dTHX;
5509     const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5510     PERL_UNUSED_CONTEXT;
5511
5512 #ifndef PERL_MY_VSNPRINTF_GUARDED
5513     if (val < 0 || (n > 0 ? val >= n : 0)) {
5514         Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5515     }
5516 #endif
5517     return val;
5518 }
5519 #endif
5520
5521 #ifndef PerlIO_sprintf
5522 int
5523 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5524 {
5525     va_list ap;
5526     int result;
5527     va_start(ap, fmt);
5528     result = PerlIO_vsprintf(s, n, fmt, ap);
5529     va_end(ap);
5530     return result;
5531 }
5532 #endif
5533
5534 /*
5535  * Local variables:
5536  * c-indentation-style: bsd
5537  * c-basic-offset: 4
5538  * indent-tabs-mode: t
5539  * End:
5540  *
5541  * ex: set ts=8 sts=4 sw=4 noet:
5542  */