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