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