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