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