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