perlio.c

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