perlio.c

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