perlio.c

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