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     PERL_UNUSED_ARG(f);
2974     return 0;
2975 #  elif defined(__hpux)
2976     f->__fileH = 0xff;
2977     f->__fileL = 0xff;
2978     return 1;
2979    /* Next one ->_file seems to be a reasonable fallback, i.e. if
2980       your platform does not have special entry try this one.
2981       [For OSF only have confirmation for Tru64 (alpha)
2982       but assume other OSFs will be similar.]
2983     */
2984 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
2985     f->_file = -1;
2986     return 1;
2987 #  elif defined(__FreeBSD__)
2988     /* There may be a better way on FreeBSD:
2989         - we could insert a dummy func in the _close function entry
2990         f->_close = (int (*)(void *)) dummy_close;
2991      */
2992     f->_file = -1;
2993     return 1;
2994 #  elif defined(__OpenBSD__)
2995     /* There may be a better way on OpenBSD:
2996         - we could insert a dummy func in the _close function entry
2997         f->_close = (int (*)(void *)) dummy_close;
2998      */
2999     f->_file = -1;
3000     return 1;
3001 #  elif defined(__EMX__)
3002     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3003     f->_handle = -1;
3004     return 1;
3005 #  elif defined(__CYGWIN__)
3006     /* There may be a better way on CYGWIN:
3007         - we could insert a dummy func in the _close function entry
3008         f->_close = (int (*)(void *)) dummy_close;
3009      */
3010     f->_file = -1;
3011     return 1;
3012 #  elif defined(WIN32)
3013 #    if defined(__BORLANDC__)
3014     f->fd = PerlLIO_dup(fileno(f));
3015 #    elif defined(UNDER_CE)
3016     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3017        structure at all
3018      */
3019 #    else
3020     f->_file = -1;
3021 #    endif
3022     return 1;
3023 #  else
3024 #if 0
3025     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3026        (which isn't thread safe) instead
3027      */
3028 #    error "Don't know how to set FILE.fileno on your platform"
3029 #endif
3030     PERL_UNUSED_ARG(f);
3031     return 0;
3032 #  endif
3033 }
3034
3035 IV
3036 PerlIOStdio_close(pTHX_ PerlIO *f)
3037 {
3038     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3039     if (!stdio) {
3040         errno = EBADF;
3041         return -1;
3042     }
3043     else {
3044         const int fd = fileno(stdio);
3045         int invalidate = 0;
3046         IV result = 0;
3047         int saveerr = 0;
3048         int dupfd = 0;
3049 #ifdef SOCKS5_VERSION_NAME
3050         /* Socks lib overrides close() but stdio isn't linked to
3051            that library (though we are) - so we must call close()
3052            on sockets on stdio's behalf.
3053          */
3054         int optval;
3055         Sock_size_t optlen = sizeof(int);
3056         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3057             invalidate = 1;
3058 #endif
3059         if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
3060             invalidate = 1;
3061         if (invalidate) {
3062             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3063             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3064                 return 0;
3065             if (stdio == stdout || stdio == stderr)
3066                 return PerlIO_flush(f);
3067             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3068                Use Sarathy's trick from maint-5.6 to invalidate the
3069                fileno slot of the FILE *
3070             */
3071             result = PerlIO_flush(f);
3072             saveerr = errno;
3073             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3074             if (!invalidate)
3075                 dupfd = PerlLIO_dup(fd);
3076         }
3077         result = PerlSIO_fclose(stdio);
3078         /* We treat error from stdio as success if we invalidated
3079            errno may NOT be expected EBADF
3080          */
3081         if (invalidate && result != 0) {
3082             errno = saveerr;
3083             result = 0;
3084         }
3085 #ifdef SOCKS5_VERSION_NAME
3086         /* in SOCKS' case, let close() determine return value */
3087         result = close(fd);
3088 #endif
3089         if (dupfd) {
3090             PerlLIO_dup2(dupfd,fd);
3091             PerlLIO_close(dupfd);
3092         }
3093         return result;
3094     }
3095 }
3096
3097 SSize_t
3098 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3099 {
3100     dVAR;
3101     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3102     SSize_t got = 0;
3103     for (;;) {
3104         if (count == 1) {
3105             STDCHAR *buf = (STDCHAR *) vbuf;
3106             /*
3107              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3108              * stdio does not do that for fread()
3109              */
3110             const int ch = PerlSIO_fgetc(s);
3111             if (ch != EOF) {
3112                 *buf = ch;
3113                 got = 1;
3114             }
3115         }
3116         else
3117             got = PerlSIO_fread(vbuf, 1, count, s);
3118         if (got == 0 && PerlSIO_ferror(s))
3119             got = -1;
3120         if (got >= 0 || errno != EINTR)
3121             break;
3122         PERL_ASYNC_CHECK();
3123         SETERRNO(0,0);  /* just in case */
3124     }
3125     return got;
3126 }
3127
3128 SSize_t
3129 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3130 {
3131     SSize_t unread = 0;
3132     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3133
3134 #ifdef STDIO_BUFFER_WRITABLE
3135     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3136         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3137         STDCHAR *base = PerlIO_get_base(f);
3138         SSize_t cnt   = PerlIO_get_cnt(f);
3139         STDCHAR *ptr  = PerlIO_get_ptr(f);
3140         SSize_t avail = ptr - base;
3141         if (avail > 0) {
3142             if (avail > count) {
3143                 avail = count;
3144             }
3145             ptr -= avail;
3146             Move(buf-avail,ptr,avail,STDCHAR);
3147             count -= avail;
3148             unread += avail;
3149             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3150             if (PerlSIO_feof(s) && unread >= 0)
3151                 PerlSIO_clearerr(s);
3152         }
3153     }
3154     else
3155 #endif
3156     if (PerlIO_has_cntptr(f)) {
3157         /* We can get pointer to buffer but not its base
3158            Do ungetc() but check chars are ending up in the
3159            buffer
3160          */
3161         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3162         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3163         while (count > 0) {
3164             const int ch = *--buf & 0xFF;
3165             if (ungetc(ch,s) != ch) {
3166                 /* ungetc did not work */
3167                 break;
3168             }
3169             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3170                 /* Did not change pointer as expected */
3171                 fgetc(s);  /* get char back again */
3172                 break;
3173             }
3174             /* It worked ! */
3175             count--;
3176             unread++;
3177         }
3178     }
3179
3180     if (count > 0) {
3181         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3182     }
3183     return unread;
3184 }
3185
3186 SSize_t
3187 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3188 {
3189     dVAR;
3190     SSize_t got;
3191     for (;;) {
3192         got = PerlSIO_fwrite(vbuf, 1, count,
3193                               PerlIOSelf(f, PerlIOStdio)->stdio);
3194         if (got >= 0 || errno != EINTR)
3195             break;
3196         PERL_ASYNC_CHECK();
3197         SETERRNO(0,0);  /* just in case */
3198     }
3199     return got;
3200 }
3201
3202 IV
3203 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3204 {
3205     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3206     PERL_UNUSED_CONTEXT;
3207
3208     return PerlSIO_fseek(stdio, offset, whence);
3209 }
3210
3211 Off_t
3212 PerlIOStdio_tell(pTHX_ PerlIO *f)
3213 {
3214     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3215     PERL_UNUSED_CONTEXT;
3216
3217     return PerlSIO_ftell(stdio);
3218 }
3219
3220 IV
3221 PerlIOStdio_flush(pTHX_ PerlIO *f)
3222 {
3223     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3224     PERL_UNUSED_CONTEXT;
3225
3226     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3227         return PerlSIO_fflush(stdio);
3228     }
3229     else {
3230         NOOP;
3231 #if 0
3232         /*
3233          * FIXME: This discards ungetc() and pre-read stuff which is not
3234          * right if this is just a "sync" from a layer above Suspect right
3235          * design is to do _this_ but not have layer above flush this
3236          * layer read-to-read
3237          */
3238         /*
3239          * Not writeable - sync by attempting a seek
3240          */
3241         const int err = errno;
3242         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3243             errno = err;
3244 #endif
3245     }
3246     return 0;
3247 }
3248
3249 IV
3250 PerlIOStdio_eof(pTHX_ PerlIO *f)
3251 {
3252     PERL_UNUSED_CONTEXT;
3253
3254     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3255 }
3256
3257 IV
3258 PerlIOStdio_error(pTHX_ PerlIO *f)
3259 {
3260     PERL_UNUSED_CONTEXT;
3261
3262     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3263 }
3264
3265 void
3266 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3267 {
3268     PERL_UNUSED_CONTEXT;
3269
3270     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3271 }
3272
3273 void
3274 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3275 {
3276     PERL_UNUSED_CONTEXT;
3277
3278 #ifdef HAS_SETLINEBUF
3279     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3280 #else
3281     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3282 #endif
3283 }
3284
3285 #ifdef FILE_base
3286 STDCHAR *
3287 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3288 {
3289     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3290     return (STDCHAR*)PerlSIO_get_base(stdio);
3291 }
3292
3293 Size_t
3294 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3295 {
3296     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3297     return PerlSIO_get_bufsiz(stdio);
3298 }
3299 #endif
3300
3301 #ifdef USE_STDIO_PTR
3302 STDCHAR *
3303 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3304 {
3305     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3306     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3307 }
3308
3309 SSize_t
3310 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3311 {
3312     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3313     return PerlSIO_get_cnt(stdio);
3314 }
3315
3316 void
3317 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3318 {
3319     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3320     if (ptr != NULL) {
3321 #ifdef STDIO_PTR_LVALUE
3322         PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
3323 #ifdef STDIO_PTR_LVAL_SETS_CNT
3324         if (PerlSIO_get_cnt(stdio) != (cnt)) {
3325             assert(PerlSIO_get_cnt(stdio) == (cnt));
3326         }
3327 #endif
3328 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3329         /*
3330          * Setting ptr _does_ change cnt - we are done
3331          */
3332         return;
3333 #endif
3334 #else                           /* STDIO_PTR_LVALUE */
3335         PerlProc_abort();
3336 #endif                          /* STDIO_PTR_LVALUE */
3337     }
3338     /*
3339      * Now (or only) set cnt
3340      */
3341 #ifdef STDIO_CNT_LVALUE
3342     PerlSIO_set_cnt(stdio, cnt);
3343 #else                           /* STDIO_CNT_LVALUE */
3344 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3345     PerlSIO_set_ptr(stdio,
3346                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3347                                               cnt));
3348 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3349     PerlProc_abort();
3350 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3351 #endif                          /* STDIO_CNT_LVALUE */
3352 }
3353
3354
3355 #endif
3356
3357 IV
3358 PerlIOStdio_fill(pTHX_ PerlIO *f)
3359 {
3360     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3361     int c;
3362     PERL_UNUSED_CONTEXT;
3363
3364     /*
3365      * fflush()ing read-only streams can cause trouble on some stdio-s
3366      */
3367     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3368         if (PerlSIO_fflush(stdio) != 0)
3369             return EOF;
3370     }
3371     c = PerlSIO_fgetc(stdio);
3372     if (c == EOF)
3373         return EOF;
3374
3375 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3376
3377 #ifdef STDIO_BUFFER_WRITABLE
3378     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3379         /* Fake ungetc() to the real buffer in case system's ungetc
3380            goes elsewhere
3381          */
3382         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3383         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3384         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3385         if (ptr == base+1) {
3386             *--ptr = (STDCHAR) c;
3387             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3388             if (PerlSIO_feof(stdio))
3389                 PerlSIO_clearerr(stdio);
3390             return 0;
3391         }
3392     }
3393     else
3394 #endif
3395     if (PerlIO_has_cntptr(f)) {
3396         STDCHAR ch = c;
3397         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3398             return 0;
3399         }
3400     }
3401 #endif
3402
3403 #if defined(VMS)
3404     /* An ungetc()d char is handled separately from the regular
3405      * buffer, so we stuff it in the buffer ourselves.
3406      * Should never get called as should hit code above
3407      */
3408     *(--((*stdio)->_ptr)) = (unsigned char) c;
3409     (*stdio)->_cnt++;
3410 #else
3411     /* If buffer snoop scheme above fails fall back to
3412        using ungetc().
3413      */
3414     if (PerlSIO_ungetc(c, stdio) != c)
3415         return EOF;
3416 #endif
3417     return 0;
3418 }
3419
3420
3421
3422 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3423     sizeof(PerlIO_funcs),
3424     "stdio",
3425     sizeof(PerlIOStdio),
3426     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3427     PerlIOStdio_pushed,
3428     PerlIOBase_popped,
3429     PerlIOStdio_open,
3430     PerlIOBase_binmode,         /* binmode */
3431     NULL,
3432     PerlIOStdio_fileno,
3433     PerlIOStdio_dup,
3434     PerlIOStdio_read,
3435     PerlIOStdio_unread,
3436     PerlIOStdio_write,
3437     PerlIOStdio_seek,
3438     PerlIOStdio_tell,
3439     PerlIOStdio_close,
3440     PerlIOStdio_flush,
3441     PerlIOStdio_fill,
3442     PerlIOStdio_eof,
3443     PerlIOStdio_error,
3444     PerlIOStdio_clearerr,
3445     PerlIOStdio_setlinebuf,
3446 #ifdef FILE_base
3447     PerlIOStdio_get_base,
3448     PerlIOStdio_get_bufsiz,
3449 #else
3450     NULL,
3451     NULL,
3452 #endif
3453 #ifdef USE_STDIO_PTR
3454     PerlIOStdio_get_ptr,
3455     PerlIOStdio_get_cnt,
3456 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3457     PerlIOStdio_set_ptrcnt,
3458 #   else
3459     NULL,
3460 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3461 #else
3462     NULL,
3463     NULL,
3464     NULL,
3465 #endif /* USE_STDIO_PTR */
3466 };
3467
3468 /* Note that calls to PerlIO_exportFILE() are reversed using
3469  * PerlIO_releaseFILE(), not importFILE. */
3470 FILE *
3471 PerlIO_exportFILE(PerlIO * f, const char *mode)
3472 {
3473     dTHX;
3474     FILE *stdio = NULL;
3475     if (PerlIOValid(f)) {
3476         char buf[8];
3477         PerlIO_flush(f);
3478         if (!mode || !*mode) {
3479             mode = PerlIO_modestr(f, buf);
3480         }
3481         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3482         if (stdio) {
3483             PerlIOl *l = *f;
3484             PerlIO *f2;
3485             /* De-link any lower layers so new :stdio sticks */
3486             *f = NULL;
3487             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3488                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3489                 s->stdio = stdio;
3490                 /* Link previous lower layers under new one */
3491                 *PerlIONext(f) = l;
3492             }
3493             else {
3494                 /* restore layers list */
3495                 *f = l;
3496             }
3497         }
3498     }
3499     return stdio;
3500 }
3501
3502
3503 FILE *
3504 PerlIO_findFILE(PerlIO *f)
3505 {
3506     PerlIOl *l = *f;
3507     while (l) {
3508         if (l->tab == &PerlIO_stdio) {
3509             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3510             return s->stdio;
3511         }
3512         l = *PerlIONext(&l);
3513     }
3514     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3515     return PerlIO_exportFILE(f, NULL);
3516 }
3517
3518 /* Use this to reverse PerlIO_exportFILE calls. */
3519 void
3520 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3521 {
3522     dVAR;
3523     PerlIOl *l;
3524     while ((l = *p)) {
3525         if (l->tab == &PerlIO_stdio) {
3526             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3527             if (s->stdio == f) {
3528                 dTHX;
3529                 PerlIO_pop(aTHX_ p);
3530                 return;
3531             }
3532         }
3533         p = PerlIONext(p);
3534     }
3535     return;
3536 }
3537
3538 /*--------------------------------------------------------------------------------------*/
3539 /*
3540  * perlio buffer layer
3541  */
3542
3543 IV
3544 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3545 {
3546     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3547     const int fd = PerlIO_fileno(f);
3548     if (fd >= 0 && PerlLIO_isatty(fd)) {
3549         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3550     }
3551     if (*PerlIONext(f)) {
3552         const Off_t posn = PerlIO_tell(PerlIONext(f));
3553         if (posn != (Off_t) - 1) {
3554             b->posn = posn;
3555         }
3556     }
3557     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3558 }
3559
3560 PerlIO *
3561 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3562                IV n, const char *mode, int fd, int imode, int perm,
3563                PerlIO *f, int narg, SV **args)
3564 {
3565     if (PerlIOValid(f)) {
3566         PerlIO *next = PerlIONext(f);
3567         PerlIO_funcs *tab =
3568              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3569         if (tab && tab->Open)
3570              next =
3571                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3572                                next, narg, args);
3573         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3574             return NULL;
3575         }
3576     }
3577     else {
3578         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3579         int init = 0;
3580         if (*mode == IoTYPE_IMPLICIT) {
3581             init = 1;
3582             /*
3583              * mode++;
3584              */
3585         }
3586         if (tab && tab->Open)
3587              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3588                               f, narg, args);
3589         else
3590              SETERRNO(EINVAL, LIB_INVARG);
3591         if (f) {
3592             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3593                 /*
3594                  * if push fails during open, open fails. close will pop us.
3595                  */
3596                 PerlIO_close (f);
3597                 return NULL;
3598             } else {
3599                 fd = PerlIO_fileno(f);
3600                 if (init && fd == 2) {
3601                     /*
3602                      * Initial stderr is unbuffered
3603                      */
3604                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3605                 }
3606 #ifdef PERLIO_USING_CRLF
3607 #  ifdef PERLIO_IS_BINMODE_FD
3608                 if (PERLIO_IS_BINMODE_FD(fd))
3609                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3610                 else
3611 #  endif
3612                 /*
3613                  * do something about failing setmode()? --jhi
3614                  */
3615                 PerlLIO_setmode(fd, O_BINARY);
3616 #endif
3617             }
3618         }
3619     }
3620     return f;
3621 }
3622
3623 /*
3624  * This "flush" is akin to sfio's sync in that it handles files in either
3625  * read or write state.  For write state, we put the postponed data through
3626  * the next layers.  For read state, we seek() the next layers to the
3627  * offset given by current position in the buffer, and discard the buffer
3628  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3629  * in any case?).  Then the pass the stick further in chain.
3630  */
3631 IV
3632 PerlIOBuf_flush(pTHX_ PerlIO *f)
3633 {
3634     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3635     int code = 0;
3636     PerlIO *n = PerlIONext(f);
3637     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3638         /*
3639          * write() the buffer
3640          */
3641         const STDCHAR *buf = b->buf;
3642         const STDCHAR *p = buf;
3643         while (p < b->ptr) {
3644             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3645             if (count > 0) {
3646                 p += count;
3647             }
3648             else if (count < 0 || PerlIO_error(n)) {
3649                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3650                 code = -1;
3651                 break;
3652             }
3653         }
3654         b->posn += (p - buf);
3655     }
3656     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3657         STDCHAR *buf = PerlIO_get_base(f);
3658         /*
3659          * Note position change
3660          */
3661         b->posn += (b->ptr - buf);
3662         if (b->ptr < b->end) {
3663             /* We did not consume all of it - try and seek downstream to
3664                our logical position
3665              */
3666             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3667                 /* Reload n as some layers may pop themselves on seek */
3668                 b->posn = PerlIO_tell(n = PerlIONext(f));
3669             }
3670             else {
3671                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3672                    data is lost for good - so return saying "ok" having undone
3673                    the position adjust
3674                  */
3675                 b->posn -= (b->ptr - buf);
3676                 return code;
3677             }
3678         }
3679     }
3680     b->ptr = b->end = b->buf;
3681     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3682     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3683     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3684         code = -1;
3685     return code;
3686 }
3687
3688 /* This discards the content of the buffer after b->ptr, and rereads
3689  * the buffer from the position off in the layer downstream; here off
3690  * is at offset corresponding to b->ptr - b->buf.
3691  */
3692 IV
3693 PerlIOBuf_fill(pTHX_ PerlIO *f)
3694 {
3695     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3696     PerlIO *n = PerlIONext(f);
3697     SSize_t avail;
3698     /*
3699      * Down-stream flush is defined not to loose read data so is harmless.
3700      * we would not normally be fill'ing if there was data left in anycase.
3701      */
3702     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
3703         return -1;
3704     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3705         PerlIOBase_flush_linebuf(aTHX);
3706
3707     if (!b->buf)
3708         PerlIO_get_base(f);     /* allocate via vtable */
3709
3710     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3711
3712     b->ptr = b->end = b->buf;
3713
3714     if (!PerlIOValid(n)) {
3715         PerlIOBase(f)->flags |= PERLIO_F_EOF;
3716         return -1;
3717     }
3718
3719     if (PerlIO_fast_gets(n)) {
3720         /*
3721          * Layer below is also buffered. We do _NOT_ want to call its
3722          * ->Read() because that will loop till it gets what we asked for
3723          * which may hang on a pipe etc. Instead take anything it has to
3724          * hand, or ask it to fill _once_.
3725          */
3726         avail = PerlIO_get_cnt(n);
3727         if (avail <= 0) {
3728             avail = PerlIO_fill(n);
3729             if (avail == 0)
3730                 avail = PerlIO_get_cnt(n);
3731             else {
3732                 if (!PerlIO_error(n) && PerlIO_eof(n))
3733                     avail = 0;
3734             }
3735         }
3736         if (avail > 0) {
3737             STDCHAR *ptr = PerlIO_get_ptr(n);
3738             const SSize_t cnt = avail;
3739             if (avail > (SSize_t)b->bufsiz)
3740                 avail = b->bufsiz;
3741             Copy(ptr, b->buf, avail, STDCHAR);
3742             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3743         }
3744     }
3745     else {
3746         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3747     }
3748     if (avail <= 0) {
3749         if (avail == 0)
3750             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3751         else
3752             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3753         return -1;
3754     }
3755     b->end = b->buf + avail;
3756     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3757     return 0;
3758 }
3759
3760 SSize_t
3761 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3762 {
3763     if (PerlIOValid(f)) {
3764         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3765         if (!b->ptr)
3766             PerlIO_get_base(f);
3767         return PerlIOBase_read(aTHX_ f, vbuf, count);
3768     }
3769     return 0;
3770 }
3771
3772 SSize_t
3773 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3774 {
3775     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3776     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3777     SSize_t unread = 0;
3778     SSize_t avail;
3779     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3780         PerlIO_flush(f);
3781     if (!b->buf)
3782         PerlIO_get_base(f);
3783     if (b->buf) {
3784         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3785             /*
3786              * Buffer is already a read buffer, we can overwrite any chars
3787              * which have been read back to buffer start
3788              */
3789             avail = (b->ptr - b->buf);
3790         }
3791         else {
3792             /*
3793              * Buffer is idle, set it up so whole buffer is available for
3794              * unread
3795              */
3796             avail = b->bufsiz;
3797             b->end = b->buf + avail;
3798             b->ptr = b->end;
3799             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3800             /*
3801              * Buffer extends _back_ from where we are now
3802              */
3803             b->posn -= b->bufsiz;
3804         }
3805         if (avail > (SSize_t) count) {
3806             /*
3807              * If we have space for more than count, just move count
3808              */
3809             avail = count;
3810         }
3811         if (avail > 0) {
3812             b->ptr -= avail;
3813             buf -= avail;
3814             /*
3815              * In simple stdio-like ungetc() case chars will be already
3816              * there
3817              */
3818             if (buf != b->ptr) {
3819                 Copy(buf, b->ptr, avail, STDCHAR);
3820             }
3821             count -= avail;
3822             unread += avail;
3823             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3824         }
3825     }
3826     if (count > 0) {
3827         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3828     }
3829     return unread;
3830 }
3831
3832 SSize_t
3833 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3834 {
3835     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3836     const STDCHAR *buf = (const STDCHAR *) vbuf;
3837     const STDCHAR *flushptr = buf;
3838     Size_t written = 0;
3839     if (!b->buf)
3840         PerlIO_get_base(f);
3841     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3842         return 0;
3843     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3844         if (PerlIO_flush(f) != 0) {
3845             return 0;
3846         }
3847     }
3848     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3849         flushptr = buf + count;
3850         while (flushptr > buf && *(flushptr - 1) != '\n')
3851             --flushptr;
3852     }
3853     while (count > 0) {
3854         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3855         if ((SSize_t) count < avail)
3856             avail = count;
3857         if (flushptr > buf && flushptr <= buf + avail)
3858             avail = flushptr - buf;
3859         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3860         if (avail) {
3861             Copy(buf, b->ptr, avail, STDCHAR);
3862             count -= avail;
3863             buf += avail;
3864             written += avail;
3865             b->ptr += avail;
3866             if (buf == flushptr)
3867                 PerlIO_flush(f);
3868         }
3869         if (b->ptr >= (b->buf + b->bufsiz))
3870             PerlIO_flush(f);
3871     }
3872     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3873         PerlIO_flush(f);
3874     return written;
3875 }
3876
3877 IV
3878 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3879 {
3880     IV code;
3881     if ((code = PerlIO_flush(f)) == 0) {
3882         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3883         code = PerlIO_seek(PerlIONext(f), offset, whence);
3884         if (code == 0) {
3885             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3886             b->posn = PerlIO_tell(PerlIONext(f));
3887         }
3888     }
3889     return code;
3890 }
3891
3892 Off_t
3893 PerlIOBuf_tell(pTHX_ PerlIO *f)
3894 {
3895     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3896     /*
3897      * b->posn is file position where b->buf was read, or will be written
3898      */
3899     Off_t posn = b->posn;
3900     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
3901         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3902 #if 1
3903         /* As O_APPEND files are normally shared in some sense it is better
3904            to flush :
3905          */
3906         PerlIO_flush(f);
3907 #else
3908         /* when file is NOT shared then this is sufficient */
3909         PerlIO_seek(PerlIONext(f),0, SEEK_END);
3910 #endif
3911         posn = b->posn = PerlIO_tell(PerlIONext(f));
3912     }
3913     if (b->buf) {
3914         /*
3915          * If buffer is valid adjust position by amount in buffer
3916          */
3917         posn += (b->ptr - b->buf);
3918     }
3919     return posn;
3920 }
3921
3922 IV
3923 PerlIOBuf_popped(pTHX_ PerlIO *f)
3924 {
3925     const IV code = PerlIOBase_popped(aTHX_ f);
3926     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3927     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3928         Safefree(b->buf);
3929     }
3930     b->ptr = b->end = b->buf = NULL;
3931     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3932     return code;
3933 }
3934
3935 IV
3936 PerlIOBuf_close(pTHX_ PerlIO *f)
3937 {
3938     const IV code = PerlIOBase_close(aTHX_ f);
3939     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3940     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3941         Safefree(b->buf);
3942     }
3943     b->ptr = b->end = b->buf = NULL;
3944     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3945     return code;
3946 }
3947
3948 STDCHAR *
3949 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3950 {
3951     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3952     if (!b->buf)
3953         PerlIO_get_base(f);
3954     return b->ptr;
3955 }
3956
3957 SSize_t
3958 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3959 {
3960     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3961     if (!b->buf)
3962         PerlIO_get_base(f);
3963     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3964         return (b->end - b->ptr);
3965     return 0;
3966 }
3967
3968 STDCHAR *
3969 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3970 {
3971     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3972     PERL_UNUSED_CONTEXT;
3973
3974     if (!b->buf) {
3975         if (!b->bufsiz)
3976             b->bufsiz = 4096;
3977         b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
3978         if (!b->buf) {
3979             b->buf = (STDCHAR *) & b->oneword;
3980             b->bufsiz = sizeof(b->oneword);
3981         }
3982         b->end = b->ptr = b->buf;
3983     }
3984     return b->buf;
3985 }
3986
3987 Size_t
3988 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3989 {
3990     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3991     if (!b->buf)
3992         PerlIO_get_base(f);
3993     return (b->end - b->buf);
3994 }
3995
3996 void
3997 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3998 {
3999     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4000     if (!b->buf)
4001         PerlIO_get_base(f);
4002     b->ptr = ptr;
4003     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
4004         assert(PerlIO_get_cnt(f) == cnt);
4005         assert(b->ptr >= b->buf);
4006     }
4007     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4008 }
4009
4010 PerlIO *
4011 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4012 {
4013  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4014 }
4015
4016
4017
4018 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4019     sizeof(PerlIO_funcs),
4020     "perlio",
4021     sizeof(PerlIOBuf),
4022     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4023     PerlIOBuf_pushed,
4024     PerlIOBuf_popped,
4025     PerlIOBuf_open,
4026     PerlIOBase_binmode,         /* binmode */
4027     NULL,
4028     PerlIOBase_fileno,
4029     PerlIOBuf_dup,
4030     PerlIOBuf_read,
4031     PerlIOBuf_unread,
4032     PerlIOBuf_write,
4033     PerlIOBuf_seek,
4034     PerlIOBuf_tell,
4035     PerlIOBuf_close,
4036     PerlIOBuf_flush,
4037     PerlIOBuf_fill,
4038     PerlIOBase_eof,
4039     PerlIOBase_error,
4040     PerlIOBase_clearerr,
4041     PerlIOBase_setlinebuf,
4042     PerlIOBuf_get_base,
4043     PerlIOBuf_bufsiz,
4044     PerlIOBuf_get_ptr,
4045     PerlIOBuf_get_cnt,
4046     PerlIOBuf_set_ptrcnt,
4047 };
4048
4049 /*--------------------------------------------------------------------------------------*/
4050 /*
4051  * Temp layer to hold unread chars when cannot do it any other way
4052  */
4053
4054 IV
4055 PerlIOPending_fill(pTHX_ PerlIO *f)
4056 {
4057     /*
4058      * Should never happen
4059      */
4060     PerlIO_flush(f);
4061     return 0;
4062 }
4063
4064 IV
4065 PerlIOPending_close(pTHX_ PerlIO *f)
4066 {
4067     /*
4068      * A tad tricky - flush pops us, then we close new top
4069      */
4070     PerlIO_flush(f);
4071     return PerlIO_close(f);
4072 }
4073
4074 IV
4075 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4076 {
4077     /*
4078      * A tad tricky - flush pops us, then we seek new top
4079      */
4080     PerlIO_flush(f);
4081     return PerlIO_seek(f, offset, whence);
4082 }
4083
4084
4085 IV
4086 PerlIOPending_flush(pTHX_ PerlIO *f)
4087 {
4088     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4089     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4090         Safefree(b->buf);
4091         b->buf = NULL;
4092     }
4093     PerlIO_pop(aTHX_ f);
4094     return 0;
4095 }
4096
4097 void
4098 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4099 {
4100     if (cnt <= 0) {
4101         PerlIO_flush(f);
4102     }
4103     else {
4104         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4105     }
4106 }
4107
4108 IV
4109 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4110 {
4111     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4112     PerlIOl * const l = PerlIOBase(f);
4113     /*
4114      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4115      * etc. get muddled when it changes mid-string when we auto-pop.
4116      */
4117     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4118         (PerlIOBase(PerlIONext(f))->
4119          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4120     return code;
4121 }
4122
4123 SSize_t
4124 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4125 {
4126     SSize_t avail = PerlIO_get_cnt(f);
4127     SSize_t got = 0;
4128     if ((SSize_t)count < avail)
4129         avail = count;
4130     if (avail > 0)
4131         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4132     if (got >= 0 && got < (SSize_t)count) {
4133         const SSize_t more =
4134             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4135         if (more >= 0 || got == 0)
4136             got += more;
4137     }
4138     return got;
4139 }
4140
4141 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4142     sizeof(PerlIO_funcs),
4143     "pending",
4144     sizeof(PerlIOBuf),
4145     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4146     PerlIOPending_pushed,
4147     PerlIOBuf_popped,
4148     NULL,
4149     PerlIOBase_binmode,         /* binmode */
4150     NULL,
4151     PerlIOBase_fileno,
4152     PerlIOBuf_dup,
4153     PerlIOPending_read,
4154     PerlIOBuf_unread,
4155     PerlIOBuf_write,
4156     PerlIOPending_seek,
4157     PerlIOBuf_tell,
4158     PerlIOPending_close,
4159     PerlIOPending_flush,
4160     PerlIOPending_fill,
4161     PerlIOBase_eof,
4162     PerlIOBase_error,
4163     PerlIOBase_clearerr,
4164     PerlIOBase_setlinebuf,
4165     PerlIOBuf_get_base,
4166     PerlIOBuf_bufsiz,
4167     PerlIOBuf_get_ptr,
4168     PerlIOBuf_get_cnt,
4169     PerlIOPending_set_ptrcnt,
4170 };
4171
4172
4173
4174 /*--------------------------------------------------------------------------------------*/
4175 /*
4176  * crlf - translation On read translate CR,LF to "\n" we do this by
4177  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4178  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4179  *
4180  * c->nl points on the first byte of CR LF pair when it is temporarily
4181  * replaced by LF, or to the last CR of the buffer.  In the former case
4182  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4183  * that it ends at c->nl; these two cases can be distinguished by
4184  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4185  * _unread() and _flush() calls.
4186  * It only matters for read operations.
4187  */
4188
4189 typedef struct {
4190     PerlIOBuf base;             /* PerlIOBuf stuff */
4191     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4192                                  * buffer */
4193 } PerlIOCrlf;
4194
4195 IV
4196 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4197 {
4198     IV code;
4199     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4200     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4201 #if 0
4202     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4203                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4204                  PerlIOBase(f)->flags);
4205 #endif
4206     {
4207       /* Enable the first CRLF capable layer you can find, but if none
4208        * found, the one we just pushed is fine.  This results in at
4209        * any given moment at most one CRLF-capable layer being enabled
4210        * in the whole layer stack. */
4211          PerlIO *g = PerlIONext(f);
4212          while (g && *g) {
4213               PerlIOl *b = PerlIOBase(g);
4214               if (b && b->tab == &PerlIO_crlf) {
4215                    if (!(b->flags & PERLIO_F_CRLF))
4216                         b->flags |= PERLIO_F_CRLF;
4217                    PerlIO_pop(aTHX_ f);
4218                    return code;
4219               }
4220               g = PerlIONext(g);
4221          }
4222     }
4223     return code;
4224 }
4225
4226
4227 SSize_t
4228 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4229 {
4230     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4231     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4232         *(c->nl) = 0xd;
4233         c->nl = NULL;
4234     }
4235     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4236         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4237     else {
4238         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4239         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4240         SSize_t unread = 0;
4241         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4242             PerlIO_flush(f);
4243         if (!b->buf)
4244             PerlIO_get_base(f);
4245         if (b->buf) {
4246             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4247                 b->end = b->ptr = b->buf + b->bufsiz;
4248                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4249                 b->posn -= b->bufsiz;
4250             }
4251             while (count > 0 && b->ptr > b->buf) {
4252                 const int ch = *--buf;
4253                 if (ch == '\n') {
4254                     if (b->ptr - 2 >= b->buf) {
4255                         *--(b->ptr) = 0xa;
4256                         *--(b->ptr) = 0xd;
4257                         unread++;
4258                         count--;
4259                     }
4260                     else {
4261                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4262                         *--(b->ptr) = 0xa;      /* Works even if 0xa == '\r' */
4263                         unread++;
4264                         count--;
4265                     }
4266                 }
4267                 else {
4268                     *--(b->ptr) = ch;
4269                     unread++;
4270                     count--;
4271                 }
4272             }
4273         }
4274         return unread;
4275     }
4276 }
4277
4278 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4279 SSize_t
4280 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4281 {
4282     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4283     if (!b->buf)
4284         PerlIO_get_base(f);
4285     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4286         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4287         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4288             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4289           scan:
4290             while (nl < b->end && *nl != 0xd)
4291                 nl++;
4292             if (nl < b->end && *nl == 0xd) {
4293               test:
4294                 if (nl + 1 < b->end) {
4295                     if (nl[1] == 0xa) {
4296                         *nl = '\n';
4297                         c->nl = nl;
4298                     }
4299                     else {
4300                         /*
4301                          * Not CR,LF but just CR
4302                          */
4303                         nl++;
4304                         goto scan;
4305                     }
4306                 }
4307                 else {
4308                     /*
4309                      * Blast - found CR as last char in buffer
4310                      */
4311
4312                     if (b->ptr < nl) {
4313                         /*
4314                          * They may not care, defer work as long as
4315                          * possible
4316                          */
4317                         c->nl = nl;
4318                         return (nl - b->ptr);
4319                     }
4320                     else {
4321                         int code;
4322                         b->ptr++;       /* say we have read it as far as
4323                                          * flush() is concerned */
4324                         b->buf++;       /* Leave space in front of buffer */
4325                         /* Note as we have moved buf up flush's
4326                            posn += ptr-buf
4327                            will naturally make posn point at CR
4328                          */
4329                         b->bufsiz--;    /* Buffer is thus smaller */
4330                         code = PerlIO_fill(f);  /* Fetch some more */
4331                         b->bufsiz++;    /* Restore size for next time */
4332                         b->buf--;       /* Point at space */
4333                         b->ptr = nl = b->buf;   /* Which is what we hand
4334                                                  * off */
4335                         *nl = 0xd;      /* Fill in the CR */
4336                         if (code == 0)
4337                             goto test;  /* fill() call worked */
4338                         /*
4339                          * CR at EOF - just fall through
4340                          */
4341                         /* Should we clear EOF though ??? */
4342                     }
4343                 }
4344             }
4345         }
4346         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4347     }
4348     return 0;
4349 }
4350
4351 void
4352 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4353 {
4354     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4355     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4356     if (!b->buf)
4357         PerlIO_get_base(f);
4358     if (!ptr) {
4359         if (c->nl) {
4360             ptr = c->nl + 1;
4361             if (ptr == b->end && *c->nl == 0xd) {
4362                 /* Defered CR at end of buffer case - we lied about count */
4363                 ptr--;
4364             }
4365         }
4366         else {
4367             ptr = b->end;
4368         }
4369         ptr -= cnt;
4370     }
4371     else {
4372         NOOP;
4373 #if 0
4374         /*
4375          * Test code - delete when it works ...
4376          */
4377         IV flags = PerlIOBase(f)->flags;
4378         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4379         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4380           /* Defered CR at end of buffer case - we lied about count */
4381           chk--;
4382         }
4383         chk -= cnt;
4384
4385         if (ptr != chk ) {
4386             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4387                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
4388                        b->end, cnt);
4389         }
4390 #endif
4391     }
4392     if (c->nl) {
4393         if (ptr > c->nl) {
4394             /*
4395              * They have taken what we lied about
4396              */
4397             *(c->nl) = 0xd;
4398             c->nl = NULL;
4399             ptr++;
4400         }
4401     }
4402     b->ptr = ptr;
4403     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4404 }
4405
4406 SSize_t
4407 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4408 {
4409     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4410         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4411     else {
4412         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4413         const STDCHAR *buf = (const STDCHAR *) vbuf;
4414         const STDCHAR * const ebuf = buf + count;
4415         if (!b->buf)
4416             PerlIO_get_base(f);
4417         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4418             return 0;
4419         while (buf < ebuf) {
4420             const STDCHAR * const eptr = b->buf + b->bufsiz;
4421             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4422             while (buf < ebuf && b->ptr < eptr) {
4423                 if (*buf == '\n') {
4424                     if ((b->ptr + 2) > eptr) {
4425                         /*
4426                          * Not room for both
4427                          */
4428                         PerlIO_flush(f);
4429                         break;
4430                     }
4431                     else {
4432                         *(b->ptr)++ = 0xd;      /* CR */
4433                         *(b->ptr)++ = 0xa;      /* LF */
4434                         buf++;
4435                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4436                             PerlIO_flush(f);
4437                             break;
4438                         }
4439                     }
4440                 }
4441                 else {
4442                     *(b->ptr)++ = *buf++;
4443                 }
4444                 if (b->ptr >= eptr) {
4445                     PerlIO_flush(f);
4446                     break;
4447                 }
4448             }
4449         }
4450         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4451             PerlIO_flush(f);
4452         return (buf - (STDCHAR *) vbuf);
4453     }
4454 }
4455
4456 IV
4457 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4458 {
4459     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4460     if (c->nl) {
4461         *(c->nl) = 0xd;
4462         c->nl = NULL;
4463     }
4464     return PerlIOBuf_flush(aTHX_ f);
4465 }
4466
4467 IV
4468 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4469 {
4470     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4471         /* In text mode - flush any pending stuff and flip it */
4472         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4473 #ifndef PERLIO_USING_CRLF
4474         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4475         if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4476                 PerlIO_pop(aTHX_ f);
4477         }
4478 #endif
4479     }
4480     return 0;
4481 }
4482
4483 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4484     sizeof(PerlIO_funcs),
4485     "crlf",
4486     sizeof(PerlIOCrlf),
4487     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4488     PerlIOCrlf_pushed,
4489     PerlIOBuf_popped,         /* popped */
4490     PerlIOBuf_open,
4491     PerlIOCrlf_binmode,       /* binmode */
4492     NULL,
4493     PerlIOBase_fileno,
4494     PerlIOBuf_dup,
4495     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4496     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4497     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4498     PerlIOBuf_seek,
4499     PerlIOBuf_tell,
4500     PerlIOBuf_close,
4501     PerlIOCrlf_flush,
4502     PerlIOBuf_fill,
4503     PerlIOBase_eof,
4504     PerlIOBase_error,
4505     PerlIOBase_clearerr,
4506     PerlIOBase_setlinebuf,
4507     PerlIOBuf_get_base,
4508     PerlIOBuf_bufsiz,
4509     PerlIOBuf_get_ptr,
4510     PerlIOCrlf_get_cnt,
4511     PerlIOCrlf_set_ptrcnt,
4512 };
4513
4514 #ifdef HAS_MMAP
4515 /*--------------------------------------------------------------------------------------*/
4516 /*
4517  * mmap as "buffer" layer
4518  */
4519
4520 typedef struct {
4521     PerlIOBuf base;             /* PerlIOBuf stuff */
4522     Mmap_t mptr;                /* Mapped address */
4523     Size_t len;                 /* mapped length */
4524     STDCHAR *bbuf;              /* malloced buffer if map fails */
4525 } PerlIOMmap;
4526
4527 IV
4528 PerlIOMmap_map(pTHX_ PerlIO *f)
4529 {
4530     dVAR;
4531     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4532     const IV flags = PerlIOBase(f)->flags;
4533     IV code = 0;
4534     if (m->len)
4535         abort();
4536     if (flags & PERLIO_F_CANREAD) {
4537         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4538         const int fd = PerlIO_fileno(f);
4539         Stat_t st;
4540         code = Fstat(fd, &st);
4541         if (code == 0 && S_ISREG(st.st_mode)) {
4542             SSize_t len = st.st_size - b->posn;
4543             if (len > 0) {
4544                 Off_t posn;
4545                 if (PL_mmap_page_size <= 0)
4546                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4547                              PL_mmap_page_size);
4548                 if (b->posn < 0) {
4549                     /*
4550                      * This is a hack - should never happen - open should
4551                      * have set it !
4552                      */
4553                     b->posn = PerlIO_tell(PerlIONext(f));
4554                 }
4555                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4556                 len = st.st_size - posn;
4557                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4558                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4559 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4560                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4561 #endif
4562 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4563                     madvise(m->mptr, len, MADV_WILLNEED);
4564 #endif
4565                     PerlIOBase(f)->flags =
4566                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4567                     b->end = ((STDCHAR *) m->mptr) + len;
4568                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4569                     b->ptr = b->buf;
4570                     m->len = len;
4571                 }
4572                 else {
4573                     b->buf = NULL;
4574                 }
4575             }
4576             else {
4577                 PerlIOBase(f)->flags =
4578                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4579                 b->buf = NULL;
4580                 b->ptr = b->end = b->ptr;
4581                 code = -1;
4582             }
4583         }
4584     }
4585     return code;
4586 }
4587
4588 IV
4589 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4590 {
4591     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4592     IV code = 0;
4593     if (m->len) {
4594         PerlIOBuf * const b = &m->base;
4595         if (b->buf) {
4596             code = munmap(m->mptr, m->len);
4597             b->buf = NULL;
4598             m->len = 0;
4599             m->mptr = NULL;
4600             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4601                 code = -1;
4602         }
4603         b->ptr = b->end = b->buf;
4604         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4605     }
4606     return code;
4607 }
4608
4609 STDCHAR *
4610 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4611 {
4612     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4613     PerlIOBuf * const b = &m->base;
4614     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4615         /*
4616          * Already have a readbuffer in progress
4617          */
4618         return b->buf;
4619     }
4620     if (b->buf) {
4621         /*
4622          * We have a write buffer or flushed PerlIOBuf read buffer
4623          */
4624         m->bbuf = b->buf;       /* save it in case we need it again */
4625         b->buf = NULL;          /* Clear to trigger below */
4626     }
4627     if (!b->buf) {
4628         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
4629         if (!b->buf) {
4630             /*
4631              * Map did not work - recover PerlIOBuf buffer if we have one
4632              */
4633             b->buf = m->bbuf;
4634         }
4635     }
4636     b->ptr = b->end = b->buf;
4637     if (b->buf)
4638         return b->buf;
4639     return PerlIOBuf_get_base(aTHX_ f);
4640 }
4641
4642 SSize_t
4643 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4644 {
4645     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4646     PerlIOBuf * const b = &m->base;
4647     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4648         PerlIO_flush(f);
4649     if (b->ptr && (b->ptr - count) >= b->buf
4650         && memEQ(b->ptr - count, vbuf, count)) {
4651         b->ptr -= count;
4652         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4653         return count;
4654     }
4655     if (m->len) {
4656         /*
4657          * Loose the unwritable mapped buffer
4658          */
4659         PerlIO_flush(f);
4660         /*
4661          * If flush took the "buffer" see if we have one from before
4662          */
4663         if (!b->buf && m->bbuf)
4664             b->buf = m->bbuf;
4665         if (!b->buf) {
4666             PerlIOBuf_get_base(aTHX_ f);
4667             m->bbuf = b->buf;
4668         }
4669     }
4670     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4671 }
4672
4673 SSize_t
4674 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4675 {
4676     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4677     PerlIOBuf * const b = &m->base;
4678
4679     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4680         /*
4681          * No, or wrong sort of, buffer
4682          */
4683         if (m->len) {
4684             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4685                 return 0;
4686         }
4687         /*
4688          * If unmap took the "buffer" see if we have one from before
4689          */
4690         if (!b->buf && m->bbuf)
4691             b->buf = m->bbuf;
4692         if (!b->buf) {
4693             PerlIOBuf_get_base(aTHX_ f);
4694             m->bbuf = b->buf;
4695         }
4696     }
4697     return PerlIOBuf_write(aTHX_ f, vbuf, count);
4698 }
4699
4700 IV
4701 PerlIOMmap_flush(pTHX_ PerlIO *f)
4702 {
4703     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4704     PerlIOBuf * const b = &m->base;
4705     IV code = PerlIOBuf_flush(aTHX_ f);
4706     /*
4707      * Now we are "synced" at PerlIOBuf level
4708      */
4709     if (b->buf) {
4710         if (m->len) {
4711             /*
4712              * Unmap the buffer
4713              */
4714             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4715                 code = -1;
4716         }
4717         else {
4718             /*
4719              * We seem to have a PerlIOBuf buffer which was not mapped
4720              * remember it in case we need one later
4721              */
4722             m->bbuf = b->buf;
4723         }
4724     }
4725     return code;
4726 }
4727
4728 IV
4729 PerlIOMmap_fill(pTHX_ PerlIO *f)
4730 {
4731     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4732     IV code = PerlIO_flush(f);
4733     if (code == 0 && !b->buf) {
4734         code = PerlIOMmap_map(aTHX_ f);
4735     }
4736     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4737         code = PerlIOBuf_fill(aTHX_ f);
4738     }
4739     return code;
4740 }
4741
4742 IV
4743 PerlIOMmap_close(pTHX_ PerlIO *f)
4744 {
4745     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4746     PerlIOBuf * const b = &m->base;
4747     IV code = PerlIO_flush(f);
4748     if (m->bbuf) {
4749         b->buf = m->bbuf;
4750         m->bbuf = NULL;
4751         b->ptr = b->end = b->buf;
4752     }
4753     if (PerlIOBuf_close(aTHX_ f) != 0)
4754         code = -1;
4755     return code;
4756 }
4757
4758 PerlIO *
4759 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4760 {
4761  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4762 }
4763
4764
4765 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4766     sizeof(PerlIO_funcs),
4767     "mmap",
4768     sizeof(PerlIOMmap),
4769     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4770     PerlIOBuf_pushed,
4771     PerlIOBuf_popped,
4772     PerlIOBuf_open,
4773     PerlIOBase_binmode,         /* binmode */
4774     NULL,
4775     PerlIOBase_fileno,
4776     PerlIOMmap_dup,
4777     PerlIOBuf_read,
4778     PerlIOMmap_unread,
4779     PerlIOMmap_write,
4780     PerlIOBuf_seek,
4781     PerlIOBuf_tell,
4782     PerlIOBuf_close,
4783     PerlIOMmap_flush,
4784     PerlIOMmap_fill,
4785     PerlIOBase_eof,
4786     PerlIOBase_error,
4787     PerlIOBase_clearerr,
4788     PerlIOBase_setlinebuf,
4789     PerlIOMmap_get_base,
4790     PerlIOBuf_bufsiz,
4791     PerlIOBuf_get_ptr,
4792     PerlIOBuf_get_cnt,
4793     PerlIOBuf_set_ptrcnt,
4794 };
4795
4796 #endif                          /* HAS_MMAP */
4797
4798 PerlIO *
4799 Perl_PerlIO_stdin(pTHX)
4800 {
4801     dVAR;
4802     if (!PL_perlio) {
4803         PerlIO_stdstreams(aTHX);
4804     }
4805     return &PL_perlio[1];
4806 }
4807
4808 PerlIO *
4809 Perl_PerlIO_stdout(pTHX)
4810 {
4811     dVAR;
4812     if (!PL_perlio) {
4813         PerlIO_stdstreams(aTHX);
4814     }
4815     return &PL_perlio[2];
4816 }
4817
4818 PerlIO *
4819 Perl_PerlIO_stderr(pTHX)
4820 {
4821     dVAR;
4822     if (!PL_perlio) {
4823         PerlIO_stdstreams(aTHX);
4824     }
4825     return &PL_perlio[3];
4826 }
4827
4828 /*--------------------------------------------------------------------------------------*/
4829
4830 char *
4831 PerlIO_getname(PerlIO *f, char *buf)
4832 {
4833     dTHX;
4834 #ifdef VMS
4835     char *name = NULL;
4836     bool exported = FALSE;
4837     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4838     if (!stdio) {
4839         stdio = PerlIO_exportFILE(f,0);
4840         exported = TRUE;
4841     }
4842     if (stdio) {
4843         name = fgetname(stdio, buf);
4844         if (exported) PerlIO_releaseFILE(f,stdio);
4845     }
4846     return name;
4847 #else
4848     PERL_UNUSED_ARG(f);
4849     PERL_UNUSED_ARG(buf);
4850     Perl_croak(aTHX_ "Don't know how to get file name");
4851     return NULL;
4852 #endif
4853 }
4854
4855
4856 /*--------------------------------------------------------------------------------------*/
4857 /*
4858  * Functions which can be called on any kind of PerlIO implemented in
4859  * terms of above
4860  */
4861
4862 #undef PerlIO_fdopen
4863 PerlIO *
4864 PerlIO_fdopen(int fd, const char *mode)
4865 {
4866     dTHX;
4867     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4868 }
4869
4870 #undef PerlIO_open
4871 PerlIO *
4872 PerlIO_open(const char *path, const char *mode)
4873 {
4874     dTHX;
4875     SV *name = sv_2mortal(newSVpv(path, 0));
4876     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4877 }
4878
4879 #undef Perlio_reopen
4880 PerlIO *
4881 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4882 {
4883     dTHX;
4884     SV *name = sv_2mortal(newSVpv(path,0));
4885     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4886 }
4887
4888 #undef PerlIO_getc
4889 int
4890 PerlIO_getc(PerlIO *f)
4891 {
4892     dTHX;
4893     STDCHAR buf[1];
4894     if ( 1 == PerlIO_read(f, buf, 1) ) {
4895         return (unsigned char) buf[0];
4896     }
4897     return EOF;
4898 }
4899
4900 #undef PerlIO_ungetc
4901 int
4902 PerlIO_ungetc(PerlIO *f, int ch)
4903 {
4904     dTHX;
4905     if (ch != EOF) {
4906         STDCHAR buf = ch;
4907         if (PerlIO_unread(f, &buf, 1) == 1)
4908             return ch;
4909     }
4910     return EOF;
4911 }
4912
4913 #undef PerlIO_putc
4914 int
4915 PerlIO_putc(PerlIO *f, int ch)
4916 {
4917     dTHX;
4918     STDCHAR buf = ch;
4919     return PerlIO_write(f, &buf, 1);
4920 }
4921
4922 #undef PerlIO_puts
4923 int
4924 PerlIO_puts(PerlIO *f, const char *s)
4925 {
4926     dTHX;
4927     return PerlIO_write(f, s, strlen(s));
4928 }
4929
4930 #undef PerlIO_rewind
4931 void
4932 PerlIO_rewind(PerlIO *f)
4933 {
4934     dTHX;
4935     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4936     PerlIO_clearerr(f);
4937 }
4938
4939 #undef PerlIO_vprintf
4940 int
4941 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4942 {
4943     dTHX;
4944     SV * const sv = newSVpvs("");
4945     const char *s;
4946     STRLEN len;
4947     SSize_t wrote;
4948 #ifdef NEED_VA_COPY
4949     va_list apc;
4950     Perl_va_copy(ap, apc);
4951     sv_vcatpvf(sv, fmt, &apc);
4952 #else
4953     sv_vcatpvf(sv, fmt, &ap);
4954 #endif
4955     s = SvPV_const(sv, len);
4956     wrote = PerlIO_write(f, s, len);
4957     SvREFCNT_dec(sv);
4958     return wrote;
4959 }
4960
4961 #undef PerlIO_printf
4962 int
4963 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4964 {
4965     va_list ap;
4966     int result;
4967     va_start(ap, fmt);
4968     result = PerlIO_vprintf(f, fmt, ap);
4969     va_end(ap);
4970     return result;
4971 }
4972
4973 #undef PerlIO_stdoutf
4974 int
4975 PerlIO_stdoutf(const char *fmt, ...)
4976 {
4977     dTHX;
4978     va_list ap;
4979     int result;
4980     va_start(ap, fmt);
4981     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4982     va_end(ap);
4983     return result;
4984 }
4985
4986 #undef PerlIO_tmpfile
4987 PerlIO *
4988 PerlIO_tmpfile(void)
4989 {
4990      dTHX;
4991      PerlIO *f = NULL;
4992 #ifdef WIN32
4993      const int fd = win32_tmpfd();
4994      if (fd >= 0)
4995           f = PerlIO_fdopen(fd, "w+b");
4996 #else /* WIN32 */
4997 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4998      SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
4999      /*
5000       * I have no idea how portable mkstemp() is ... NI-S
5001       */
5002      const int fd = mkstemp(SvPVX(sv));
5003      if (fd >= 0) {
5004           f = PerlIO_fdopen(fd, "w+");
5005           if (f)
5006                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5007           PerlLIO_unlink(SvPVX_const(sv));
5008           SvREFCNT_dec(sv);
5009      }
5010 #    else       /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5011      FILE * const stdio = PerlSIO_tmpfile();
5012
5013      if (stdio) {
5014           if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
5015                                PERLIO_FUNCS_CAST(&PerlIO_stdio),
5016                                "w+", NULL))) {
5017                PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
5018
5019                if (s)
5020                     s->stdio = stdio;
5021           }
5022      }
5023 #    endif /* else HAS_MKSTEMP */
5024 #endif /* else WIN32 */
5025      return f;
5026 }
5027
5028 #undef HAS_FSETPOS
5029 #undef HAS_FGETPOS
5030
5031 #endif                          /* USE_SFIO */
5032 #endif                          /* PERLIO_IS_STDIO */
5033
5034 /*======================================================================================*/
5035 /*
5036  * Now some functions in terms of above which may be needed even if we are
5037  * not in true PerlIO mode
5038  */
5039 const char *
5040 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5041 {
5042     dVAR;
5043     const char *type = NULL;
5044     /*
5045      * Need to supply default layer info from open.pm
5046      */
5047     if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) {
5048         SV * const layers
5049             = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
5050                                        "open", 4, 0, 0);
5051         assert(layers);
5052         if (SvOK(layers)) {
5053             STRLEN len;
5054             type = SvPV_const(layers, len);
5055             if (type && mode && mode[0] != 'r') {
5056                 /*
5057                  * Skip to write part, which is separated by a '\0'
5058                  */
5059                 STRLEN read_len = strlen(type);
5060                 if (read_len < len) {
5061                     type += read_len + 1;
5062                 }
5063             }
5064         }
5065     }
5066     return type;
5067 }
5068
5069
5070 #ifndef HAS_FSETPOS
5071 #undef PerlIO_setpos
5072 int
5073 PerlIO_setpos(PerlIO *f, SV *pos)
5074 {
5075     dTHX;
5076     if (SvOK(pos)) {
5077         STRLEN len;
5078         const Off_t * const posn = (Off_t *) SvPV(pos, len);
5079         if (f && len == sizeof(Off_t))
5080             return PerlIO_seek(f, *posn, SEEK_SET);
5081     }
5082     SETERRNO(EINVAL, SS_IVCHAN);
5083     return -1;
5084 }
5085 #else
5086 #undef PerlIO_setpos
5087 int
5088 PerlIO_setpos(PerlIO *f, SV *pos)
5089 {
5090     dTHX;
5091     if (SvOK(pos)) {
5092         STRLEN len;
5093         Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5094         if (f && len == sizeof(Fpos_t)) {
5095 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5096             return fsetpos64(f, fpos);
5097 #else
5098             return fsetpos(f, fpos);
5099 #endif
5100         }
5101     }
5102     SETERRNO(EINVAL, SS_IVCHAN);
5103     return -1;
5104 }
5105 #endif
5106
5107 #ifndef HAS_FGETPOS
5108 #undef PerlIO_getpos
5109 int
5110 PerlIO_getpos(PerlIO *f, SV *pos)
5111 {
5112     dTHX;
5113     Off_t posn = PerlIO_tell(f);
5114     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5115     return (posn == (Off_t) - 1) ? -1 : 0;
5116 }
5117 #else
5118 #undef PerlIO_getpos
5119 int
5120 PerlIO_getpos(PerlIO *f, SV *pos)
5121 {
5122     dTHX;
5123     Fpos_t fpos;
5124     int code;
5125 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5126     code = fgetpos64(f, &fpos);
5127 #else
5128     code = fgetpos(f, &fpos);
5129 #endif
5130     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5131     return code;
5132 }
5133 #endif
5134
5135 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5136
5137 int
5138 vprintf(char *pat, char *args)
5139 {
5140     _doprnt(pat, args, stdout);
5141     return 0;                   /* wrong, but perl doesn't use the return
5142                                  * value */
5143 }
5144
5145 int
5146 vfprintf(FILE *fd, char *pat, char *args)
5147 {
5148     _doprnt(pat, args, fd);
5149     return 0;                   /* wrong, but perl doesn't use the return
5150                                  * value */
5151 }
5152
5153 #endif
5154
5155 #ifndef PerlIO_vsprintf
5156 int
5157 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5158 {
5159     dTHX;
5160     const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5161     PERL_UNUSED_CONTEXT;
5162
5163 #ifndef PERL_MY_VSNPRINTF_GUARDED
5164     if (val < 0 || (n > 0 ? val >= n : 0)) {
5165         Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5166     }
5167 #endif
5168     return val;
5169 }
5170 #endif
5171
5172 #ifndef PerlIO_sprintf
5173 int
5174 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5175 {
5176     va_list ap;
5177     int result;
5178     va_start(ap, fmt);
5179     result = PerlIO_vsprintf(s, n, fmt, ap);
5180     va_end(ap);
5181     return result;
5182 }
5183 #endif
5184
5185 /*
5186  * Local variables:
5187  * c-indentation-style: bsd
5188  * c-basic-offset: 4
5189  * indent-tabs-mode: t
5190  * End:
5191  *
5192  * ex: set ts=8 sts=4 sw=4 noet:
5193  */