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