perlio.c

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