perlio.c

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