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