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