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