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