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