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