perlio.c

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