perlio.c

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