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