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             Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1523         return f;
1524     }
1525
1526     /*
1527      * For other types allow if layer is known but don't try and load it
1528      */
1529     switch (SvTYPE(sv)) {
1530     case SVt_PVAV:
1531         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1532     case SVt_PVHV:
1533         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1534     case SVt_PVCV:
1535         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1536     case SVt_PVGV:
1537         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1538     default:
1539         return NULL;
1540     }
1541 }
1542
1543 PerlIO_list_t *
1544 PerlIO_resolve_layers(pTHX_ const char *layers,
1545                       const char *mode, int narg, SV **args)
1546 {
1547     dVAR;
1548     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1549     int incdef = 1;
1550     if (!PL_perlio)
1551         PerlIO_stdstreams(aTHX);
1552     if (narg) {
1553         SV * const arg = *args;
1554         /*
1555          * If it is a reference but not an object see if we have a handler
1556          * for it
1557          */
1558         if (SvROK(arg) && !sv_isobject(arg)) {
1559             PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1560             if (handler) {
1561                 def = PerlIO_list_alloc(aTHX);
1562                 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1563                 incdef = 0;
1564             }
1565             /*
1566              * Don't fail if handler cannot be found :via(...) etc. may do
1567              * something sensible else we will just stringfy and open
1568              * resulting string.
1569              */
1570         }
1571     }
1572     if (!layers || !*layers)
1573         layers = Perl_PerlIO_context_layers(aTHX_ mode);
1574     if (layers && *layers) {
1575         PerlIO_list_t *av;
1576         if (incdef) {
1577             av = PerlIO_clone_list(aTHX_ def, NULL);
1578         }
1579         else {
1580             av = def;
1581         }
1582         if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1583              return av;
1584         }
1585         else {
1586             PerlIO_list_free(aTHX_ av);
1587             return NULL;
1588         }
1589     }
1590     else {
1591         if (incdef)
1592             def->refcnt++;
1593         return def;
1594     }
1595 }
1596
1597 PerlIO *
1598 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1599              int imode, int perm, PerlIO *f, int narg, SV **args)
1600 {
1601     dVAR;
1602     if (!f && narg == 1 && *args == &PL_sv_undef) {
1603         if ((f = PerlIO_tmpfile())) {
1604             if (!layers || !*layers)
1605                 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1606             if (layers && *layers)
1607                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1608         }
1609     }
1610     else {
1611         PerlIO_list_t *layera;
1612         IV n;
1613         PerlIO_funcs *tab = NULL;
1614         if (PerlIOValid(f)) {
1615             /*
1616              * This is "reopen" - it is not tested as perl does not use it
1617              * yet
1618              */
1619             PerlIOl *l = *f;
1620             layera = PerlIO_list_alloc(aTHX);
1621             while (l) {
1622                 SV *arg = NULL;
1623                 if (l->tab && l->tab->Getarg)
1624                     arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1625                 PerlIO_list_push(aTHX_ layera, l->tab,
1626                                  (arg) ? arg : &PL_sv_undef);
1627                 SvREFCNT_dec(arg);
1628                 l = *PerlIONext(&l);
1629             }
1630         }
1631         else {
1632             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1633             if (!layera) {
1634                 return NULL;
1635             }
1636         }
1637         /*
1638          * Start at "top" of layer stack
1639          */
1640         n = layera->cur - 1;
1641         while (n >= 0) {
1642             PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1643             if (t && t->Open) {
1644                 tab = t;
1645                 break;
1646             }
1647             n--;
1648         }
1649         if (tab) {
1650             /*
1651              * Found that layer 'n' can do opens - call it
1652              */
1653             if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1654                 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1655             }
1656             PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1657                          tab->name, layers ? layers : "(Null)", mode, fd,
1658                          imode, perm, (void*)f, narg, (void*)args);
1659             if (tab->Open)
1660                  f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1661                                    f, narg, args);
1662             else {
1663                  SETERRNO(EINVAL, LIB_INVARG);
1664                  f = NULL;
1665             }
1666             if (f) {
1667                 if (n + 1 < layera->cur) {
1668                     /*
1669                      * More layers above the one that we used to open -
1670                      * apply them now
1671                      */
1672                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1673                         /* If pushing layers fails close the file */
1674                         PerlIO_close(f);
1675                         f = NULL;
1676                     }
1677                 }
1678             }
1679         }
1680         PerlIO_list_free(aTHX_ layera);
1681     }
1682     return f;
1683 }
1684
1685
1686 SSize_t
1687 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1688 {
1689      PERL_ARGS_ASSERT_PERLIO_READ;
1690
1691      Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1692 }
1693
1694 SSize_t
1695 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1696 {
1697      PERL_ARGS_ASSERT_PERLIO_UNREAD;
1698
1699      Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1700 }
1701
1702 SSize_t
1703 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1704 {
1705      PERL_ARGS_ASSERT_PERLIO_WRITE;
1706
1707      Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1708 }
1709
1710 int
1711 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1712 {
1713      Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1714 }
1715
1716 Off_t
1717 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1718 {
1719      Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1720 }
1721
1722 int
1723 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1724 {
1725     dVAR;
1726     if (f) {
1727         if (*f) {
1728             const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1729
1730             if (tab && tab->Flush)
1731                 return (*tab->Flush) (aTHX_ f);
1732             else
1733                  return 0; /* If no Flush defined, silently succeed. */
1734         }
1735         else {
1736             PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1737             SETERRNO(EBADF, SS_IVCHAN);
1738             return -1;
1739         }
1740     }
1741     else {
1742         /*
1743          * Is it good API design to do flush-all on NULL, a potentially
1744          * erroneous input? Maybe some magical value (PerlIO*
1745          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1746          * things on fflush(NULL), but should we be bound by their design
1747          * decisions? --jhi
1748          */
1749         PerlIOl **table = &PL_perlio;
1750         PerlIOl *ff;
1751         int code = 0;
1752         while ((ff = *table)) {
1753             int i;
1754             table = (PerlIOl **) (ff++);
1755             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1756                 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1757                     code = -1;
1758                 ff++;
1759             }
1760         }
1761         return code;
1762     }
1763 }
1764
1765 void
1766 PerlIOBase_flush_linebuf(pTHX)
1767 {
1768     dVAR;
1769     PerlIOl **table = &PL_perlio;
1770     PerlIOl *f;
1771     while ((f = *table)) {
1772         int i;
1773         table = (PerlIOl **) (f++);
1774         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1775             if (f->next
1776                 && (PerlIOBase(&(f->next))->
1777                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1778                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1779                 PerlIO_flush(&(f->next));
1780             f++;
1781         }
1782     }
1783 }
1784
1785 int
1786 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1787 {
1788      Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1789 }
1790
1791 int
1792 PerlIO_isutf8(PerlIO *f)
1793 {
1794      if (PerlIOValid(f))
1795           return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1796      else
1797           SETERRNO(EBADF, SS_IVCHAN);
1798
1799      return -1;
1800 }
1801
1802 int
1803 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1804 {
1805      Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1806 }
1807
1808 int
1809 Perl_PerlIO_error(pTHX_ PerlIO *f)
1810 {
1811      Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1812 }
1813
1814 void
1815 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1816 {
1817      Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1818 }
1819
1820 void
1821 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1822 {
1823      Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1824 }
1825
1826 int
1827 PerlIO_has_base(PerlIO *f)
1828 {
1829      if (PerlIOValid(f)) {
1830           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1831
1832           if (tab)
1833                return (tab->Get_base != NULL);
1834      }
1835
1836      return 0;
1837 }
1838
1839 int
1840 PerlIO_fast_gets(PerlIO *f)
1841 {
1842     if (PerlIOValid(f)) {
1843          if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1844              const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1845
1846              if (tab)
1847                   return (tab->Set_ptrcnt != NULL);
1848          }
1849     }
1850
1851     return 0;
1852 }
1853
1854 int
1855 PerlIO_has_cntptr(PerlIO *f)
1856 {
1857     if (PerlIOValid(f)) {
1858         const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1859
1860         if (tab)
1861              return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1862     }
1863
1864     return 0;
1865 }
1866
1867 int
1868 PerlIO_canset_cnt(PerlIO *f)
1869 {
1870     if (PerlIOValid(f)) {
1871           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1872
1873           if (tab)
1874                return (tab->Set_ptrcnt != NULL);
1875     }
1876
1877     return 0;
1878 }
1879
1880 STDCHAR *
1881 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1882 {
1883      Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1884 }
1885
1886 int
1887 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1888 {
1889      Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1890 }
1891
1892 STDCHAR *
1893 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1894 {
1895      Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1896 }
1897
1898 int
1899 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1900 {
1901      Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1902 }
1903
1904 void
1905 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1906 {
1907      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1908 }
1909
1910 void
1911 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1912 {
1913      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1914 }
1915
1916
1917 /*--------------------------------------------------------------------------------------*/
1918 /*
1919  * utf8 and raw dummy layers
1920  */
1921
1922 IV
1923 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1924 {
1925     PERL_UNUSED_CONTEXT;
1926     PERL_UNUSED_ARG(mode);
1927     PERL_UNUSED_ARG(arg);
1928     if (PerlIOValid(f)) {
1929         if (tab && tab->kind & PERLIO_K_UTF8)
1930             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1931         else
1932             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1933         return 0;
1934     }
1935     return -1;
1936 }
1937
1938 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1939     sizeof(PerlIO_funcs),
1940     "utf8",
1941     0,
1942     PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1943     PerlIOUtf8_pushed,
1944     NULL,
1945     PerlIOBase_open,
1946     NULL,
1947     NULL,
1948     NULL,
1949     NULL,
1950     NULL,
1951     NULL,
1952     NULL,
1953     NULL,
1954     NULL,
1955     NULL,
1956     NULL,                       /* flush */
1957     NULL,                       /* fill */
1958     NULL,
1959     NULL,
1960     NULL,
1961     NULL,
1962     NULL,                       /* get_base */
1963     NULL,                       /* get_bufsiz */
1964     NULL,                       /* get_ptr */
1965     NULL,                       /* get_cnt */
1966     NULL,                       /* set_ptrcnt */
1967 };
1968
1969 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1970     sizeof(PerlIO_funcs),
1971     "bytes",
1972     0,
1973     PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1974     PerlIOUtf8_pushed,
1975     NULL,
1976     PerlIOBase_open,
1977     NULL,
1978     NULL,
1979     NULL,
1980     NULL,
1981     NULL,
1982     NULL,
1983     NULL,
1984     NULL,
1985     NULL,
1986     NULL,
1987     NULL,                       /* flush */
1988     NULL,                       /* fill */
1989     NULL,
1990     NULL,
1991     NULL,
1992     NULL,
1993     NULL,                       /* get_base */
1994     NULL,                       /* get_bufsiz */
1995     NULL,                       /* get_ptr */
1996     NULL,                       /* get_cnt */
1997     NULL,                       /* set_ptrcnt */
1998 };
1999
2000 PERLIO_FUNCS_DECL(PerlIO_raw) = {
2001     sizeof(PerlIO_funcs),
2002     "raw",
2003     0,
2004     PERLIO_K_DUMMY,
2005     PerlIORaw_pushed,
2006     PerlIOBase_popped,
2007     PerlIOBase_open,
2008     NULL,
2009     NULL,
2010     NULL,
2011     NULL,
2012     NULL,
2013     NULL,
2014     NULL,
2015     NULL,
2016     NULL,
2017     NULL,
2018     NULL,                       /* flush */
2019     NULL,                       /* fill */
2020     NULL,
2021     NULL,
2022     NULL,
2023     NULL,
2024     NULL,                       /* get_base */
2025     NULL,                       /* get_bufsiz */
2026     NULL,                       /* get_ptr */
2027     NULL,                       /* get_cnt */
2028     NULL,                       /* set_ptrcnt */
2029 };
2030 /*--------------------------------------------------------------------------------------*/
2031 /*--------------------------------------------------------------------------------------*/
2032 /*
2033  * "Methods" of the "base class"
2034  */
2035
2036 IV
2037 PerlIOBase_fileno(pTHX_ PerlIO *f)
2038 {
2039     return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2040 }
2041
2042 char *
2043 PerlIO_modestr(PerlIO * f, char *buf)
2044 {
2045     char *s = buf;
2046     if (PerlIOValid(f)) {
2047         const IV flags = PerlIOBase(f)->flags;
2048         if (flags & PERLIO_F_APPEND) {
2049             *s++ = 'a';
2050             if (flags & PERLIO_F_CANREAD) {
2051                 *s++ = '+';
2052             }
2053         }
2054         else if (flags & PERLIO_F_CANREAD) {
2055             *s++ = 'r';
2056             if (flags & PERLIO_F_CANWRITE)
2057                 *s++ = '+';
2058         }
2059         else if (flags & PERLIO_F_CANWRITE) {
2060             *s++ = 'w';
2061             if (flags & PERLIO_F_CANREAD) {
2062                 *s++ = '+';
2063             }
2064         }
2065 #ifdef PERLIO_USING_CRLF
2066         if (!(flags & PERLIO_F_CRLF))
2067             *s++ = 'b';
2068 #endif
2069     }
2070     *s = '\0';
2071     return buf;
2072 }
2073
2074
2075 IV
2076 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2077 {
2078     PerlIOl * const l = PerlIOBase(f);
2079     PERL_UNUSED_CONTEXT;
2080     PERL_UNUSED_ARG(arg);
2081
2082     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2083                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2084     if (tab && tab->Set_ptrcnt != NULL)
2085         l->flags |= PERLIO_F_FASTGETS;
2086     if (mode) {
2087         if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2088             mode++;
2089         switch (*mode++) {
2090         case 'r':
2091             l->flags |= PERLIO_F_CANREAD;
2092             break;
2093         case 'a':
2094             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2095             break;
2096         case 'w':
2097             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2098             break;
2099         default:
2100             SETERRNO(EINVAL, LIB_INVARG);
2101             return -1;
2102         }
2103         while (*mode) {
2104             switch (*mode++) {
2105             case '+':
2106                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2107                 break;
2108             case 'b':
2109                 l->flags &= ~PERLIO_F_CRLF;
2110                 break;
2111             case 't':
2112                 l->flags |= PERLIO_F_CRLF;
2113                 break;
2114             default:
2115                 SETERRNO(EINVAL, LIB_INVARG);
2116                 return -1;
2117             }
2118         }
2119     }
2120     else {
2121         if (l->next) {
2122             l->flags |= l->next->flags &
2123                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2124                  PERLIO_F_APPEND);
2125         }
2126     }
2127 #if 0
2128     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2129                  (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2130                  l->flags, PerlIO_modestr(f, temp));
2131 #endif
2132     return 0;
2133 }
2134
2135 IV
2136 PerlIOBase_popped(pTHX_ PerlIO *f)
2137 {
2138     PERL_UNUSED_CONTEXT;
2139     PERL_UNUSED_ARG(f);
2140     return 0;
2141 }
2142
2143 SSize_t
2144 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2145 {
2146     /*
2147      * Save the position as current head considers it
2148      */
2149     const Off_t old = PerlIO_tell(f);
2150     PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2151     PerlIOSelf(f, PerlIOBuf)->posn = old;
2152     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2153 }
2154
2155 SSize_t
2156 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2157 {
2158     STDCHAR *buf = (STDCHAR *) vbuf;
2159     if (f) {
2160         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2161             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2162             SETERRNO(EBADF, SS_IVCHAN);
2163             return 0;
2164         }
2165         while (count > 0) {
2166          get_cnt:
2167           {
2168             SSize_t avail = PerlIO_get_cnt(f);
2169             SSize_t take = 0;
2170             if (avail > 0)
2171                 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2172             if (take > 0) {
2173                 STDCHAR *ptr = PerlIO_get_ptr(f);
2174                 Copy(ptr, buf, take, STDCHAR);
2175                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2176                 count -= take;
2177                 buf += take;
2178                 if (avail == 0)         /* set_ptrcnt could have reset avail */
2179                     goto get_cnt;
2180             }
2181             if (count > 0 && avail <= 0) {
2182                 if (PerlIO_fill(f) != 0)
2183                     break;
2184             }
2185           }
2186         }
2187         return (buf - (STDCHAR *) vbuf);
2188     }
2189     return 0;
2190 }
2191
2192 IV
2193 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2194 {
2195     PERL_UNUSED_CONTEXT;
2196     PERL_UNUSED_ARG(f);
2197     return 0;
2198 }
2199
2200 IV
2201 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2202 {
2203     PERL_UNUSED_CONTEXT;
2204     PERL_UNUSED_ARG(f);
2205     return -1;
2206 }
2207
2208 IV
2209 PerlIOBase_close(pTHX_ PerlIO *f)
2210 {
2211     IV code = -1;
2212     if (PerlIOValid(f)) {
2213         PerlIO *n = PerlIONext(f);
2214         code = PerlIO_flush(f);
2215         PerlIOBase(f)->flags &=
2216            ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2217         while (PerlIOValid(n)) {
2218             const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2219             if (tab && tab->Close) {
2220                 if ((*tab->Close)(aTHX_ n) != 0)
2221                     code = -1;
2222                 break;
2223             }
2224             else {
2225                 PerlIOBase(n)->flags &=
2226                     ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2227             }
2228             n = PerlIONext(n);
2229         }
2230     }
2231     else {
2232         SETERRNO(EBADF, SS_IVCHAN);
2233     }
2234     return code;
2235 }
2236
2237 IV
2238 PerlIOBase_eof(pTHX_ PerlIO *f)
2239 {
2240     PERL_UNUSED_CONTEXT;
2241     if (PerlIOValid(f)) {
2242         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2243     }
2244     return 1;
2245 }
2246
2247 IV
2248 PerlIOBase_error(pTHX_ PerlIO *f)
2249 {
2250     PERL_UNUSED_CONTEXT;
2251     if (PerlIOValid(f)) {
2252         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2253     }
2254     return 1;
2255 }
2256
2257 void
2258 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2259 {
2260     if (PerlIOValid(f)) {
2261         PerlIO * const n = PerlIONext(f);
2262         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2263         if (PerlIOValid(n))
2264             PerlIO_clearerr(n);
2265     }
2266 }
2267
2268 void
2269 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2270 {
2271     PERL_UNUSED_CONTEXT;
2272     if (PerlIOValid(f)) {
2273         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2274     }
2275 }
2276
2277 SV *
2278 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2279 {
2280     if (!arg)
2281         return NULL;
2282 #ifdef sv_dup
2283     if (param) {
2284         arg = sv_dup(arg, param);
2285         SvREFCNT_inc_simple_void_NN(arg);
2286         return arg;
2287     }
2288     else {
2289         return newSVsv(arg);
2290     }
2291 #else
2292     PERL_UNUSED_ARG(param);
2293     return newSVsv(arg);
2294 #endif
2295 }
2296
2297 PerlIO *
2298 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2299 {
2300     PerlIO * const nexto = PerlIONext(o);
2301     if (PerlIOValid(nexto)) {
2302         const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2303         if (tab && tab->Dup)
2304             f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2305         else
2306             f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2307     }
2308     if (f) {
2309         PerlIO_funcs * const self = PerlIOBase(o)->tab;
2310         SV *arg = NULL;
2311         char buf[8];
2312         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2313                      self ? self->name : "(Null)",
2314                      (void*)f, (void*)o, (void*)param);
2315         if (self && self->Getarg)
2316             arg = (*self->Getarg)(aTHX_ o, param, flags);
2317         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2318         if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2319             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2320         SvREFCNT_dec(arg);
2321     }
2322     return f;
2323 }
2324
2325 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2326
2327 /* Must be called with PL_perlio_mutex locked. */
2328 static void
2329 S_more_refcounted_fds(pTHX_ const int new_fd) {
2330     dVAR;
2331     const int old_max = PL_perlio_fd_refcnt_size;
2332     const int new_max = 16 + (new_fd & ~15);
2333     int *new_array;
2334
2335     PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2336                  old_max, new_fd, new_max);
2337
2338     if (new_fd < old_max) {
2339         return;
2340     }
2341
2342     assert (new_max > new_fd);
2343
2344     /* Use plain realloc() since we need this memory to be really
2345      * global and visible to all the interpreters and/or threads. */
2346     new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2347
2348     if (!new_array) {
2349 #ifdef USE_ITHREADS
2350         MUTEX_UNLOCK(&PL_perlio_mutex);
2351 #endif
2352         /* Can't use PerlIO to write as it allocates memory */
2353         PerlLIO_write(PerlIO_fileno(Perl_error_log),
2354                       PL_no_mem, strlen(PL_no_mem));
2355         my_exit(1);
2356     }
2357
2358     PL_perlio_fd_refcnt_size = new_max;
2359     PL_perlio_fd_refcnt = new_array;
2360
2361     PerlIO_debug("Zeroing %p, %d\n",
2362                  (void*)(new_array + old_max),
2363                  new_max - old_max);
2364
2365     Zero(new_array + old_max, new_max - old_max, int);
2366 }
2367
2368
2369 void
2370 PerlIO_init(pTHX)
2371 {
2372     /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2373     PERL_UNUSED_CONTEXT;
2374 }
2375
2376 void
2377 PerlIOUnix_refcnt_inc(int fd)
2378 {
2379     dTHX;
2380     if (fd >= 0) {
2381         dVAR;
2382
2383 #ifdef USE_ITHREADS
2384         MUTEX_LOCK(&PL_perlio_mutex);
2385 #endif
2386         if (fd >= PL_perlio_fd_refcnt_size)
2387             S_more_refcounted_fds(aTHX_ fd);
2388
2389         PL_perlio_fd_refcnt[fd]++;
2390         if (PL_perlio_fd_refcnt[fd] <= 0) {
2391             /* diag_listed_as: refcnt_inc: fd %d%s */
2392             Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2393                        fd, PL_perlio_fd_refcnt[fd]);
2394         }
2395         PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2396                      fd, PL_perlio_fd_refcnt[fd]);
2397
2398 #ifdef USE_ITHREADS
2399         MUTEX_UNLOCK(&PL_perlio_mutex);
2400 #endif
2401     } else {
2402         /* diag_listed_as: refcnt_inc: fd %d%s */
2403         Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2404     }
2405 }
2406
2407 int
2408 PerlIOUnix_refcnt_dec(int fd)
2409 {
2410     dTHX;
2411     int cnt = 0;
2412     if (fd >= 0) {
2413         dVAR;
2414 #ifdef USE_ITHREADS
2415         MUTEX_LOCK(&PL_perlio_mutex);
2416 #endif
2417         if (fd >= PL_perlio_fd_refcnt_size) {
2418             /* diag_listed_as: refcnt_dec: fd %d%s */
2419             Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2420                        fd, PL_perlio_fd_refcnt_size);
2421         }
2422         if (PL_perlio_fd_refcnt[fd] <= 0) {
2423             /* diag_listed_as: refcnt_dec: fd %d%s */
2424             Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2425                        fd, PL_perlio_fd_refcnt[fd]);
2426         }
2427         cnt = --PL_perlio_fd_refcnt[fd];
2428         PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2429 #ifdef USE_ITHREADS
2430         MUTEX_UNLOCK(&PL_perlio_mutex);
2431 #endif
2432     } else {
2433         /* diag_listed_as: refcnt_dec: fd %d%s */
2434         Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2435     }
2436     return cnt;
2437 }
2438
2439 int
2440 PerlIOUnix_refcnt(int fd)
2441 {
2442     dTHX;
2443     int cnt = 0;
2444     if (fd >= 0) {
2445         dVAR;
2446 #ifdef USE_ITHREADS
2447         MUTEX_LOCK(&PL_perlio_mutex);
2448 #endif
2449         if (fd >= PL_perlio_fd_refcnt_size) {
2450             /* diag_listed_as: refcnt: fd %d%s */
2451             Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2452                        fd, PL_perlio_fd_refcnt_size);
2453         }
2454         if (PL_perlio_fd_refcnt[fd] <= 0) {
2455             /* diag_listed_as: refcnt: fd %d%s */
2456             Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2457                        fd, PL_perlio_fd_refcnt[fd]);
2458         }
2459         cnt = PL_perlio_fd_refcnt[fd];
2460 #ifdef USE_ITHREADS
2461         MUTEX_UNLOCK(&PL_perlio_mutex);
2462 #endif
2463     } else {
2464         /* diag_listed_as: refcnt: fd %d%s */
2465         Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2466     }
2467     return cnt;
2468 }
2469
2470 void
2471 PerlIO_cleanup(pTHX)
2472 {
2473     dVAR;
2474     int i;
2475 #ifdef USE_ITHREADS
2476     PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2477 #else
2478     PerlIO_debug("Cleanup layers\n");
2479 #endif
2480
2481     /* Raise STDIN..STDERR refcount so we don't close them */
2482     for (i=0; i < 3; i++)
2483         PerlIOUnix_refcnt_inc(i);
2484     PerlIO_cleantable(aTHX_ &PL_perlio);
2485     /* Restore STDIN..STDERR refcount */
2486     for (i=0; i < 3; i++)
2487         PerlIOUnix_refcnt_dec(i);
2488
2489     if (PL_known_layers) {
2490         PerlIO_list_free(aTHX_ PL_known_layers);
2491         PL_known_layers = NULL;
2492     }
2493     if (PL_def_layerlist) {
2494         PerlIO_list_free(aTHX_ PL_def_layerlist);
2495         PL_def_layerlist = NULL;
2496     }
2497 }
2498
2499 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2500 {
2501     dVAR;
2502 #if 0
2503 /* XXX we can't rely on an interpreter being present at this late stage,
2504    XXX so we can't use a function like PerlLIO_write that relies on one
2505    being present (at least in win32) :-(.
2506    Disable for now.
2507 */
2508 #ifdef DEBUGGING
2509     {
2510         /* By now all filehandles should have been closed, so any
2511          * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2512          * errors. */
2513 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2514 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2515         char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2516         int i;
2517         for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2518             if (PL_perlio_fd_refcnt[i]) {
2519                 const STRLEN len =
2520                     my_snprintf(buf, sizeof(buf),
2521                                 "PerlIO_teardown: fd %d refcnt=%d\n",
2522                                 i, PL_perlio_fd_refcnt[i]);
2523                 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2524             }
2525         }
2526     }
2527 #endif
2528 #endif
2529     /* Not bothering with PL_perlio_mutex since by now
2530      * all the interpreters are gone. */
2531     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2532         && PL_perlio_fd_refcnt) {
2533         free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2534         PL_perlio_fd_refcnt = NULL;
2535         PL_perlio_fd_refcnt_size = 0;
2536     }
2537 }
2538
2539 /*--------------------------------------------------------------------------------------*/
2540 /*
2541  * Bottom-most level for UNIX-like case
2542  */
2543
2544 typedef struct {
2545     struct _PerlIO base;        /* The generic part */
2546     int fd;                     /* UNIX like file descriptor */
2547     int oflags;                 /* open/fcntl flags */
2548 } PerlIOUnix;
2549
2550 static void
2551 S_lockcnt_dec(pTHX_ const void* f)
2552 {
2553     PerlIO_lockcnt((PerlIO*)f)--;
2554 }
2555
2556
2557 /* call the signal handler, and if that handler happens to clear
2558  * this handle, free what we can and return true */
2559
2560 static bool
2561 S_perlio_async_run(pTHX_ PerlIO* f) {
2562     ENTER;
2563     SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2564     PerlIO_lockcnt(f)++;
2565     PERL_ASYNC_CHECK();
2566     if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2567         return 0;
2568     /* we've just run some perl-level code that could have done
2569      * anything, including closing the file or clearing this layer.
2570      * If so, free any lower layers that have already been
2571      * cleared, then return an error. */
2572     while (PerlIOValid(f) &&
2573             (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2574     {
2575         const PerlIOl *l = *f;
2576         *f = l->next;
2577         Safefree(l);
2578     }
2579     return 1;
2580 }
2581
2582 int
2583 PerlIOUnix_oflags(const char *mode)
2584 {
2585     int oflags = -1;
2586     if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2587         mode++;
2588     switch (*mode) {
2589     case 'r':
2590         oflags = O_RDONLY;
2591         if (*++mode == '+') {
2592             oflags = O_RDWR;
2593             mode++;
2594         }
2595         break;
2596
2597     case 'w':
2598         oflags = O_CREAT | O_TRUNC;
2599         if (*++mode == '+') {
2600             oflags |= O_RDWR;
2601             mode++;
2602         }
2603         else
2604             oflags |= O_WRONLY;
2605         break;
2606
2607     case 'a':
2608         oflags = O_CREAT | O_APPEND;
2609         if (*++mode == '+') {
2610             oflags |= O_RDWR;
2611             mode++;
2612         }
2613         else
2614             oflags |= O_WRONLY;
2615         break;
2616     }
2617     if (*mode == 'b') {
2618         oflags |= O_BINARY;
2619         oflags &= ~O_TEXT;
2620         mode++;
2621     }
2622     else if (*mode == 't') {
2623         oflags |= O_TEXT;
2624         oflags &= ~O_BINARY;
2625         mode++;
2626     }
2627     /*
2628      * Always open in binary mode
2629      */
2630     oflags |= O_BINARY;
2631     if (*mode || oflags == -1) {
2632         SETERRNO(EINVAL, LIB_INVARG);
2633         oflags = -1;
2634     }
2635     return oflags;
2636 }
2637
2638 IV
2639 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2640 {
2641     PERL_UNUSED_CONTEXT;
2642     return PerlIOSelf(f, PerlIOUnix)->fd;
2643 }
2644
2645 static void
2646 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2647 {
2648     PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2649 #if defined(WIN32)
2650     Stat_t st;
2651     if (PerlLIO_fstat(fd, &st) == 0) {
2652         if (!S_ISREG(st.st_mode)) {
2653             PerlIO_debug("%d is not regular file\n",fd);
2654             PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2655         }
2656         else {
2657             PerlIO_debug("%d _is_ a regular file\n",fd);
2658         }
2659     }
2660 #endif
2661     s->fd = fd;
2662     s->oflags = imode;
2663     PerlIOUnix_refcnt_inc(fd);
2664     PERL_UNUSED_CONTEXT;
2665 }
2666
2667 IV
2668 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2669 {
2670     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2671     if (*PerlIONext(f)) {
2672         /* We never call down so do any pending stuff now */
2673         PerlIO_flush(PerlIONext(f));
2674         /*
2675          * XXX could (or should) we retrieve the oflags from the open file
2676          * handle rather than believing the "mode" we are passed in? XXX
2677          * Should the value on NULL mode be 0 or -1?
2678          */
2679         PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2680                          mode ? PerlIOUnix_oflags(mode) : -1);
2681     }
2682     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2683
2684     return code;
2685 }
2686
2687 IV
2688 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2689 {
2690     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2691     Off_t new_loc;
2692     PERL_UNUSED_CONTEXT;
2693     if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2694 #ifdef  ESPIPE
2695         SETERRNO(ESPIPE, LIB_INVARG);
2696 #else
2697         SETERRNO(EINVAL, LIB_INVARG);
2698 #endif
2699         return -1;
2700     }
2701     new_loc = PerlLIO_lseek(fd, offset, whence);
2702     if (new_loc == (Off_t) - 1)
2703         return -1;
2704     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2705     return  0;
2706 }
2707
2708 PerlIO *
2709 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2710                 IV n, const char *mode, int fd, int imode,
2711                 int perm, PerlIO *f, int narg, SV **args)
2712 {
2713     if (PerlIOValid(f)) {
2714         if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2715             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2716     }
2717     if (narg > 0) {
2718         if (*mode == IoTYPE_NUMERIC)
2719             mode++;
2720         else {
2721             imode = PerlIOUnix_oflags(mode);
2722 #ifdef VMS
2723             perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2724 #else
2725             perm = 0666;
2726 #endif
2727         }
2728         if (imode != -1) {
2729             const char *path = SvPV_nolen_const(*args);
2730             fd = PerlLIO_open3(path, imode, perm);
2731         }
2732     }
2733     if (fd >= 0) {
2734         if (*mode == IoTYPE_IMPLICIT)
2735             mode++;
2736         if (!f) {
2737             f = PerlIO_allocate(aTHX);
2738         }
2739         if (!PerlIOValid(f)) {
2740             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2741                 return NULL;
2742             }
2743         }
2744         PerlIOUnix_setfd(aTHX_ f, fd, imode);
2745         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2746         if (*mode == IoTYPE_APPEND)
2747             PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2748         return f;
2749     }
2750     else {
2751         if (f) {
2752             NOOP;
2753             /*
2754              * FIXME: pop layers ???
2755              */
2756         }
2757         return NULL;
2758     }
2759 }
2760
2761 PerlIO *
2762 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2763 {
2764     const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2765     int fd = os->fd;
2766     if (flags & PERLIO_DUP_FD) {
2767         fd = PerlLIO_dup(fd);
2768     }
2769     if (fd >= 0) {
2770         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2771         if (f) {
2772             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2773             PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2774             return f;
2775         }
2776     }
2777     return NULL;
2778 }
2779
2780
2781 SSize_t
2782 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2783 {
2784     dVAR;
2785     int fd;
2786     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2787         return -1;
2788     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2789 #ifdef PERLIO_STD_SPECIAL
2790     if (fd == 0)
2791         return PERLIO_STD_IN(fd, vbuf, count);
2792 #endif
2793     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2794          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2795         return 0;
2796     }
2797     while (1) {
2798         const SSize_t len = PerlLIO_read(fd, vbuf, count);
2799         if (len >= 0 || errno != EINTR) {
2800             if (len < 0) {
2801                 if (errno != EAGAIN) {
2802                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2803                 }
2804             }
2805             else if (len == 0 && count != 0) {
2806                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2807                 SETERRNO(0,0);
2808             }
2809             return len;
2810         }
2811         /* EINTR */
2812         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2813             return -1;
2814     }
2815     /*NOTREACHED*/
2816 }
2817
2818 SSize_t
2819 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2820 {
2821     dVAR;
2822     int fd;
2823     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2824         return -1;
2825     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2826 #ifdef PERLIO_STD_SPECIAL
2827     if (fd == 1 || fd == 2)
2828         return PERLIO_STD_OUT(fd, vbuf, count);
2829 #endif
2830     while (1) {
2831         const SSize_t len = PerlLIO_write(fd, vbuf, count);
2832         if (len >= 0 || errno != EINTR) {
2833             if (len < 0) {
2834                 if (errno != EAGAIN) {
2835                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2836                 }
2837             }
2838             return len;
2839         }
2840         /* EINTR */
2841         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2842             return -1;
2843     }
2844     /*NOTREACHED*/
2845 }
2846
2847 Off_t
2848 PerlIOUnix_tell(pTHX_ PerlIO *f)
2849 {
2850     PERL_UNUSED_CONTEXT;
2851
2852     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2853 }
2854
2855
2856 IV
2857 PerlIOUnix_close(pTHX_ PerlIO *f)
2858 {
2859     dVAR;
2860     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2861     int code = 0;
2862     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2863         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2864             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2865             return 0;
2866         }
2867     }
2868     else {
2869         SETERRNO(EBADF,SS_IVCHAN);
2870         return -1;
2871     }
2872     while (PerlLIO_close(fd) != 0) {
2873         if (errno != EINTR) {
2874             code = -1;
2875             break;
2876         }
2877         /* EINTR */
2878         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2879             return -1;
2880     }
2881     if (code == 0) {
2882         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2883     }
2884     return code;
2885 }
2886
2887 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2888     sizeof(PerlIO_funcs),
2889     "unix",
2890     sizeof(PerlIOUnix),
2891     PERLIO_K_RAW,
2892     PerlIOUnix_pushed,
2893     PerlIOBase_popped,
2894     PerlIOUnix_open,
2895     PerlIOBase_binmode,         /* binmode */
2896     NULL,
2897     PerlIOUnix_fileno,
2898     PerlIOUnix_dup,
2899     PerlIOUnix_read,
2900     PerlIOBase_unread,
2901     PerlIOUnix_write,
2902     PerlIOUnix_seek,
2903     PerlIOUnix_tell,
2904     PerlIOUnix_close,
2905     PerlIOBase_noop_ok,         /* flush */
2906     PerlIOBase_noop_fail,       /* fill */
2907     PerlIOBase_eof,
2908     PerlIOBase_error,
2909     PerlIOBase_clearerr,
2910     PerlIOBase_setlinebuf,
2911     NULL,                       /* get_base */
2912     NULL,                       /* get_bufsiz */
2913     NULL,                       /* get_ptr */
2914     NULL,                       /* get_cnt */
2915     NULL,                       /* set_ptrcnt */
2916 };
2917
2918 /*--------------------------------------------------------------------------------------*/
2919 /*
2920  * stdio as a layer
2921  */
2922
2923 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2924 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2925    broken by the last second glibc 2.3 fix
2926  */
2927 #define STDIO_BUFFER_WRITABLE
2928 #endif
2929
2930
2931 typedef struct {
2932     struct _PerlIO base;
2933     FILE *stdio;                /* The stream */
2934 } PerlIOStdio;
2935
2936 IV
2937 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2938 {
2939     PERL_UNUSED_CONTEXT;
2940
2941     if (PerlIOValid(f)) {
2942         FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2943         if (s)
2944             return PerlSIO_fileno(s);
2945     }
2946     errno = EBADF;
2947     return -1;
2948 }
2949
2950 char *
2951 PerlIOStdio_mode(const char *mode, char *tmode)
2952 {
2953     char * const ret = tmode;
2954     if (mode) {
2955         while (*mode) {
2956             *tmode++ = *mode++;
2957         }
2958     }
2959 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2960     *tmode++ = 'b';
2961 #endif
2962     *tmode = '\0';
2963     return ret;
2964 }
2965
2966 IV
2967 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2968 {
2969     PerlIO *n;
2970     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2971         PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2972         if (toptab == tab) {
2973             /* Top is already stdio - pop self (duplicate) and use original */
2974             PerlIO_pop(aTHX_ f);
2975             return 0;
2976         } else {
2977             const int fd = PerlIO_fileno(n);
2978             char tmode[8];
2979             FILE *stdio;
2980             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
2981                             mode = PerlIOStdio_mode(mode, tmode)))) {
2982                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2983                 /* We never call down so do any pending stuff now */
2984                 PerlIO_flush(PerlIONext(f));
2985             }
2986             else {
2987                 return -1;
2988             }
2989         }
2990     }
2991     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2992 }
2993
2994
2995 PerlIO *
2996 PerlIO_importFILE(FILE *stdio, const char *mode)
2997 {
2998     dTHX;
2999     PerlIO *f = NULL;
3000     if (stdio) {
3001         PerlIOStdio *s;
3002         if (!mode || !*mode) {
3003             /* We need to probe to see how we can open the stream
3004                so start with read/write and then try write and read
3005                we dup() so that we can fclose without loosing the fd.
3006
3007                Note that the errno value set by a failing fdopen
3008                varies between stdio implementations.
3009              */
3010             const int fd = PerlLIO_dup(fileno(stdio));
3011             FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3012             if (!f2) {
3013                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3014             }
3015             if (!f2) {
3016                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3017             }
3018             if (!f2) {
3019                 /* Don't seem to be able to open */
3020                 PerlLIO_close(fd);
3021                 return f;
3022             }
3023             fclose(f2);
3024         }
3025         if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3026             s = PerlIOSelf(f, PerlIOStdio);
3027             s->stdio = stdio;
3028             PerlIOUnix_refcnt_inc(fileno(stdio));
3029         }
3030     }
3031     return f;
3032 }
3033
3034 PerlIO *
3035 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3036                  IV n, const char *mode, int fd, int imode,
3037                  int perm, PerlIO *f, int narg, SV **args)
3038 {
3039     char tmode[8];
3040     if (PerlIOValid(f)) {
3041         const char * const path = SvPV_nolen_const(*args);
3042         PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3043         FILE *stdio;
3044         PerlIOUnix_refcnt_dec(fileno(s->stdio));
3045         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3046                             s->stdio);
3047         if (!s->stdio)
3048             return NULL;
3049         s->stdio = stdio;
3050         PerlIOUnix_refcnt_inc(fileno(s->stdio));
3051         return f;
3052     }
3053     else {
3054         if (narg > 0) {
3055             const char * const path = SvPV_nolen_const(*args);
3056             if (*mode == IoTYPE_NUMERIC) {
3057                 mode++;
3058                 fd = PerlLIO_open3(path, imode, perm);
3059             }
3060             else {
3061                 FILE *stdio;
3062                 bool appended = FALSE;
3063 #ifdef __CYGWIN__
3064                 /* Cygwin wants its 'b' early. */
3065                 appended = TRUE;
3066                 mode = PerlIOStdio_mode(mode, tmode);
3067 #endif
3068                 stdio = PerlSIO_fopen(path, mode);
3069                 if (stdio) {
3070                     if (!f) {
3071                         f = PerlIO_allocate(aTHX);
3072                     }
3073                     if (!appended)
3074                         mode = PerlIOStdio_mode(mode, tmode);
3075                     f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3076                     if (f) {
3077                         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3078                         PerlIOUnix_refcnt_inc(fileno(stdio));
3079                     } else {
3080                         PerlSIO_fclose(stdio);
3081                     }
3082                     return f;
3083                 }
3084                 else {
3085                     return NULL;
3086                 }
3087             }
3088         }
3089         if (fd >= 0) {
3090             FILE *stdio = NULL;
3091             int init = 0;
3092             if (*mode == IoTYPE_IMPLICIT) {
3093                 init = 1;
3094                 mode++;
3095             }
3096             if (init) {
3097                 switch (fd) {
3098                 case 0:
3099                     stdio = PerlSIO_stdin;
3100                     break;
3101                 case 1:
3102                     stdio = PerlSIO_stdout;
3103                     break;
3104                 case 2:
3105                     stdio = PerlSIO_stderr;
3106                     break;
3107                 }
3108             }
3109             else {
3110                 stdio = PerlSIO_fdopen(fd, mode =
3111                                        PerlIOStdio_mode(mode, tmode));
3112             }
3113             if (stdio) {
3114                 if (!f) {
3115                     f = PerlIO_allocate(aTHX);
3116                 }
3117                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3118                     PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3119                     PerlIOUnix_refcnt_inc(fileno(stdio));
3120                 }
3121                 return f;
3122             }
3123         }
3124     }
3125     return NULL;
3126 }
3127
3128 PerlIO *
3129 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3130 {
3131     /* This assumes no layers underneath - which is what
3132        happens, but is not how I remember it. NI-S 2001/10/16
3133      */
3134     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3135         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3136         const int fd = fileno(stdio);
3137         char mode[8];
3138         if (flags & PERLIO_DUP_FD) {
3139             const int dfd = PerlLIO_dup(fileno(stdio));
3140             if (dfd >= 0) {
3141                 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3142                 goto set_this;
3143             }
3144             else {
3145                 NOOP;
3146                 /* FIXME: To avoid messy error recovery if dup fails
3147                    re-use the existing stdio as though flag was not set
3148                  */
3149             }
3150         }
3151         stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3152     set_this:
3153         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3154         if(stdio) {
3155             PerlIOUnix_refcnt_inc(fileno(stdio));
3156         }
3157     }
3158     return f;
3159 }
3160
3161 static int
3162 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3163 {
3164     PERL_UNUSED_CONTEXT;
3165
3166     /* XXX this could use PerlIO_canset_fileno() and
3167      * PerlIO_set_fileno() support from Configure
3168      */
3169 #  if defined(__UCLIBC__)
3170     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3171     f->__filedes = -1;
3172     return 1;
3173 #  elif defined(__GLIBC__)
3174     /* There may be a better way for GLIBC:
3175         - libio.h defines a flag to not close() on cleanup
3176      */
3177     f->_fileno = -1;
3178     return 1;
3179 #  elif defined(__sun__)
3180     PERL_UNUSED_ARG(f);
3181     return 0;
3182 #  elif defined(__hpux)
3183     f->__fileH = 0xff;
3184     f->__fileL = 0xff;
3185     return 1;
3186    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3187       your platform does not have special entry try this one.
3188       [For OSF only have confirmation for Tru64 (alpha)
3189       but assume other OSFs will be similar.]
3190     */
3191 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3192     f->_file = -1;
3193     return 1;
3194 #  elif defined(__FreeBSD__)
3195     /* There may be a better way on FreeBSD:
3196         - we could insert a dummy func in the _close function entry
3197         f->_close = (int (*)(void *)) dummy_close;
3198      */
3199     f->_file = -1;
3200     return 1;
3201 #  elif defined(__OpenBSD__)
3202     /* There may be a better way on OpenBSD:
3203         - we could insert a dummy func in the _close function entry
3204         f->_close = (int (*)(void *)) dummy_close;
3205      */
3206     f->_file = -1;
3207     return 1;
3208 #  elif defined(__EMX__)
3209     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3210     f->_handle = -1;
3211     return 1;
3212 #  elif defined(__CYGWIN__)
3213     /* There may be a better way on CYGWIN:
3214         - we could insert a dummy func in the _close function entry
3215         f->_close = (int (*)(void *)) dummy_close;
3216      */
3217     f->_file = -1;
3218     return 1;
3219 #  elif defined(WIN32)
3220 #    if defined(UNDER_CE)
3221     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3222        structure at all
3223      */
3224 #    else
3225     f->_file = -1;
3226 #    endif
3227     return 1;
3228 #  else
3229 #if 0
3230     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3231        (which isn't thread safe) instead
3232      */
3233 #    error "Don't know how to set FILE.fileno on your platform"
3234 #endif
3235     PERL_UNUSED_ARG(f);
3236     return 0;
3237 #  endif
3238 }
3239
3240 IV
3241 PerlIOStdio_close(pTHX_ PerlIO *f)
3242 {
3243     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3244     if (!stdio) {
3245         errno = EBADF;
3246         return -1;
3247     }
3248     else {
3249         const int fd = fileno(stdio);
3250         int invalidate = 0;
3251         IV result = 0;
3252         int dupfd = -1;
3253         dSAVEDERRNO;
3254 #ifdef USE_ITHREADS
3255         dVAR;
3256 #endif
3257 #ifdef SOCKS5_VERSION_NAME
3258         /* Socks lib overrides close() but stdio isn't linked to
3259            that library (though we are) - so we must call close()
3260            on sockets on stdio's behalf.
3261          */
3262         int optval;
3263         Sock_size_t optlen = sizeof(int);
3264         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3265             invalidate = 1;
3266 #endif
3267         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3268            that a subsequent fileno() on it returns -1. Don't want to croak()
3269            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3270            trying to close an already closed handle which somehow it still has
3271            a reference to. (via.xs, I'm looking at you).  */
3272         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3273             /* File descriptor still in use */
3274             invalidate = 1;
3275         }
3276         if (invalidate) {
3277             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3278             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3279                 return 0;
3280             if (stdio == stdout || stdio == stderr)
3281                 return PerlIO_flush(f);
3282             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3283                Use Sarathy's trick from maint-5.6 to invalidate the
3284                fileno slot of the FILE *
3285             */
3286             result = PerlIO_flush(f);
3287             SAVE_ERRNO;
3288             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3289             if (!invalidate) {
3290 #ifdef USE_ITHREADS
3291                 MUTEX_LOCK(&PL_perlio_mutex);
3292                 /* Right. We need a mutex here because for a brief while we
3293                    will have the situation that fd is actually closed. Hence if
3294                    a second thread were to get into this block, its dup() would
3295                    likely return our fd as its dupfd. (after all, it is closed)
3296                    Then if we get to the dup2() first, we blat the fd back
3297                    (messing up its temporary as a side effect) only for it to
3298                    then close its dupfd (== our fd) in its close(dupfd) */
3299
3300                 /* There is, of course, a race condition, that any other thread
3301                    trying to input/output/whatever on this fd will be stuffed
3302                    for the duration of this little manoeuvrer. Perhaps we
3303                    should hold an IO mutex for the duration of every IO
3304                    operation if we know that invalidate doesn't work on this
3305                    platform, but that would suck, and could kill performance.
3306
3307                    Except that correctness trumps speed.
3308                    Advice from klortho #11912. */
3309 #endif
3310                 dupfd = PerlLIO_dup(fd);
3311 #ifdef USE_ITHREADS
3312                 if (dupfd < 0) {
3313                     MUTEX_UNLOCK(&PL_perlio_mutex);
3314                     /* Oh cXap. This isn't going to go well. Not sure if we can
3315                        recover from here, or if closing this particular FILE *
3316                        is a good idea now.  */
3317                 }
3318 #endif
3319             }
3320         } else {
3321             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3322         }
3323         result = PerlSIO_fclose(stdio);
3324         /* We treat error from stdio as success if we invalidated
3325            errno may NOT be expected EBADF
3326          */
3327         if (invalidate && result != 0) {
3328             RESTORE_ERRNO;
3329             result = 0;
3330         }
3331 #ifdef SOCKS5_VERSION_NAME
3332         /* in SOCKS' case, let close() determine return value */
3333         result = close(fd);
3334 #endif
3335         if (dupfd >= 0) {
3336             PerlLIO_dup2(dupfd,fd);
3337             PerlLIO_close(dupfd);
3338 #ifdef USE_ITHREADS
3339             MUTEX_UNLOCK(&PL_perlio_mutex);
3340 #endif
3341         }
3342         return result;
3343     }
3344 }
3345
3346 SSize_t
3347 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3348 {
3349     dVAR;
3350     FILE * s;
3351     SSize_t got = 0;
3352     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3353         return -1;
3354     s = PerlIOSelf(f, PerlIOStdio)->stdio;
3355     for (;;) {
3356         if (count == 1) {
3357             STDCHAR *buf = (STDCHAR *) vbuf;
3358             /*
3359              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3360              * stdio does not do that for fread()
3361              */
3362             const int ch = PerlSIO_fgetc(s);
3363             if (ch != EOF) {
3364                 *buf = ch;
3365                 got = 1;
3366             }
3367         }
3368         else
3369             got = PerlSIO_fread(vbuf, 1, count, s);
3370         if (got == 0 && PerlSIO_ferror(s))
3371             got = -1;
3372         if (got >= 0 || errno != EINTR)
3373             break;
3374         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3375             return -1;
3376         SETERRNO(0,0);  /* just in case */
3377     }
3378     return got;
3379 }
3380
3381 SSize_t
3382 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3383 {
3384     SSize_t unread = 0;
3385     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3386
3387 #ifdef STDIO_BUFFER_WRITABLE
3388     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3389         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3390         STDCHAR *base = PerlIO_get_base(f);
3391         SSize_t cnt   = PerlIO_get_cnt(f);
3392         STDCHAR *ptr  = PerlIO_get_ptr(f);
3393         SSize_t avail = ptr - base;
3394         if (avail > 0) {
3395             if (avail > count) {
3396                 avail = count;
3397             }
3398             ptr -= avail;
3399             Move(buf-avail,ptr,avail,STDCHAR);
3400             count -= avail;
3401             unread += avail;
3402             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3403             if (PerlSIO_feof(s) && unread >= 0)
3404                 PerlSIO_clearerr(s);
3405         }
3406     }
3407     else
3408 #endif
3409     if (PerlIO_has_cntptr(f)) {
3410         /* We can get pointer to buffer but not its base
3411            Do ungetc() but check chars are ending up in the
3412            buffer
3413          */
3414         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3415         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3416         while (count > 0) {
3417             const int ch = *--buf & 0xFF;
3418             if (ungetc(ch,s) != ch) {
3419                 /* ungetc did not work */
3420                 break;
3421             }
3422             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3423                 /* Did not change pointer as expected */
3424                 fgetc(s);  /* get char back again */
3425                 break;
3426             }
3427             /* It worked ! */
3428             count--;
3429             unread++;
3430         }
3431     }
3432
3433     if (count > 0) {
3434         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3435     }
3436     return unread;
3437 }
3438
3439 SSize_t
3440 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3441 {
3442     dVAR;
3443     SSize_t got;
3444     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3445         return -1;
3446     for (;;) {
3447         got = PerlSIO_fwrite(vbuf, 1, count,
3448                               PerlIOSelf(f, PerlIOStdio)->stdio);
3449         if (got >= 0 || errno != EINTR)
3450             break;
3451         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3452             return -1;
3453         SETERRNO(0,0);  /* just in case */
3454     }
3455     return got;
3456 }
3457
3458 IV
3459 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3460 {
3461     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3462     PERL_UNUSED_CONTEXT;
3463
3464     return PerlSIO_fseek(stdio, offset, whence);
3465 }
3466
3467 Off_t
3468 PerlIOStdio_tell(pTHX_ PerlIO *f)
3469 {
3470     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3471     PERL_UNUSED_CONTEXT;
3472
3473     return PerlSIO_ftell(stdio);
3474 }
3475
3476 IV
3477 PerlIOStdio_flush(pTHX_ PerlIO *f)
3478 {
3479     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3480     PERL_UNUSED_CONTEXT;
3481
3482     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3483         return PerlSIO_fflush(stdio);
3484     }
3485     else {
3486         NOOP;
3487 #if 0
3488         /*
3489          * FIXME: This discards ungetc() and pre-read stuff which is not
3490          * right if this is just a "sync" from a layer above Suspect right
3491          * design is to do _this_ but not have layer above flush this
3492          * layer read-to-read
3493          */
3494         /*
3495          * Not writeable - sync by attempting a seek
3496          */
3497         dSAVE_ERRNO;
3498         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3499             RESTORE_ERRNO;
3500 #endif
3501     }
3502     return 0;
3503 }
3504
3505 IV
3506 PerlIOStdio_eof(pTHX_ PerlIO *f)
3507 {
3508     PERL_UNUSED_CONTEXT;
3509
3510     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3511 }
3512
3513 IV
3514 PerlIOStdio_error(pTHX_ PerlIO *f)
3515 {
3516     PERL_UNUSED_CONTEXT;
3517
3518     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3519 }
3520
3521 void
3522 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3523 {
3524     PERL_UNUSED_CONTEXT;
3525
3526     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3527 }
3528
3529 void
3530 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3531 {
3532     PERL_UNUSED_CONTEXT;
3533
3534 #ifdef HAS_SETLINEBUF
3535     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3536 #else
3537     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3538 #endif
3539 }
3540
3541 #ifdef FILE_base
3542 STDCHAR *
3543 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3544 {
3545     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3546     return (STDCHAR*)PerlSIO_get_base(stdio);
3547 }
3548
3549 Size_t
3550 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3551 {
3552     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3553     return PerlSIO_get_bufsiz(stdio);
3554 }
3555 #endif
3556
3557 #ifdef USE_STDIO_PTR
3558 STDCHAR *
3559 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3560 {
3561     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3562     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3563 }
3564
3565 SSize_t
3566 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3567 {
3568     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3569     return PerlSIO_get_cnt(stdio);
3570 }
3571
3572 void
3573 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3574 {
3575     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3576     if (ptr != NULL) {
3577 #ifdef STDIO_PTR_LVALUE
3578         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3579 #ifdef STDIO_PTR_LVAL_SETS_CNT
3580         assert(PerlSIO_get_cnt(stdio) == (cnt));
3581 #endif
3582 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3583         /*
3584          * Setting ptr _does_ change cnt - we are done
3585          */
3586         return;
3587 #endif
3588 #else                           /* STDIO_PTR_LVALUE */
3589         PerlProc_abort();
3590 #endif                          /* STDIO_PTR_LVALUE */
3591     }
3592     /*
3593      * Now (or only) set cnt
3594      */
3595 #ifdef STDIO_CNT_LVALUE
3596     PerlSIO_set_cnt(stdio, cnt);
3597 #else                           /* STDIO_CNT_LVALUE */
3598 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3599     PerlSIO_set_ptr(stdio,
3600                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3601                                               cnt));
3602 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3603     PerlProc_abort();
3604 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3605 #endif                          /* STDIO_CNT_LVALUE */
3606 }
3607
3608
3609 #endif
3610
3611 IV
3612 PerlIOStdio_fill(pTHX_ PerlIO *f)
3613 {
3614     FILE * stdio;
3615     int c;
3616     PERL_UNUSED_CONTEXT;
3617     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3618         return -1;
3619     stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3620
3621     /*
3622      * fflush()ing read-only streams can cause trouble on some stdio-s
3623      */
3624     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3625         if (PerlSIO_fflush(stdio) != 0)
3626             return EOF;
3627     }
3628     for (;;) {
3629         c = PerlSIO_fgetc(stdio);
3630         if (c != EOF)
3631             break;
3632         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3633             return EOF;
3634         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3635             return -1;
3636         SETERRNO(0,0);
3637     }
3638
3639 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3640
3641 #ifdef STDIO_BUFFER_WRITABLE
3642     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3643         /* Fake ungetc() to the real buffer in case system's ungetc
3644            goes elsewhere
3645          */
3646         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3647         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3648         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3649         if (ptr == base+1) {
3650             *--ptr = (STDCHAR) c;
3651             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3652             if (PerlSIO_feof(stdio))
3653                 PerlSIO_clearerr(stdio);
3654             return 0;
3655         }
3656     }
3657     else
3658 #endif
3659     if (PerlIO_has_cntptr(f)) {
3660         STDCHAR ch = c;
3661         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3662             return 0;
3663         }
3664     }
3665 #endif
3666
3667 #if defined(VMS)
3668     /* An ungetc()d char is handled separately from the regular
3669      * buffer, so we stuff it in the buffer ourselves.
3670      * Should never get called as should hit code above
3671      */
3672     *(--((*stdio)->_ptr)) = (unsigned char) c;
3673     (*stdio)->_cnt++;
3674 #else
3675     /* If buffer snoop scheme above fails fall back to
3676        using ungetc().
3677      */
3678     if (PerlSIO_ungetc(c, stdio) != c)
3679         return EOF;
3680 #endif
3681     return 0;
3682 }
3683
3684
3685
3686 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3687     sizeof(PerlIO_funcs),
3688     "stdio",
3689     sizeof(PerlIOStdio),
3690     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3691     PerlIOStdio_pushed,
3692     PerlIOBase_popped,
3693     PerlIOStdio_open,
3694     PerlIOBase_binmode,         /* binmode */
3695     NULL,
3696     PerlIOStdio_fileno,
3697     PerlIOStdio_dup,
3698     PerlIOStdio_read,
3699     PerlIOStdio_unread,
3700     PerlIOStdio_write,
3701     PerlIOStdio_seek,
3702     PerlIOStdio_tell,
3703     PerlIOStdio_close,
3704     PerlIOStdio_flush,
3705     PerlIOStdio_fill,
3706     PerlIOStdio_eof,
3707     PerlIOStdio_error,
3708     PerlIOStdio_clearerr,
3709     PerlIOStdio_setlinebuf,
3710 #ifdef FILE_base
3711     PerlIOStdio_get_base,
3712     PerlIOStdio_get_bufsiz,
3713 #else
3714     NULL,
3715     NULL,
3716 #endif
3717 #ifdef USE_STDIO_PTR
3718     PerlIOStdio_get_ptr,
3719     PerlIOStdio_get_cnt,
3720 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3721     PerlIOStdio_set_ptrcnt,
3722 #   else
3723     NULL,
3724 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3725 #else
3726     NULL,
3727     NULL,
3728     NULL,
3729 #endif /* USE_STDIO_PTR */
3730 };
3731
3732 /* Note that calls to PerlIO_exportFILE() are reversed using
3733  * PerlIO_releaseFILE(), not importFILE. */
3734 FILE *
3735 PerlIO_exportFILE(PerlIO * f, const char *mode)
3736 {
3737     dTHX;
3738     FILE *stdio = NULL;
3739     if (PerlIOValid(f)) {
3740         char buf[8];
3741         PerlIO_flush(f);
3742         if (!mode || !*mode) {
3743             mode = PerlIO_modestr(f, buf);
3744         }
3745         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3746         if (stdio) {
3747             PerlIOl *l = *f;
3748             PerlIO *f2;
3749             /* De-link any lower layers so new :stdio sticks */
3750             *f = NULL;
3751             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3752                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3753                 s->stdio = stdio;
3754                 PerlIOUnix_refcnt_inc(fileno(stdio));
3755                 /* Link previous lower layers under new one */
3756                 *PerlIONext(f) = l;
3757             }
3758             else {
3759                 /* restore layers list */
3760                 *f = l;
3761             }
3762         }
3763     }
3764     return stdio;
3765 }
3766
3767
3768 FILE *
3769 PerlIO_findFILE(PerlIO *f)
3770 {
3771     PerlIOl *l = *f;
3772     FILE *stdio;
3773     while (l) {
3774         if (l->tab == &PerlIO_stdio) {
3775             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3776             return s->stdio;
3777         }
3778         l = *PerlIONext(&l);
3779     }
3780     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3781     /* However, we're not really exporting a FILE * to someone else (who
3782        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3783        So we need to undo its reference count increase on the underlying file
3784        descriptor. We have to do this, because if the loop above returns you
3785        the FILE *, then *it* didn't increase any reference count. So there's
3786        only one way to be consistent. */
3787     stdio = PerlIO_exportFILE(f, NULL);
3788     if (stdio) {
3789         const int fd = fileno(stdio);
3790         if (fd >= 0)
3791             PerlIOUnix_refcnt_dec(fd);
3792     }
3793     return stdio;
3794 }
3795
3796 /* Use this to reverse PerlIO_exportFILE calls. */
3797 void
3798 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3799 {
3800     dVAR;
3801     PerlIOl *l;
3802     while ((l = *p)) {
3803         if (l->tab == &PerlIO_stdio) {
3804             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3805             if (s->stdio == f) {
3806                 dTHX;
3807                 const int fd = fileno(f);
3808                 if (fd >= 0)
3809                     PerlIOUnix_refcnt_dec(fd);
3810                 PerlIO_pop(aTHX_ p);
3811                 return;
3812             }
3813         }
3814         p = PerlIONext(p);
3815     }
3816     return;
3817 }
3818
3819 /*--------------------------------------------------------------------------------------*/
3820 /*
3821  * perlio buffer layer
3822  */
3823
3824 IV
3825 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3826 {
3827     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3828     const int fd = PerlIO_fileno(f);
3829     if (fd >= 0 && PerlLIO_isatty(fd)) {
3830         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3831     }
3832     if (*PerlIONext(f)) {
3833         const Off_t posn = PerlIO_tell(PerlIONext(f));
3834         if (posn != (Off_t) - 1) {
3835             b->posn = posn;
3836         }
3837     }
3838     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3839 }
3840
3841 PerlIO *
3842 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3843                IV n, const char *mode, int fd, int imode, int perm,
3844                PerlIO *f, int narg, SV **args)
3845 {
3846     if (PerlIOValid(f)) {
3847         PerlIO *next = PerlIONext(f);
3848         PerlIO_funcs *tab =
3849              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3850         if (tab && tab->Open)
3851              next =
3852                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3853                                next, narg, args);
3854         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3855             return NULL;
3856         }
3857     }
3858     else {
3859         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3860         int init = 0;
3861         if (*mode == IoTYPE_IMPLICIT) {
3862             init = 1;
3863             /*
3864              * mode++;
3865              */
3866         }
3867         if (tab && tab->Open)
3868              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3869                               f, narg, args);
3870         else
3871              SETERRNO(EINVAL, LIB_INVARG);
3872         if (f) {
3873             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3874                 /*
3875                  * if push fails during open, open fails. close will pop us.
3876                  */
3877                 PerlIO_close (f);
3878                 return NULL;
3879             } else {
3880                 fd = PerlIO_fileno(f);
3881                 if (init && fd == 2) {
3882                     /*
3883                      * Initial stderr is unbuffered
3884                      */
3885                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3886                 }
3887 #ifdef PERLIO_USING_CRLF
3888 #  ifdef PERLIO_IS_BINMODE_FD
3889                 if (PERLIO_IS_BINMODE_FD(fd))
3890                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3891                 else
3892 #  endif
3893                 /*
3894                  * do something about failing setmode()? --jhi
3895                  */
3896                 PerlLIO_setmode(fd, O_BINARY);
3897 #endif
3898 #ifdef VMS
3899 #include <rms.h>
3900                 /* Enable line buffering with record-oriented regular files
3901                  * so we don't introduce an extraneous record boundary when
3902                  * the buffer fills up.
3903                  */
3904                 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3905                     Stat_t st;
3906                     if (PerlLIO_fstat(fd, &st) == 0
3907                         && S_ISREG(st.st_mode)
3908                         && (st.st_fab_rfm == FAB$C_VAR
3909                             || st.st_fab_rfm == FAB$C_VFC)) {
3910                         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3911                     }
3912                 }
3913 #endif
3914             }
3915         }
3916     }
3917     return f;
3918 }
3919
3920 /*
3921  * This "flush" is akin to sfio's sync in that it handles files in either
3922  * read or write state.  For write state, we put the postponed data through
3923  * the next layers.  For read state, we seek() the next layers to the
3924  * offset given by current position in the buffer, and discard the buffer
3925  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3926  * in any case?).  Then the pass the stick further in chain.
3927  */
3928 IV
3929 PerlIOBuf_flush(pTHX_ PerlIO *f)
3930 {
3931     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3932     int code = 0;
3933     PerlIO *n = PerlIONext(f);
3934     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3935         /*
3936          * write() the buffer
3937          */
3938         const STDCHAR *buf = b->buf;
3939         const STDCHAR *p = buf;
3940         while (p < b->ptr) {
3941             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3942             if (count > 0) {
3943                 p += count;
3944             }
3945             else if (count < 0 || PerlIO_error(n)) {
3946                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3947                 code = -1;
3948                 break;
3949             }
3950         }
3951         b->posn += (p - buf);
3952     }
3953     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3954         STDCHAR *buf = PerlIO_get_base(f);
3955         /*
3956          * Note position change
3957          */
3958         b->posn += (b->ptr - buf);
3959         if (b->ptr < b->end) {
3960             /* We did not consume all of it - try and seek downstream to
3961                our logical position
3962              */
3963             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3964                 /* Reload n as some layers may pop themselves on seek */
3965                 b->posn = PerlIO_tell(n = PerlIONext(f));
3966             }
3967             else {
3968                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3969                    data is lost for good - so return saying "ok" having undone
3970                    the position adjust
3971                  */
3972                 b->posn -= (b->ptr - buf);
3973                 return code;
3974             }
3975         }
3976     }
3977     b->ptr = b->end = b->buf;
3978     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3979     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3980     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3981         code = -1;
3982     return code;
3983 }
3984
3985 /* This discards the content of the buffer after b->ptr, and rereads
3986  * the buffer from the position off in the layer downstream; here off
3987  * is at offset corresponding to b->ptr - b->buf.
3988  */
3989 IV
3990 PerlIOBuf_fill(pTHX_ PerlIO *f)
3991 {
3992     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3993     PerlIO *n = PerlIONext(f);
3994     SSize_t avail;
3995     /*
3996      * Down-stream flush is defined not to loose read data so is harmless.
3997      * we would not normally be fill'ing if there was data left in anycase.
3998      */
3999     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
4000         return -1;
4001     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4002         PerlIOBase_flush_linebuf(aTHX);
4003
4004     if (!b->buf)
4005         PerlIO_get_base(f);     /* allocate via vtable */
4006
4007     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4008
4009     b->ptr = b->end = b->buf;
4010
4011     if (!PerlIOValid(n)) {
4012         PerlIOBase(f)->flags |= PERLIO_F_EOF;
4013         return -1;
4014     }
4015
4016     if (PerlIO_fast_gets(n)) {
4017         /*
4018          * Layer below is also buffered. We do _NOT_ want to call its
4019          * ->Read() because that will loop till it gets what we asked for
4020          * which may hang on a pipe etc. Instead take anything it has to
4021          * hand, or ask it to fill _once_.
4022          */
4023         avail = PerlIO_get_cnt(n);
4024         if (avail <= 0) {
4025             avail = PerlIO_fill(n);
4026             if (avail == 0)
4027                 avail = PerlIO_get_cnt(n);
4028             else {
4029                 if (!PerlIO_error(n) && PerlIO_eof(n))
4030                     avail = 0;
4031             }
4032         }
4033         if (avail > 0) {
4034             STDCHAR *ptr = PerlIO_get_ptr(n);
4035             const SSize_t cnt = avail;
4036             if (avail > (SSize_t)b->bufsiz)
4037                 avail = b->bufsiz;
4038             Copy(ptr, b->buf, avail, STDCHAR);
4039             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4040         }
4041     }
4042     else {
4043         avail = PerlIO_read(n, b->ptr, b->bufsiz);
4044     }
4045     if (avail <= 0) {
4046         if (avail == 0)
4047             PerlIOBase(f)->flags |= PERLIO_F_EOF;
4048         else
4049             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4050         return -1;
4051     }
4052     b->end = b->buf + avail;
4053     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4054     return 0;
4055 }
4056
4057 SSize_t
4058 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4059 {
4060     if (PerlIOValid(f)) {
4061         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4062         if (!b->ptr)
4063             PerlIO_get_base(f);
4064         return PerlIOBase_read(aTHX_ f, vbuf, count);
4065     }
4066     return 0;
4067 }
4068
4069 SSize_t
4070 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4071 {
4072     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4073     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4074     SSize_t unread = 0;
4075     SSize_t avail;
4076     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4077         PerlIO_flush(f);
4078     if (!b->buf)
4079         PerlIO_get_base(f);
4080     if (b->buf) {
4081         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4082             /*
4083              * Buffer is already a read buffer, we can overwrite any chars
4084              * which have been read back to buffer start
4085              */
4086             avail = (b->ptr - b->buf);
4087         }
4088         else {
4089             /*
4090              * Buffer is idle, set it up so whole buffer is available for
4091              * unread
4092              */
4093             avail = b->bufsiz;
4094             b->end = b->buf + avail;
4095             b->ptr = b->end;
4096             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4097             /*
4098              * Buffer extends _back_ from where we are now
4099              */
4100             b->posn -= b->bufsiz;
4101         }
4102         if (avail > (SSize_t) count) {
4103             /*
4104              * If we have space for more than count, just move count
4105              */
4106             avail = count;
4107         }
4108         if (avail > 0) {
4109             b->ptr -= avail;
4110             buf -= avail;
4111             /*
4112              * In simple stdio-like ungetc() case chars will be already
4113              * there
4114              */
4115             if (buf != b->ptr) {
4116                 Copy(buf, b->ptr, avail, STDCHAR);
4117             }
4118             count -= avail;
4119             unread += avail;
4120             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4121         }
4122     }
4123     if (count > 0) {
4124         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4125     }
4126     return unread;
4127 }
4128
4129 SSize_t
4130 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4131 {
4132     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4133     const STDCHAR *buf = (const STDCHAR *) vbuf;
4134     const STDCHAR *flushptr = buf;
4135     Size_t written = 0;
4136     if (!b->buf)
4137         PerlIO_get_base(f);
4138     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4139         return 0;
4140     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4141         if (PerlIO_flush(f) != 0) {
4142             return 0;
4143         }
4144     }
4145     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4146         flushptr = buf + count;
4147         while (flushptr > buf && *(flushptr - 1) != '\n')
4148             --flushptr;
4149     }
4150     while (count > 0) {
4151         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4152         if ((SSize_t) count < avail)
4153             avail = count;
4154         if (flushptr > buf && flushptr <= buf + avail)
4155             avail = flushptr - buf;
4156         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4157         if (avail) {
4158             Copy(buf, b->ptr, avail, STDCHAR);
4159             count -= avail;
4160             buf += avail;
4161             written += avail;
4162             b->ptr += avail;
4163             if (buf == flushptr)
4164                 PerlIO_flush(f);
4165         }
4166         if (b->ptr >= (b->buf + b->bufsiz))
4167             if (PerlIO_flush(f) == -1)
4168                 return -1;
4169     }
4170     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4171         PerlIO_flush(f);
4172     return written;
4173 }
4174
4175 IV
4176 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4177 {
4178     IV code;
4179     if ((code = PerlIO_flush(f)) == 0) {
4180         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4181         code = PerlIO_seek(PerlIONext(f), offset, whence);
4182         if (code == 0) {
4183             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4184             b->posn = PerlIO_tell(PerlIONext(f));
4185         }
4186     }
4187     return code;
4188 }
4189
4190 Off_t
4191 PerlIOBuf_tell(pTHX_ PerlIO *f)
4192 {
4193     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4194     /*
4195      * b->posn is file position where b->buf was read, or will be written
4196      */
4197     Off_t posn = b->posn;
4198     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4199         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4200 #if 1
4201         /* As O_APPEND files are normally shared in some sense it is better
4202            to flush :
4203          */
4204         PerlIO_flush(f);
4205 #else
4206         /* when file is NOT shared then this is sufficient */
4207         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4208 #endif
4209         posn = b->posn = PerlIO_tell(PerlIONext(f));
4210     }
4211     if (b->buf) {
4212         /*
4213          * If buffer is valid adjust position by amount in buffer
4214          */
4215         posn += (b->ptr - b->buf);
4216     }
4217     return posn;
4218 }
4219
4220 IV
4221 PerlIOBuf_popped(pTHX_ PerlIO *f)
4222 {
4223     const IV code = PerlIOBase_popped(aTHX_ f);
4224     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4225     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4226         Safefree(b->buf);
4227     }
4228     b->ptr = b->end = b->buf = NULL;
4229     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4230     return code;
4231 }
4232
4233 IV
4234 PerlIOBuf_close(pTHX_ PerlIO *f)
4235 {
4236     const IV code = PerlIOBase_close(aTHX_ f);
4237     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4238     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4239         Safefree(b->buf);
4240     }
4241     b->ptr = b->end = b->buf = NULL;
4242     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4243     return code;
4244 }
4245
4246 STDCHAR *
4247 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4248 {
4249     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4250     if (!b->buf)
4251         PerlIO_get_base(f);
4252     return b->ptr;
4253 }
4254
4255 SSize_t
4256 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4257 {
4258     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4259     if (!b->buf)
4260         PerlIO_get_base(f);
4261     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4262         return (b->end - b->ptr);
4263     return 0;
4264 }
4265
4266 STDCHAR *
4267 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4268 {
4269     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4270     PERL_UNUSED_CONTEXT;
4271
4272     if (!b->buf) {
4273         if (!b->bufsiz)
4274             b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4275         Newxz(b->buf,b->bufsiz, STDCHAR);
4276         if (!b->buf) {
4277             b->buf = (STDCHAR *) & b->oneword;
4278             b->bufsiz = sizeof(b->oneword);
4279         }
4280         b->end = b->ptr = b->buf;
4281     }
4282     return b->buf;
4283 }
4284
4285 Size_t
4286 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4287 {
4288     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4289     if (!b->buf)
4290         PerlIO_get_base(f);
4291     return (b->end - b->buf);
4292 }
4293
4294 void
4295 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4296 {
4297     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4298 #ifndef DEBUGGING
4299     PERL_UNUSED_ARG(cnt);
4300 #endif
4301     if (!b->buf)
4302         PerlIO_get_base(f);
4303     b->ptr = ptr;
4304     assert(PerlIO_get_cnt(f) == cnt);
4305     assert(b->ptr >= b->buf);
4306     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4307 }
4308
4309 PerlIO *
4310 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4311 {
4312  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4313 }
4314
4315
4316
4317 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4318     sizeof(PerlIO_funcs),
4319     "perlio",
4320     sizeof(PerlIOBuf),
4321     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4322     PerlIOBuf_pushed,
4323     PerlIOBuf_popped,
4324     PerlIOBuf_open,
4325     PerlIOBase_binmode,         /* binmode */
4326     NULL,
4327     PerlIOBase_fileno,
4328     PerlIOBuf_dup,
4329     PerlIOBuf_read,
4330     PerlIOBuf_unread,
4331     PerlIOBuf_write,
4332     PerlIOBuf_seek,
4333     PerlIOBuf_tell,
4334     PerlIOBuf_close,
4335     PerlIOBuf_flush,
4336     PerlIOBuf_fill,
4337     PerlIOBase_eof,
4338     PerlIOBase_error,
4339     PerlIOBase_clearerr,
4340     PerlIOBase_setlinebuf,
4341     PerlIOBuf_get_base,
4342     PerlIOBuf_bufsiz,
4343     PerlIOBuf_get_ptr,
4344     PerlIOBuf_get_cnt,
4345     PerlIOBuf_set_ptrcnt,
4346 };
4347
4348 /*--------------------------------------------------------------------------------------*/
4349 /*
4350  * Temp layer to hold unread chars when cannot do it any other way
4351  */
4352
4353 IV
4354 PerlIOPending_fill(pTHX_ PerlIO *f)
4355 {
4356     /*
4357      * Should never happen
4358      */
4359     PerlIO_flush(f);
4360     return 0;
4361 }
4362
4363 IV
4364 PerlIOPending_close(pTHX_ PerlIO *f)
4365 {
4366     /*
4367      * A tad tricky - flush pops us, then we close new top
4368      */
4369     PerlIO_flush(f);
4370     return PerlIO_close(f);
4371 }
4372
4373 IV
4374 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4375 {
4376     /*
4377      * A tad tricky - flush pops us, then we seek new top
4378      */
4379     PerlIO_flush(f);
4380     return PerlIO_seek(f, offset, whence);
4381 }
4382
4383
4384 IV
4385 PerlIOPending_flush(pTHX_ PerlIO *f)
4386 {
4387     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4388     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4389         Safefree(b->buf);
4390         b->buf = NULL;
4391     }
4392     PerlIO_pop(aTHX_ f);
4393     return 0;
4394 }
4395
4396 void
4397 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4398 {
4399     if (cnt <= 0) {
4400         PerlIO_flush(f);
4401     }
4402     else {
4403         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4404     }
4405 }
4406
4407 IV
4408 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4409 {
4410     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4411     PerlIOl * const l = PerlIOBase(f);
4412     /*
4413      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4414      * etc. get muddled when it changes mid-string when we auto-pop.
4415      */
4416     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4417         (PerlIOBase(PerlIONext(f))->
4418          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4419     return code;
4420 }
4421
4422 SSize_t
4423 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4424 {
4425     SSize_t avail = PerlIO_get_cnt(f);
4426     SSize_t got = 0;
4427     if ((SSize_t)count < avail)
4428         avail = count;
4429     if (avail > 0)
4430         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4431     if (got >= 0 && got < (SSize_t)count) {
4432         const SSize_t more =
4433             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4434         if (more >= 0 || got == 0)
4435             got += more;
4436     }
4437     return got;
4438 }
4439
4440 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4441     sizeof(PerlIO_funcs),
4442     "pending",
4443     sizeof(PerlIOBuf),
4444     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4445     PerlIOPending_pushed,
4446     PerlIOBuf_popped,
4447     NULL,
4448     PerlIOBase_binmode,         /* binmode */
4449     NULL,
4450     PerlIOBase_fileno,
4451     PerlIOBuf_dup,
4452     PerlIOPending_read,
4453     PerlIOBuf_unread,
4454     PerlIOBuf_write,
4455     PerlIOPending_seek,
4456     PerlIOBuf_tell,
4457     PerlIOPending_close,
4458     PerlIOPending_flush,
4459     PerlIOPending_fill,
4460     PerlIOBase_eof,
4461     PerlIOBase_error,
4462     PerlIOBase_clearerr,
4463     PerlIOBase_setlinebuf,
4464     PerlIOBuf_get_base,
4465     PerlIOBuf_bufsiz,
4466     PerlIOBuf_get_ptr,
4467     PerlIOBuf_get_cnt,
4468     PerlIOPending_set_ptrcnt,
4469 };
4470
4471
4472
4473 /*--------------------------------------------------------------------------------------*/
4474 /*
4475  * crlf - translation On read translate CR,LF to "\n" we do this by
4476  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4477  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4478  *
4479  * c->nl points on the first byte of CR LF pair when it is temporarily
4480  * replaced by LF, or to the last CR of the buffer.  In the former case
4481  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4482  * that it ends at c->nl; these two cases can be distinguished by
4483  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4484  * _unread() and _flush() calls.
4485  * It only matters for read operations.
4486  */
4487
4488 typedef struct {
4489     PerlIOBuf base;             /* PerlIOBuf stuff */
4490     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4491                                  * buffer */
4492 } PerlIOCrlf;
4493
4494 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4495  * Otherwise the :crlf layer would always revert back to
4496  * raw mode.
4497  */
4498 static void
4499 S_inherit_utf8_flag(PerlIO *f)
4500 {
4501     PerlIO *g = PerlIONext(f);
4502     if (PerlIOValid(g)) {
4503         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4504             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4505         }
4506     }
4507 }
4508
4509 IV
4510 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4511 {
4512     IV code;
4513     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4514     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4515 #if 0
4516     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4517                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4518                  PerlIOBase(f)->flags);
4519 #endif
4520     {
4521       /* If the old top layer is a CRLF layer, reactivate it (if
4522        * necessary) and remove this new layer from the stack */
4523          PerlIO *g = PerlIONext(f);
4524          if (PerlIOValid(g)) {
4525               PerlIOl *b = PerlIOBase(g);
4526               if (b && b->tab == &PerlIO_crlf) {
4527                    if (!(b->flags & PERLIO_F_CRLF))
4528                         b->flags |= PERLIO_F_CRLF;
4529                    S_inherit_utf8_flag(g);
4530                    PerlIO_pop(aTHX_ f);
4531                    return code;
4532               }
4533          }
4534     }
4535     S_inherit_utf8_flag(f);
4536     return code;
4537 }
4538
4539
4540 SSize_t
4541 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4542 {
4543     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4544     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4545         *(c->nl) = 0xd;
4546         c->nl = NULL;
4547     }
4548     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4549         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4550     else {
4551         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4552         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4553         SSize_t unread = 0;
4554         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4555             PerlIO_flush(f);
4556         if (!b->buf)
4557             PerlIO_get_base(f);
4558         if (b->buf) {
4559             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4560                 b->end = b->ptr = b->buf + b->bufsiz;
4561                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4562                 b->posn -= b->bufsiz;
4563             }
4564             while (count > 0 && b->ptr > b->buf) {
4565                 const int ch = *--buf;
4566                 if (ch == '\n') {
4567                     if (b->ptr - 2 >= b->buf) {
4568                         *--(b->ptr) = 0xa;
4569                         *--(b->ptr) = 0xd;
4570                         unread++;
4571                         count--;
4572                     }
4573                     else {
4574                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4575                         *--(b->ptr) = 0xa;      /* Works even if 0xa == '\r' */
4576                         unread++;
4577                         count--;
4578                     }
4579                 }
4580                 else {
4581                     *--(b->ptr) = ch;
4582                     unread++;
4583                     count--;
4584                 }
4585             }
4586         }
4587         return unread;
4588     }
4589 }
4590
4591 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4592 SSize_t
4593 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4594 {
4595     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4596     if (!b->buf)
4597         PerlIO_get_base(f);
4598     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4599         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4600         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4601             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4602           scan:
4603             while (nl < b->end && *nl != 0xd)
4604                 nl++;
4605             if (nl < b->end && *nl == 0xd) {
4606               test:
4607                 if (nl + 1 < b->end) {
4608                     if (nl[1] == 0xa) {
4609                         *nl = '\n';
4610                         c->nl = nl;
4611                     }
4612                     else {
4613                         /*
4614                          * Not CR,LF but just CR
4615                          */
4616                         nl++;
4617                         goto scan;
4618                     }
4619                 }
4620                 else {
4621                     /*
4622                      * Blast - found CR as last char in buffer
4623                      */
4624
4625                     if (b->ptr < nl) {
4626                         /*
4627                          * They may not care, defer work as long as
4628                          * possible
4629                          */
4630                         c->nl = nl;
4631                         return (nl - b->ptr);
4632                     }
4633                     else {
4634                         int code;
4635                         b->ptr++;       /* say we have read it as far as
4636                                          * flush() is concerned */
4637                         b->buf++;       /* Leave space in front of buffer */
4638                         /* Note as we have moved buf up flush's
4639                            posn += ptr-buf
4640                            will naturally make posn point at CR
4641                          */
4642                         b->bufsiz--;    /* Buffer is thus smaller */
4643                         code = PerlIO_fill(f);  /* Fetch some more */
4644                         b->bufsiz++;    /* Restore size for next time */
4645                         b->buf--;       /* Point at space */
4646                         b->ptr = nl = b->buf;   /* Which is what we hand
4647                                                  * off */
4648                         *nl = 0xd;      /* Fill in the CR */
4649                         if (code == 0)
4650                             goto test;  /* fill() call worked */
4651                         /*
4652                          * CR at EOF - just fall through
4653                          */
4654                         /* Should we clear EOF though ??? */
4655                     }
4656                 }
4657             }
4658         }
4659         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4660     }
4661     return 0;
4662 }
4663
4664 void
4665 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4666 {
4667     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4668     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4669     if (!b->buf)
4670         PerlIO_get_base(f);
4671     if (!ptr) {
4672         if (c->nl) {
4673             ptr = c->nl + 1;
4674             if (ptr == b->end && *c->nl == 0xd) {
4675                 /* Deferred CR at end of buffer case - we lied about count */
4676                 ptr--;
4677             }
4678         }
4679         else {
4680             ptr = b->end;
4681         }
4682         ptr -= cnt;
4683     }
4684     else {
4685         NOOP;
4686 #if 0
4687         /*
4688          * Test code - delete when it works ...
4689          */
4690         IV flags = PerlIOBase(f)->flags;
4691         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4692         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4693           /* Deferred CR at end of buffer case - we lied about count */
4694           chk--;
4695         }
4696         chk -= cnt;
4697
4698         if (ptr != chk ) {
4699             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4700                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4701                        flags, c->nl, b->end, cnt);
4702         }
4703 #endif
4704     }
4705     if (c->nl) {
4706         if (ptr > c->nl) {
4707             /*
4708              * They have taken what we lied about
4709              */
4710             *(c->nl) = 0xd;
4711             c->nl = NULL;
4712             ptr++;
4713         }
4714     }
4715     b->ptr = ptr;
4716     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4717 }
4718
4719 SSize_t
4720 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4721 {
4722     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4723         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4724     else {
4725         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4726         const STDCHAR *buf = (const STDCHAR *) vbuf;
4727         const STDCHAR * const ebuf = buf + count;
4728         if (!b->buf)
4729             PerlIO_get_base(f);
4730         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4731             return 0;
4732         while (buf < ebuf) {
4733             const STDCHAR * const eptr = b->buf + b->bufsiz;
4734             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4735             while (buf < ebuf && b->ptr < eptr) {
4736                 if (*buf == '\n') {
4737                     if ((b->ptr + 2) > eptr) {
4738                         /*
4739                          * Not room for both
4740                          */
4741                         PerlIO_flush(f);
4742                         break;
4743                     }
4744                     else {
4745                         *(b->ptr)++ = 0xd;      /* CR */
4746                         *(b->ptr)++ = 0xa;      /* LF */
4747                         buf++;
4748                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4749                             PerlIO_flush(f);
4750                             break;
4751                         }
4752                     }
4753                 }
4754                 else {
4755                     *(b->ptr)++ = *buf++;
4756                 }
4757                 if (b->ptr >= eptr) {
4758                     PerlIO_flush(f);
4759                     break;
4760                 }
4761             }
4762         }
4763         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4764             PerlIO_flush(f);
4765         return (buf - (STDCHAR *) vbuf);
4766     }
4767 }
4768
4769 IV
4770 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4771 {
4772     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4773     if (c->nl) {
4774         *(c->nl) = 0xd;
4775         c->nl = NULL;
4776     }
4777     return PerlIOBuf_flush(aTHX_ f);
4778 }
4779
4780 IV
4781 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4782 {
4783     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4784         /* In text mode - flush any pending stuff and flip it */
4785         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4786 #ifndef PERLIO_USING_CRLF
4787         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4788         PerlIO_pop(aTHX_ f);
4789 #endif
4790     }
4791     return 0;
4792 }
4793
4794 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4795     sizeof(PerlIO_funcs),
4796     "crlf",
4797     sizeof(PerlIOCrlf),
4798     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4799     PerlIOCrlf_pushed,
4800     PerlIOBuf_popped,         /* popped */
4801     PerlIOBuf_open,
4802     PerlIOCrlf_binmode,       /* binmode */
4803     NULL,
4804     PerlIOBase_fileno,
4805     PerlIOBuf_dup,
4806     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4807     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4808     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4809     PerlIOBuf_seek,
4810     PerlIOBuf_tell,
4811     PerlIOBuf_close,
4812     PerlIOCrlf_flush,
4813     PerlIOBuf_fill,
4814     PerlIOBase_eof,
4815     PerlIOBase_error,
4816     PerlIOBase_clearerr,
4817     PerlIOBase_setlinebuf,
4818     PerlIOBuf_get_base,
4819     PerlIOBuf_bufsiz,
4820     PerlIOBuf_get_ptr,
4821     PerlIOCrlf_get_cnt,
4822     PerlIOCrlf_set_ptrcnt,
4823 };
4824
4825 #ifdef HAS_MMAP
4826 /*--------------------------------------------------------------------------------------*/
4827 /*
4828  * mmap as "buffer" layer
4829  */
4830
4831 typedef struct {
4832     PerlIOBuf base;             /* PerlIOBuf stuff */
4833     Mmap_t mptr;                /* Mapped address */
4834     Size_t len;                 /* mapped length */
4835     STDCHAR *bbuf;              /* malloced buffer if map fails */
4836 } PerlIOMmap;
4837
4838 IV
4839 PerlIOMmap_map(pTHX_ PerlIO *f)
4840 {
4841     dVAR;
4842     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4843     const IV flags = PerlIOBase(f)->flags;
4844     IV code = 0;
4845     if (m->len)
4846         abort();
4847     if (flags & PERLIO_F_CANREAD) {
4848         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4849         const int fd = PerlIO_fileno(f);
4850         Stat_t st;
4851         code = Fstat(fd, &st);
4852         if (code == 0 && S_ISREG(st.st_mode)) {
4853             SSize_t len = st.st_size - b->posn;
4854             if (len > 0) {
4855                 Off_t posn;
4856                 if (PL_mmap_page_size <= 0)
4857                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4858                              PL_mmap_page_size);
4859                 if (b->posn < 0) {
4860                     /*
4861                      * This is a hack - should never happen - open should
4862                      * have set it !
4863                      */
4864                     b->posn = PerlIO_tell(PerlIONext(f));
4865                 }
4866                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4867                 len = st.st_size - posn;