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