perlio.c

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