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