perlio.c

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