perlio.c

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