perlio.c

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