perlio.c

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