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     for (;;) {
2865         if (count == 1) {
2866             STDCHAR *buf = (STDCHAR *) vbuf;
2867             /*
2868              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2869              * stdio does not do that for fread()
2870              */
2871             int ch = PerlSIO_fgetc(s);
2872             if (ch != EOF) {
2873                 *buf = ch;
2874                 got = 1;
2875             }
2876         }
2877         else
2878             got = PerlSIO_fread(vbuf, 1, count, s);
2879         if (got || errno != EINTR)
2880             break;
2881         PERL_ASYNC_CHECK();
2882         errno = 0;      /* just in case */
2883     }
2884     return got;
2885 }
2886
2887 SSize_t
2888 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2889 {
2890     SSize_t unread = 0;
2891     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2892
2893 #ifdef STDIO_BUFFER_WRITABLE
2894     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2895         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2896         STDCHAR *base = PerlIO_get_base(f);
2897         SSize_t cnt   = PerlIO_get_cnt(f);
2898         STDCHAR *ptr  = PerlIO_get_ptr(f);
2899         SSize_t avail = ptr - base;
2900         if (avail > 0) {
2901             if (avail > count) {
2902                 avail = count;
2903             }
2904             ptr -= avail;
2905             Move(buf-avail,ptr,avail,STDCHAR);
2906             count -= avail;
2907             unread += avail;
2908             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
2909             if (PerlSIO_feof(s) && unread >= 0)
2910                 PerlSIO_clearerr(s);
2911         }
2912     }
2913     else
2914 #endif
2915     if (PerlIO_has_cntptr(f)) {
2916         /* We can get pointer to buffer but not its base
2917            Do ungetc() but check chars are ending up in the
2918            buffer
2919          */
2920         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
2921         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2922         while (count > 0) {
2923             int ch = *--buf & 0xFF;
2924             if (ungetc(ch,s) != ch) {
2925                 /* ungetc did not work */
2926                 break;
2927             }
2928             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
2929                 /* Did not change pointer as expected */
2930                 fgetc(s);  /* get char back again */
2931                 break;
2932             }
2933             /* It worked ! */
2934             count--;
2935             unread++;
2936         }
2937     }
2938
2939     if (count > 0) {
2940         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
2941     }
2942     return unread;
2943 }
2944
2945 SSize_t
2946 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2947 {
2948     SSize_t got;
2949     for (;;) {
2950         got = PerlSIO_fwrite(vbuf, 1, count,
2951                               PerlIOSelf(f, PerlIOStdio)->stdio);
2952         if (got || errno != EINTR)
2953             break;
2954         PERL_ASYNC_CHECK();
2955         errno = 0;      /* just in case */
2956     }
2957     return got;
2958 }
2959
2960 IV
2961 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2962 {
2963     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2964     return PerlSIO_fseek(stdio, offset, whence);
2965 }
2966
2967 Off_t
2968 PerlIOStdio_tell(pTHX_ PerlIO *f)
2969 {
2970     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2971     return PerlSIO_ftell(stdio);
2972 }
2973
2974 IV
2975 PerlIOStdio_flush(pTHX_ PerlIO *f)
2976 {
2977     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2978     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2979         return PerlSIO_fflush(stdio);
2980     }
2981     else {
2982 #if 0
2983         /*
2984          * FIXME: This discards ungetc() and pre-read stuff which is not
2985          * right if this is just a "sync" from a layer above Suspect right
2986          * design is to do _this_ but not have layer above flush this
2987          * layer read-to-read
2988          */
2989         /*
2990          * Not writeable - sync by attempting a seek
2991          */
2992         int err = errno;
2993         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2994             errno = err;
2995 #endif
2996     }
2997     return 0;
2998 }
2999
3000 IV
3001 PerlIOStdio_eof(pTHX_ PerlIO *f)
3002 {
3003     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3004 }
3005
3006 IV
3007 PerlIOStdio_error(pTHX_ PerlIO *f)
3008 {
3009     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3010 }
3011
3012 void
3013 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3014 {
3015     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3016 }
3017
3018 void
3019 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3020 {
3021 #ifdef HAS_SETLINEBUF
3022     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3023 #else
3024     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
3025 #endif
3026 }
3027
3028 #ifdef FILE_base
3029 STDCHAR *
3030 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3031 {
3032     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3033     return (STDCHAR*)PerlSIO_get_base(stdio);
3034 }
3035
3036 Size_t
3037 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3038 {
3039     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3040     return PerlSIO_get_bufsiz(stdio);
3041 }
3042 #endif
3043
3044 #ifdef USE_STDIO_PTR
3045 STDCHAR *
3046 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3047 {
3048     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3049     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3050 }
3051
3052 SSize_t
3053 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3054 {
3055     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3056     return PerlSIO_get_cnt(stdio);
3057 }
3058
3059 void
3060 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3061 {
3062     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3063     if (ptr != NULL) {
3064 #ifdef STDIO_PTR_LVALUE
3065         PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
3066 #ifdef STDIO_PTR_LVAL_SETS_CNT
3067         if (PerlSIO_get_cnt(stdio) != (cnt)) {
3068             assert(PerlSIO_get_cnt(stdio) == (cnt));
3069         }
3070 #endif
3071 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3072         /*
3073          * Setting ptr _does_ change cnt - we are done
3074          */
3075         return;
3076 #endif
3077 #else                           /* STDIO_PTR_LVALUE */
3078         PerlProc_abort();
3079 #endif                          /* STDIO_PTR_LVALUE */
3080     }
3081     /*
3082      * Now (or only) set cnt
3083      */
3084 #ifdef STDIO_CNT_LVALUE
3085     PerlSIO_set_cnt(stdio, cnt);
3086 #else                           /* STDIO_CNT_LVALUE */
3087 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3088     PerlSIO_set_ptr(stdio,
3089                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3090                                               cnt));
3091 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3092     PerlProc_abort();
3093 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3094 #endif                          /* STDIO_CNT_LVALUE */
3095 }
3096
3097
3098 #endif
3099
3100 IV
3101 PerlIOStdio_fill(pTHX_ PerlIO *f)
3102 {
3103     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3104     int c;
3105     /*
3106      * fflush()ing read-only streams can cause trouble on some stdio-s
3107      */
3108     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3109         if (PerlSIO_fflush(stdio) != 0)
3110             return EOF;
3111     }
3112     c = PerlSIO_fgetc(stdio);
3113     if (c == EOF)
3114         return EOF;
3115
3116 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3117
3118 #ifdef STDIO_BUFFER_WRITABLE
3119     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3120         /* Fake ungetc() to the real buffer in case system's ungetc
3121            goes elsewhere
3122          */
3123         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3124         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3125         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3126         if (ptr == base+1) {
3127             *--ptr = (STDCHAR) c;
3128             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3129             if (PerlSIO_feof(stdio))
3130                 PerlSIO_clearerr(stdio);
3131             return 0;
3132         }
3133     }
3134     else
3135 #endif
3136     if (PerlIO_has_cntptr(f)) {
3137         STDCHAR ch = c;
3138         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3139             return 0;
3140         }
3141     }
3142 #endif
3143
3144 #if defined(VMS)
3145     /* An ungetc()d char is handled separately from the regular
3146      * buffer, so we stuff it in the buffer ourselves.
3147      * Should never get called as should hit code above
3148      */
3149     *(--((*stdio)->_ptr)) = (unsigned char) c;
3150     (*stdio)->_cnt++;
3151 #else
3152     /* If buffer snoop scheme above fails fall back to
3153        using ungetc().
3154      */
3155     if (PerlSIO_ungetc(c, stdio) != c)
3156         return EOF;
3157 #endif
3158     return 0;
3159 }
3160
3161
3162
3163 PerlIO_funcs PerlIO_stdio = {
3164     sizeof(PerlIO_funcs),
3165     "stdio",
3166     sizeof(PerlIOStdio),
3167     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3168     PerlIOStdio_pushed,
3169     PerlIOBase_popped,
3170     PerlIOStdio_open,
3171     PerlIOBase_binmode,         /* binmode */
3172     NULL,
3173     PerlIOStdio_fileno,
3174     PerlIOStdio_dup,
3175     PerlIOStdio_read,
3176     PerlIOStdio_unread,
3177     PerlIOStdio_write,
3178     PerlIOStdio_seek,
3179     PerlIOStdio_tell,
3180     PerlIOStdio_close,
3181     PerlIOStdio_flush,
3182     PerlIOStdio_fill,
3183     PerlIOStdio_eof,
3184     PerlIOStdio_error,
3185     PerlIOStdio_clearerr,
3186     PerlIOStdio_setlinebuf,
3187 #ifdef FILE_base
3188     PerlIOStdio_get_base,
3189     PerlIOStdio_get_bufsiz,
3190 #else
3191     NULL,
3192     NULL,
3193 #endif
3194 #ifdef USE_STDIO_PTR
3195     PerlIOStdio_get_ptr,
3196     PerlIOStdio_get_cnt,
3197 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3198     PerlIOStdio_set_ptrcnt
3199 #else                           /* STDIO_PTR_LVALUE */
3200     NULL
3201 #endif                          /* STDIO_PTR_LVALUE */
3202 #else                           /* USE_STDIO_PTR */
3203     NULL,
3204     NULL,
3205     NULL
3206 #endif                          /* USE_STDIO_PTR */
3207 };
3208
3209 /* Note that calls to PerlIO_exportFILE() are reversed using
3210  * PerlIO_releaseFILE(), not importFILE. */
3211 FILE *
3212 PerlIO_exportFILE(PerlIO * f, const char *mode)
3213 {
3214     dTHX;
3215     FILE *stdio = NULL;
3216     if (PerlIOValid(f)) {
3217         char buf[8];
3218         PerlIO_flush(f);
3219         if (!mode || !*mode) {
3220             mode = PerlIO_modestr(f, buf);
3221         }
3222         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3223         if (stdio) {
3224             PerlIOl *l = *f;
3225             /* De-link any lower layers so new :stdio sticks */
3226             *f = NULL;
3227             if ((f = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) {
3228                 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
3229                 s->stdio = stdio;
3230                 /* Link previous lower layers under new one */
3231                 *PerlIONext(f) = l;
3232             }
3233             else {
3234                 /* restore layers list */
3235                 *f = l;
3236             }
3237         }
3238     }
3239     return stdio;
3240 }
3241
3242
3243 FILE *
3244 PerlIO_findFILE(PerlIO *f)
3245 {
3246     PerlIOl *l = *f;
3247     while (l) {
3248         if (l->tab == &PerlIO_stdio) {
3249             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3250             return s->stdio;
3251         }
3252         l = *PerlIONext(&l);
3253     }
3254     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3255     return PerlIO_exportFILE(f, Nullch);
3256 }
3257
3258 /* Use this to reverse PerlIO_exportFILE calls. */
3259 void
3260 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3261 {
3262     PerlIOl *l;
3263     while ((l = *p)) {
3264         if (l->tab == &PerlIO_stdio) {
3265             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3266             if (s->stdio == f) {
3267                 dTHX;
3268                 PerlIO_pop(aTHX_ p);
3269                 return;
3270             }
3271         }
3272         p = PerlIONext(p);
3273     }
3274     return;
3275 }
3276
3277 /*--------------------------------------------------------------------------------------*/
3278 /*
3279  * perlio buffer layer
3280  */
3281
3282 IV
3283 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3284 {
3285     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3286     int fd = PerlIO_fileno(f);
3287     if (fd >= 0 && PerlLIO_isatty(fd)) {
3288         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3289     }
3290     if (*PerlIONext(f)) {
3291         Off_t posn = PerlIO_tell(PerlIONext(f));
3292         if (posn != (Off_t) - 1) {
3293             b->posn = posn;
3294         }
3295     }
3296     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3297 }
3298
3299 PerlIO *
3300 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3301                IV n, const char *mode, int fd, int imode, int perm,
3302                PerlIO *f, int narg, SV **args)
3303 {
3304     if (PerlIOValid(f)) {
3305         PerlIO *next = PerlIONext(f);
3306         PerlIO_funcs *tab =  PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3307         next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3308                           next, narg, args);
3309         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3310             return NULL;
3311         }
3312     }
3313     else {
3314         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3315         int init = 0;
3316         if (*mode == 'I') {
3317             init = 1;
3318             /*
3319              * mode++;
3320              */
3321         }
3322         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3323                           f, narg, args);
3324         if (f) {
3325             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3326                 /*
3327                  * if push fails during open, open fails. close will pop us.
3328                  */
3329                 PerlIO_close (f);
3330                 return NULL;
3331             } else {
3332                 fd = PerlIO_fileno(f);
3333                 if (init && fd == 2) {
3334                     /*
3335                      * Initial stderr is unbuffered
3336                      */
3337                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3338                 }
3339 #ifdef PERLIO_USING_CRLF
3340 #  ifdef PERLIO_IS_BINMODE_FD
3341                 if (PERLIO_IS_BINMODE_FD(fd))
3342                     PerlIO_binmode(f,  '<'/*not used*/, O_BINARY, Nullch);
3343                 else
3344 #  endif
3345                 /*
3346                  * do something about failing setmode()? --jhi
3347                  */
3348                 PerlLIO_setmode(fd, O_BINARY);
3349 #endif
3350             }
3351         }
3352     }
3353     return f;
3354 }
3355
3356 /*
3357  * This "flush" is akin to sfio's sync in that it handles files in either
3358  * read or write state
3359  */
3360 IV
3361 PerlIOBuf_flush(pTHX_ PerlIO *f)
3362 {
3363     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3364     int code = 0;
3365     PerlIO *n = PerlIONext(f);
3366     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3367         /*
3368          * write() the buffer
3369          */
3370         STDCHAR *buf = b->buf;
3371         STDCHAR *p = buf;
3372         while (p < b->ptr) {
3373             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3374             if (count > 0) {
3375                 p += count;
3376             }
3377             else if (count < 0 || PerlIO_error(n)) {
3378                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3379                 code = -1;
3380                 break;
3381             }
3382         }
3383         b->posn += (p - buf);
3384     }
3385     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3386         STDCHAR *buf = PerlIO_get_base(f);
3387         /*
3388          * Note position change
3389          */
3390         b->posn += (b->ptr - buf);
3391         if (b->ptr < b->end) {
3392             /* We did not consume all of it - try and seek downstream to
3393                our logical position
3394              */
3395             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3396                 /* Reload n as some layers may pop themselves on seek */
3397                 b->posn = PerlIO_tell(n = PerlIONext(f));
3398             }
3399             else {
3400                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3401                    data is lost for good - so return saying "ok" having undone
3402                    the position adjust
3403                  */
3404                 b->posn -= (b->ptr - buf);
3405                 return code;
3406             }
3407         }
3408     }
3409     b->ptr = b->end = b->buf;
3410     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3411     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3412     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3413         code = -1;
3414     return code;
3415 }
3416
3417 IV
3418 PerlIOBuf_fill(pTHX_ PerlIO *f)
3419 {
3420     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3421     PerlIO *n = PerlIONext(f);
3422     SSize_t avail;
3423     /*
3424      * Down-stream flush is defined not to loose read data so is harmless.
3425      * we would not normally be fill'ing if there was data left in anycase.
3426      */
3427     if (PerlIO_flush(f) != 0)
3428         return -1;
3429     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3430         PerlIOBase_flush_linebuf(aTHX);
3431
3432     if (!b->buf)
3433         PerlIO_get_base(f);     /* allocate via vtable */
3434
3435     b->ptr = b->end = b->buf;
3436
3437     if (!PerlIOValid(n)) {
3438         PerlIOBase(f)->flags |= PERLIO_F_EOF;
3439         return -1;
3440     }
3441
3442     if (PerlIO_fast_gets(n)) {
3443         /*
3444          * Layer below is also buffered. We do _NOT_ want to call its
3445          * ->Read() because that will loop till it gets what we asked for
3446          * which may hang on a pipe etc. Instead take anything it has to
3447          * hand, or ask it to fill _once_.
3448          */
3449         avail = PerlIO_get_cnt(n);
3450         if (avail <= 0) {
3451             avail = PerlIO_fill(n);
3452             if (avail == 0)
3453                 avail = PerlIO_get_cnt(n);
3454             else {
3455                 if (!PerlIO_error(n) && PerlIO_eof(n))
3456                     avail = 0;
3457             }
3458         }
3459         if (avail > 0) {
3460             STDCHAR *ptr = PerlIO_get_ptr(n);
3461             SSize_t cnt = avail;
3462             if (avail > (SSize_t)b->bufsiz)
3463                 avail = b->bufsiz;
3464             Copy(ptr, b->buf, avail, STDCHAR);
3465             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3466         }
3467     }
3468     else {
3469         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3470     }
3471     if (avail <= 0) {
3472         if (avail == 0)
3473             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3474         else
3475             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3476         return -1;
3477     }
3478     b->end = b->buf + avail;
3479     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3480     return 0;
3481 }
3482
3483 SSize_t
3484 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3485 {
3486     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3487     if (PerlIOValid(f)) {
3488         if (!b->ptr)
3489             PerlIO_get_base(f);
3490         return PerlIOBase_read(aTHX_ f, vbuf, count);
3491     }
3492     return 0;
3493 }
3494
3495 SSize_t
3496 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3497 {
3498     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3499     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3500     SSize_t unread = 0;
3501     SSize_t avail;
3502     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3503         PerlIO_flush(f);
3504     if (!b->buf)
3505         PerlIO_get_base(f);
3506     if (b->buf) {
3507         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3508             /*
3509              * Buffer is already a read buffer, we can overwrite any chars
3510              * which have been read back to buffer start
3511              */
3512             avail = (b->ptr - b->buf);
3513         }
3514         else {
3515             /*
3516              * Buffer is idle, set it up so whole buffer is available for
3517              * unread
3518              */
3519             avail = b->bufsiz;
3520             b->end = b->buf + avail;
3521             b->ptr = b->end;
3522             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3523             /*
3524              * Buffer extends _back_ from where we are now
3525              */
3526             b->posn -= b->bufsiz;
3527         }
3528         if (avail > (SSize_t) count) {
3529             /*
3530              * If we have space for more than count, just move count
3531              */
3532             avail = count;
3533         }
3534         if (avail > 0) {
3535             b->ptr -= avail;
3536             buf -= avail;
3537             /*
3538              * In simple stdio-like ungetc() case chars will be already
3539              * there
3540              */
3541             if (buf != b->ptr) {
3542                 Copy(buf, b->ptr, avail, STDCHAR);
3543             }
3544             count -= avail;
3545             unread += avail;
3546             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3547         }
3548     }
3549     if (count > 0) {
3550         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3551     }
3552     return unread;
3553 }
3554
3555 SSize_t
3556 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3557 {
3558     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3559     const STDCHAR *buf = (const STDCHAR *) vbuf;
3560     Size_t written = 0;
3561     if (!b->buf)
3562         PerlIO_get_base(f);
3563     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3564         return 0;
3565     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3566         if (PerlIO_flush(f) != 0) {
3567             return 0;
3568         }
3569     }
3570     while (count > 0) {
3571         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3572         if ((SSize_t) count < avail)
3573             avail = count;
3574         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3575         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3576             while (avail > 0) {
3577                 int ch = *buf++;
3578                 *(b->ptr)++ = ch;
3579                 count--;
3580                 avail--;
3581                 written++;
3582                 if (ch == '\n') {
3583                     PerlIO_flush(f);
3584                     break;
3585                 }
3586             }
3587         }
3588         else {
3589             if (avail) {
3590                 Copy(buf, b->ptr, avail, STDCHAR);
3591                 count -= avail;
3592                 buf += avail;
3593                 written += avail;
3594                 b->ptr += avail;
3595             }
3596         }
3597         if (b->ptr >= (b->buf + b->bufsiz))
3598             PerlIO_flush(f);
3599     }
3600     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3601         PerlIO_flush(f);
3602     return written;
3603 }
3604
3605 IV
3606 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3607 {
3608     IV code;
3609     if ((code = PerlIO_flush(f)) == 0) {
3610         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3611         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3612         code = PerlIO_seek(PerlIONext(f), offset, whence);
3613         if (code == 0) {
3614             b->posn = PerlIO_tell(PerlIONext(f));
3615         }
3616     }
3617     return code;
3618 }
3619
3620 Off_t
3621 PerlIOBuf_tell(pTHX_ PerlIO *f)
3622 {
3623     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3624     /*
3625      * b->posn is file position where b->buf was read, or will be written
3626      */
3627     Off_t posn = b->posn;
3628     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
3629         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3630 #if 1
3631         /* As O_APPEND files are normally shared in some sense it is better
3632            to flush :
3633          */
3634         PerlIO_flush(f);
3635 #else
3636         /* when file is NOT shared then this is sufficient */
3637         PerlIO_seek(PerlIONext(f),0, SEEK_END);
3638 #endif
3639         posn = b->posn = PerlIO_tell(PerlIONext(f));
3640     }
3641     if (b->buf) {
3642         /*
3643          * If buffer is valid adjust position by amount in buffer
3644          */
3645         posn += (b->ptr - b->buf);
3646     }
3647     return posn;
3648 }
3649
3650 IV
3651 PerlIOBuf_popped(pTHX_ PerlIO *f)
3652 {
3653     IV code = PerlIOBase_popped(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 IV
3665 PerlIOBuf_close(pTHX_ PerlIO *f)
3666 {
3667     IV code = PerlIOBase_close(aTHX_ f);
3668     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3669     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3670         Safefree(b->buf);
3671     }
3672     b->buf = NULL;
3673     b->ptr = b->end = b->buf;
3674     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3675     return code;
3676 }
3677
3678 STDCHAR *
3679 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3680 {
3681     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3682     if (!b->buf)
3683         PerlIO_get_base(f);
3684     return b->ptr;
3685 }
3686
3687 SSize_t
3688 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3689 {
3690     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3691     if (!b->buf)
3692         PerlIO_get_base(f);
3693     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3694         return (b->end - b->ptr);
3695     return 0;
3696 }
3697
3698 STDCHAR *
3699 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3700 {
3701     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3702     if (!b->buf) {
3703         if (!b->bufsiz)
3704             b->bufsiz = 4096;
3705         b->buf =
3706         Newz('B',b->buf,b->bufsiz, STDCHAR);
3707         if (!b->buf) {
3708             b->buf = (STDCHAR *) & b->oneword;
3709             b->bufsiz = sizeof(b->oneword);
3710         }
3711         b->ptr = b->buf;
3712         b->end = b->ptr;
3713     }
3714     return b->buf;
3715 }
3716
3717 Size_t
3718 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3719 {
3720     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3721     if (!b->buf)
3722         PerlIO_get_base(f);
3723     return (b->end - b->buf);
3724 }
3725
3726 void
3727 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3728 {
3729     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3730     if (!b->buf)
3731         PerlIO_get_base(f);
3732     b->ptr = ptr;
3733     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3734         assert(PerlIO_get_cnt(f) == cnt);
3735         assert(b->ptr >= b->buf);
3736     }
3737     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3738 }
3739
3740 PerlIO *
3741 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3742 {
3743  return PerlIOBase_dup(aTHX_ f, o, param, flags);
3744 }
3745
3746
3747
3748 PerlIO_funcs PerlIO_perlio = {
3749     sizeof(PerlIO_funcs),
3750     "perlio",
3751     sizeof(PerlIOBuf),
3752     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3753     PerlIOBuf_pushed,
3754     PerlIOBuf_popped,
3755     PerlIOBuf_open,
3756     PerlIOBase_binmode,         /* binmode */
3757     NULL,
3758     PerlIOBase_fileno,
3759     PerlIOBuf_dup,
3760     PerlIOBuf_read,
3761     PerlIOBuf_unread,
3762     PerlIOBuf_write,
3763     PerlIOBuf_seek,
3764     PerlIOBuf_tell,
3765     PerlIOBuf_close,
3766     PerlIOBuf_flush,
3767     PerlIOBuf_fill,
3768     PerlIOBase_eof,
3769     PerlIOBase_error,
3770     PerlIOBase_clearerr,
3771     PerlIOBase_setlinebuf,
3772     PerlIOBuf_get_base,
3773     PerlIOBuf_bufsiz,
3774     PerlIOBuf_get_ptr,
3775     PerlIOBuf_get_cnt,
3776     PerlIOBuf_set_ptrcnt,
3777 };
3778
3779 /*--------------------------------------------------------------------------------------*/
3780 /*
3781  * Temp layer to hold unread chars when cannot do it any other way
3782  */
3783
3784 IV
3785 PerlIOPending_fill(pTHX_ PerlIO *f)
3786 {
3787     /*
3788      * Should never happen
3789      */
3790     PerlIO_flush(f);
3791     return 0;
3792 }
3793
3794 IV
3795 PerlIOPending_close(pTHX_ PerlIO *f)
3796 {
3797     /*
3798      * A tad tricky - flush pops us, then we close new top
3799      */
3800     PerlIO_flush(f);
3801     return PerlIO_close(f);
3802 }
3803
3804 IV
3805 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3806 {
3807     /*
3808      * A tad tricky - flush pops us, then we seek new top
3809      */
3810     PerlIO_flush(f);
3811     return PerlIO_seek(f, offset, whence);
3812 }
3813
3814
3815 IV
3816 PerlIOPending_flush(pTHX_ PerlIO *f)
3817 {
3818     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3819     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3820         Safefree(b->buf);
3821         b->buf = NULL;
3822     }
3823     PerlIO_pop(aTHX_ f);
3824     return 0;
3825 }
3826
3827 void
3828 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3829 {
3830     if (cnt <= 0) {
3831         PerlIO_flush(f);
3832     }
3833     else {
3834         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3835     }
3836 }
3837
3838 IV
3839 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3840 {
3841     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3842     PerlIOl *l = PerlIOBase(f);
3843     /*
3844      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3845      * etc. get muddled when it changes mid-string when we auto-pop.
3846      */
3847     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3848         (PerlIOBase(PerlIONext(f))->
3849          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3850     return code;
3851 }
3852
3853 SSize_t
3854 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3855 {
3856     SSize_t avail = PerlIO_get_cnt(f);
3857     SSize_t got = 0;
3858     if ((SSize_t)count < avail)
3859         avail = count;
3860     if (avail > 0)
3861         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3862     if (got >= 0 && got < (SSize_t)count) {
3863         SSize_t more =
3864             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3865         if (more >= 0 || got == 0)
3866             got += more;
3867     }
3868     return got;
3869 }
3870
3871 PerlIO_funcs PerlIO_pending = {
3872     sizeof(PerlIO_funcs),
3873     "pending",
3874     sizeof(PerlIOBuf),
3875     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
3876     PerlIOPending_pushed,
3877     PerlIOBuf_popped,
3878     NULL,
3879     PerlIOBase_binmode,         /* binmode */
3880     NULL,
3881     PerlIOBase_fileno,
3882     PerlIOBuf_dup,
3883     PerlIOPending_read,
3884     PerlIOBuf_unread,
3885     PerlIOBuf_write,
3886     PerlIOPending_seek,
3887     PerlIOBuf_tell,
3888     PerlIOPending_close,
3889     PerlIOPending_flush,
3890     PerlIOPending_fill,
3891     PerlIOBase_eof,
3892     PerlIOBase_error,
3893     PerlIOBase_clearerr,
3894     PerlIOBase_setlinebuf,
3895     PerlIOBuf_get_base,
3896     PerlIOBuf_bufsiz,
3897     PerlIOBuf_get_ptr,
3898     PerlIOBuf_get_cnt,
3899     PerlIOPending_set_ptrcnt,
3900 };
3901
3902
3903
3904 /*--------------------------------------------------------------------------------------*/
3905 /*
3906  * crlf - translation On read translate CR,LF to "\n" we do this by
3907  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3908  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3909  */
3910
3911 typedef struct {
3912     PerlIOBuf base;             /* PerlIOBuf stuff */
3913     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3914                                  * buffer */
3915 } PerlIOCrlf;
3916
3917 IV
3918 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3919 {
3920     IV code;
3921     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3922     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
3923 #if 0
3924     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3925                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3926                  PerlIOBase(f)->flags);
3927 #endif
3928     return code;
3929 }
3930
3931
3932 SSize_t
3933 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3934 {
3935     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3936     if (c->nl) {
3937         *(c->nl) = 0xd;
3938         c->nl = NULL;
3939     }
3940     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3941         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3942     else {
3943         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3944         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3945         SSize_t unread = 0;
3946         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3947             PerlIO_flush(f);
3948         if (!b->buf)
3949             PerlIO_get_base(f);
3950         if (b->buf) {
3951             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3952                 b->end = b->ptr = b->buf + b->bufsiz;
3953                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3954                 b->posn -= b->bufsiz;
3955             }
3956             while (count > 0 && b->ptr > b->buf) {
3957                 int ch = *--buf;
3958                 if (ch == '\n') {
3959                     if (b->ptr - 2 >= b->buf) {
3960                         *--(b->ptr) = 0xa;
3961                         *--(b->ptr) = 0xd;
3962                         unread++;
3963                         count--;
3964                     }
3965                     else {
3966                         buf++;
3967                         break;
3968                     }
3969                 }
3970                 else {
3971                     *--(b->ptr) = ch;
3972                     unread++;
3973                     count--;
3974                 }
3975             }
3976         }
3977         return unread;
3978     }
3979 }
3980
3981 SSize_t
3982 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3983 {
3984     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3985     if (!b->buf)
3986         PerlIO_get_base(f);
3987     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3988         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3989         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3990             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3991           scan:
3992             while (nl < b->end && *nl != 0xd)
3993                 nl++;
3994             if (nl < b->end && *nl == 0xd) {
3995               test:
3996                 if (nl + 1 < b->end) {
3997                     if (nl[1] == 0xa) {
3998                         *nl = '\n';
3999                         c->nl = nl;
4000                     }
4001                     else {
4002                         /*
4003                          * Not CR,LF but just CR
4004                          */
4005                         nl++;
4006                         goto scan;
4007                     }
4008                 }
4009                 else {
4010                     /*
4011                      * Blast - found CR as last char in buffer
4012                      */
4013
4014                     if (b->ptr < nl) {
4015                         /*
4016                          * They may not care, defer work as long as
4017                          * possible
4018                          */
4019                         c->nl = nl;
4020                         return (nl - b->ptr);
4021                     }
4022                     else {
4023                         int code;
4024                         b->ptr++;       /* say we have read it as far as
4025                                          * flush() is concerned */
4026                         b->buf++;       /* Leave space in front of buffer */
4027                         /* Note as we have moved buf up flush's
4028                            posn += ptr-buf
4029                            will naturally make posn point at CR
4030                          */
4031                         b->bufsiz--;    /* Buffer is thus smaller */
4032                         code = PerlIO_fill(f);  /* Fetch some more */
4033                         b->bufsiz++;    /* Restore size for next time */
4034                         b->buf--;       /* Point at space */
4035                         b->ptr = nl = b->buf;   /* Which is what we hand
4036                                                  * off */
4037                         *nl = 0xd;      /* Fill in the CR */
4038                         if (code == 0)
4039                             goto test;  /* fill() call worked */
4040                         /*
4041                          * CR at EOF - just fall through
4042                          */
4043                         /* Should we clear EOF though ??? */
4044                     }
4045                 }
4046             }
4047         }
4048         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4049     }
4050     return 0;
4051 }
4052
4053 void
4054 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4055 {
4056     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4057     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4058     if (!b->buf)
4059         PerlIO_get_base(f);
4060     if (!ptr) {
4061         if (c->nl) {
4062             ptr = c->nl + 1;
4063             if (ptr == b->end && *c->nl == 0xd) {
4064                 /* Defered CR at end of buffer case - we lied about count */
4065                 ptr--;
4066             }
4067         }
4068         else {
4069             ptr = b->end;
4070         }
4071         ptr -= cnt;
4072     }
4073     else {
4074 #if 0
4075         /*
4076          * Test code - delete when it works ...
4077          */
4078         IV flags = PerlIOBase(f)->flags;
4079         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4080         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4081           /* Defered CR at end of buffer case - we lied about count */
4082           chk--;
4083         }
4084         chk -= cnt;
4085
4086         if (ptr != chk ) {
4087             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4088                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
4089                        b->end, cnt);
4090         }
4091 #endif
4092     }
4093     if (c->nl) {
4094         if (ptr > c->nl) {
4095             /*
4096              * They have taken what we lied about
4097              */
4098             *(c->nl) = 0xd;
4099             c->nl = NULL;
4100             ptr++;
4101         }
4102     }
4103     b->ptr = ptr;
4104     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4105 }
4106
4107 SSize_t
4108 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4109 {
4110     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4111         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4112     else {
4113         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4114         const STDCHAR *buf = (const STDCHAR *) vbuf;
4115         const STDCHAR *ebuf = buf + count;
4116         if (!b->buf)
4117             PerlIO_get_base(f);
4118         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4119             return 0;
4120         while (buf < ebuf) {
4121             STDCHAR *eptr = b->buf + b->bufsiz;
4122             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4123             while (buf < ebuf && b->ptr < eptr) {
4124                 if (*buf == '\n') {
4125                     if ((b->ptr + 2) > eptr) {
4126                         /*
4127                          * Not room for both
4128                          */
4129                         PerlIO_flush(f);
4130                         break;
4131                     }
4132                     else {
4133                         *(b->ptr)++ = 0xd;      /* CR */
4134                         *(b->ptr)++ = 0xa;      /* LF */
4135                         buf++;
4136                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4137                             PerlIO_flush(f);
4138                             break;
4139                         }
4140                     }
4141                 }
4142                 else {
4143                     int ch = *buf++;
4144                     *(b->ptr)++ = ch;
4145                 }
4146                 if (b->ptr >= eptr) {
4147                     PerlIO_flush(f);
4148                     break;
4149                 }
4150             }
4151         }
4152         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4153             PerlIO_flush(f);
4154         return (buf - (STDCHAR *) vbuf);
4155     }
4156 }
4157
4158 IV
4159 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4160 {
4161     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4162     if (c->nl) {
4163         *(c->nl) = 0xd;
4164         c->nl = NULL;
4165     }
4166     return PerlIOBuf_flush(aTHX_ f);
4167 }
4168
4169 IV
4170 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4171 {
4172     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4173         /* In text mode - flush any pending stuff and flip it */
4174         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4175 #ifndef PERLIO_USING_CRLF
4176         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4177         if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4178                 PerlIO_pop(aTHX_ f);
4179         }
4180 #endif
4181     }
4182     return 0;
4183 }
4184
4185 PerlIO_funcs PerlIO_crlf = {
4186     sizeof(PerlIO_funcs),
4187     "crlf",
4188     sizeof(PerlIOCrlf),
4189     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4190     PerlIOCrlf_pushed,
4191     PerlIOBuf_popped,         /* popped */
4192     PerlIOBuf_open,
4193     PerlIOCrlf_binmode,       /* binmode */
4194     NULL,
4195     PerlIOBase_fileno,
4196     PerlIOBuf_dup,
4197     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
4198                                  * ... */
4199     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4200     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4201     PerlIOBuf_seek,
4202     PerlIOBuf_tell,
4203     PerlIOBuf_close,
4204     PerlIOCrlf_flush,
4205     PerlIOBuf_fill,
4206     PerlIOBase_eof,
4207     PerlIOBase_error,
4208     PerlIOBase_clearerr,
4209     PerlIOBase_setlinebuf,
4210     PerlIOBuf_get_base,
4211     PerlIOBuf_bufsiz,
4212     PerlIOBuf_get_ptr,
4213     PerlIOCrlf_get_cnt,
4214     PerlIOCrlf_set_ptrcnt,
4215 };
4216
4217 #ifdef HAS_MMAP
4218 /*--------------------------------------------------------------------------------------*/
4219 /*
4220  * mmap as "buffer" layer
4221  */
4222
4223 typedef struct {
4224     PerlIOBuf base;             /* PerlIOBuf stuff */
4225     Mmap_t mptr;                /* Mapped address */
4226     Size_t len;                 /* mapped length */
4227     STDCHAR *bbuf;              /* malloced buffer if map fails */
4228 } PerlIOMmap;
4229
4230 static size_t page_size = 0;
4231
4232 IV
4233 PerlIOMmap_map(pTHX_ PerlIO *f)
4234 {
4235     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4236     IV flags = PerlIOBase(f)->flags;
4237     IV code = 0;
4238     if (m->len)
4239         abort();
4240     if (flags & PERLIO_F_CANREAD) {
4241         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4242         int fd = PerlIO_fileno(f);
4243         Stat_t st;
4244         code = Fstat(fd, &st);
4245         if (code == 0 && S_ISREG(st.st_mode)) {
4246             SSize_t len = st.st_size - b->posn;
4247             if (len > 0) {
4248                 Off_t posn;
4249                 if (!page_size) {
4250 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
4251                     {
4252                         SETERRNO(0, SS_NORMAL);
4253 #   ifdef _SC_PAGESIZE
4254                         page_size = sysconf(_SC_PAGESIZE);
4255 #   else
4256                         page_size = sysconf(_SC_PAGE_SIZE);
4257 #   endif
4258                         if ((long) page_size < 0) {
4259                             if (errno) {
4260                                 SV *error = ERRSV;
4261                                 char *msg;
4262                                 STRLEN n_a;
4263                                 (void) SvUPGRADE(error, SVt_PV);
4264                                 msg = SvPVx(error, n_a);
4265                                 Perl_croak(aTHX_ "panic: sysconf: %s",
4266                                            msg);
4267                             }
4268                             else
4269                                 Perl_croak(aTHX_
4270                                            "panic: sysconf: pagesize unknown");
4271                         }
4272                     }
4273 #else
4274 #   ifdef HAS_GETPAGESIZE
4275                     page_size = getpagesize();
4276 #   else
4277 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
4278                     page_size = PAGESIZE;       /* compiletime, bad */
4279 #       endif
4280 #   endif
4281 #endif
4282                     if ((IV) page_size <= 0)
4283                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4284                                    (IV) page_size);
4285                 }
4286                 if (b->posn < 0) {
4287                     /*
4288                      * This is a hack - should never happen - open should
4289                      * have set it !
4290                      */
4291                     b->posn = PerlIO_tell(PerlIONext(f));
4292                 }
4293                 posn = (b->posn / page_size) * page_size;
4294                 len = st.st_size - posn;
4295                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4296                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4297 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4298                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4299 #endif
4300 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4301                     madvise(m->mptr, len, MADV_WILLNEED);
4302 #endif
4303                     PerlIOBase(f)->flags =
4304                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4305                     b->end = ((STDCHAR *) m->mptr) + len;
4306                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4307                     b->ptr = b->buf;
4308                     m->len = len;
4309                 }
4310                 else {
4311                     b->buf = NULL;
4312                 }
4313             }
4314             else {
4315                 PerlIOBase(f)->flags =
4316                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4317                 b->buf = NULL;
4318                 b->ptr = b->end = b->ptr;
4319                 code = -1;
4320             }
4321         }
4322     }
4323     return code;
4324 }
4325
4326 IV
4327 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4328 {
4329     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4330     PerlIOBuf *b = &m->base;
4331     IV code = 0;
4332     if (m->len) {
4333         if (b->buf) {
4334             code = munmap(m->mptr, m->len);
4335             b->buf = NULL;
4336             m->len = 0;
4337             m->mptr = NULL;
4338             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4339                 code = -1;
4340         }
4341         b->ptr = b->end = b->buf;
4342         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4343     }
4344     return code;
4345 }
4346
4347 STDCHAR *
4348 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4349 {
4350     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4351     PerlIOBuf *b = &m->base;
4352     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4353         /*
4354          * Already have a readbuffer in progress
4355          */
4356         return b->buf;
4357     }
4358     if (b->buf) {
4359         /*
4360          * We have a write buffer or flushed PerlIOBuf read buffer
4361          */
4362         m->bbuf = b->buf;       /* save it in case we need it again */
4363         b->buf = NULL;          /* Clear to trigger below */
4364     }
4365     if (!b->buf) {
4366         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
4367         if (!b->buf) {
4368             /*
4369              * Map did not work - recover PerlIOBuf buffer if we have one
4370              */
4371             b->buf = m->bbuf;
4372         }
4373     }
4374     b->ptr = b->end = b->buf;
4375     if (b->buf)
4376         return b->buf;
4377     return PerlIOBuf_get_base(aTHX_ f);
4378 }
4379
4380 SSize_t
4381 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4382 {
4383     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4384     PerlIOBuf *b = &m->base;
4385     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4386         PerlIO_flush(f);
4387     if (b->ptr && (b->ptr - count) >= b->buf
4388         && memEQ(b->ptr - count, vbuf, count)) {
4389         b->ptr -= count;
4390         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4391         return count;
4392     }
4393     if (m->len) {
4394         /*
4395          * Loose the unwritable mapped buffer
4396          */
4397         PerlIO_flush(f);
4398         /*
4399          * If flush took the "buffer" see if we have one from before
4400          */
4401         if (!b->buf && m->bbuf)
4402             b->buf = m->bbuf;
4403         if (!b->buf) {
4404             PerlIOBuf_get_base(aTHX_ f);
4405             m->bbuf = b->buf;
4406         }
4407     }
4408     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4409 }
4410
4411 SSize_t
4412 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4413 {
4414     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4415     PerlIOBuf *b = &m->base;
4416     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4417         /*
4418          * No, or wrong sort of, buffer
4419          */
4420         if (m->len) {
4421             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4422                 return 0;
4423         }
4424         /*
4425          * If unmap took the "buffer" see if we have one from before
4426          */
4427         if (!b->buf && m->bbuf)
4428             b->buf = m->bbuf;
4429         if (!b->buf) {
4430             PerlIOBuf_get_base(aTHX_ f);
4431             m->bbuf = b->buf;
4432         }
4433     }
4434     return PerlIOBuf_write(aTHX_ f, vbuf, count);
4435 }
4436
4437 IV
4438 PerlIOMmap_flush(pTHX_ PerlIO *f)
4439 {
4440     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4441     PerlIOBuf *b = &m->base;
4442     IV code = PerlIOBuf_flush(aTHX_ f);
4443     /*
4444      * Now we are "synced" at PerlIOBuf level
4445      */
4446     if (b->buf) {
4447         if (m->len) {
4448             /*
4449              * Unmap the buffer
4450              */
4451             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4452                 code = -1;
4453         }
4454         else {
4455             /*
4456              * We seem to have a PerlIOBuf buffer which was not mapped
4457              * remember it in case we need one later
4458              */
4459             m->bbuf = b->buf;
4460         }
4461     }
4462     return code;
4463 }
4464
4465 IV
4466 PerlIOMmap_fill(pTHX_ PerlIO *f)
4467 {
4468     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4469     IV code = PerlIO_flush(f);
4470     if (code == 0 && !b->buf) {
4471         code = PerlIOMmap_map(aTHX_ f);
4472     }
4473     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4474         code = PerlIOBuf_fill(aTHX_ f);
4475     }
4476     return code;
4477 }
4478
4479 IV
4480 PerlIOMmap_close(pTHX_ PerlIO *f)
4481 {
4482     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4483     PerlIOBuf *b = &m->base;
4484     IV code = PerlIO_flush(f);
4485     if (m->bbuf) {
4486         b->buf = m->bbuf;
4487         m->bbuf = NULL;
4488         b->ptr = b->end = b->buf;
4489     }
4490     if (PerlIOBuf_close(aTHX_ f) != 0)
4491         code = -1;
4492     return code;
4493 }
4494
4495 PerlIO *
4496 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4497 {
4498  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4499 }
4500
4501
4502 PerlIO_funcs PerlIO_mmap = {
4503     sizeof(PerlIO_funcs),
4504     "mmap",
4505     sizeof(PerlIOMmap),
4506     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4507     PerlIOBuf_pushed,
4508     PerlIOBuf_popped,
4509     PerlIOBuf_open,
4510     PerlIOBase_binmode,         /* binmode */
4511     NULL,
4512     PerlIOBase_fileno,
4513     PerlIOMmap_dup,
4514     PerlIOBuf_read,
4515     PerlIOMmap_unread,
4516     PerlIOMmap_write,
4517     PerlIOBuf_seek,
4518     PerlIOBuf_tell,
4519     PerlIOBuf_close,
4520     PerlIOMmap_flush,
4521     PerlIOMmap_fill,
4522     PerlIOBase_eof,
4523     PerlIOBase_error,
4524     PerlIOBase_clearerr,
4525     PerlIOBase_setlinebuf,
4526     PerlIOMmap_get_base,
4527     PerlIOBuf_bufsiz,
4528     PerlIOBuf_get_ptr,
4529     PerlIOBuf_get_cnt,
4530     PerlIOBuf_set_ptrcnt,
4531 };
4532
4533 #endif                          /* HAS_MMAP */
4534
4535 PerlIO *
4536 Perl_PerlIO_stdin(pTHX)
4537 {
4538     if (!PL_perlio) {
4539         PerlIO_stdstreams(aTHX);
4540     }
4541     return &PL_perlio[1];
4542 }
4543
4544 PerlIO *
4545 Perl_PerlIO_stdout(pTHX)
4546 {
4547     if (!PL_perlio) {
4548         PerlIO_stdstreams(aTHX);
4549     }
4550     return &PL_perlio[2];
4551 }
4552
4553 PerlIO *
4554 Perl_PerlIO_stderr(pTHX)
4555 {
4556     if (!PL_perlio) {
4557         PerlIO_stdstreams(aTHX);
4558     }
4559     return &PL_perlio[3];
4560 }
4561
4562 /*--------------------------------------------------------------------------------------*/
4563
4564 char *
4565 PerlIO_getname(PerlIO *f, char *buf)
4566 {
4567     dTHX;
4568     char *name = NULL;
4569 #ifdef VMS
4570     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4571     if (stdio)
4572         name = fgetname(stdio, buf);
4573 #else
4574     Perl_croak(aTHX_ "Don't know how to get file name");
4575 #endif
4576     return name;
4577 }
4578
4579
4580 /*--------------------------------------------------------------------------------------*/
4581 /*
4582  * Functions which can be called on any kind of PerlIO implemented in
4583  * terms of above
4584  */
4585
4586 #undef PerlIO_fdopen
4587 PerlIO *
4588 PerlIO_fdopen(int fd, const char *mode)
4589 {
4590     dTHX;
4591     return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4592 }
4593
4594 #undef PerlIO_open
4595 PerlIO *
4596 PerlIO_open(const char *path, const char *mode)
4597 {
4598     dTHX;
4599     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4600     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4601 }
4602
4603 #undef Perlio_reopen
4604 PerlIO *
4605 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4606 {
4607     dTHX;
4608     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4609     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4610 }
4611
4612 #undef PerlIO_getc
4613 int
4614 PerlIO_getc(PerlIO *f)
4615 {
4616     dTHX;
4617     STDCHAR buf[1];
4618     SSize_t count = PerlIO_read(f, buf, 1);
4619     if (count == 1) {
4620         return (unsigned char) buf[0];
4621     }
4622     return EOF;
4623 }
4624
4625 #undef PerlIO_ungetc
4626 int
4627 PerlIO_ungetc(PerlIO *f, int ch)
4628 {
4629     dTHX;
4630     if (ch != EOF) {
4631         STDCHAR buf = ch;
4632         if (PerlIO_unread(f, &buf, 1) == 1)
4633             return ch;
4634     }
4635     return EOF;
4636 }
4637
4638 #undef PerlIO_putc
4639 int
4640 PerlIO_putc(PerlIO *f, int ch)
4641 {
4642     dTHX;
4643     STDCHAR buf = ch;
4644     return PerlIO_write(f, &buf, 1);
4645 }
4646
4647 #undef PerlIO_puts
4648 int
4649 PerlIO_puts(PerlIO *f, const char *s)
4650 {
4651     dTHX;
4652     STRLEN len = strlen(s);
4653     return PerlIO_write(f, s, len);
4654 }
4655
4656 #undef PerlIO_rewind
4657 void
4658 PerlIO_rewind(PerlIO *f)
4659 {
4660     dTHX;
4661     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4662     PerlIO_clearerr(f);
4663 }
4664
4665 #undef PerlIO_vprintf
4666 int
4667 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4668 {
4669     dTHX;
4670     SV *sv = newSVpvn("", 0);
4671     char *s;
4672     STRLEN len;
4673     SSize_t wrote;
4674 #ifdef NEED_VA_COPY
4675     va_list apc;
4676     Perl_va_copy(ap, apc);
4677     sv_vcatpvf(sv, fmt, &apc);
4678 #else
4679     sv_vcatpvf(sv, fmt, &ap);
4680 #endif
4681     s = SvPV(sv, len);
4682     wrote = PerlIO_write(f, s, len);
4683     SvREFCNT_dec(sv);
4684     return wrote;
4685 }
4686
4687 #undef PerlIO_printf
4688 int
4689 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4690 {
4691     va_list ap;
4692     int result;
4693     va_start(ap, fmt);
4694     result = PerlIO_vprintf(f, fmt, ap);
4695     va_end(ap);
4696     return result;
4697 }
4698
4699 #undef PerlIO_stdoutf
4700 int
4701 PerlIO_stdoutf(const char *fmt, ...)
4702 {
4703     dTHX;
4704     va_list ap;
4705     int result;
4706     va_start(ap, fmt);
4707     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4708     va_end(ap);
4709     return result;
4710 }
4711
4712 #undef PerlIO_tmpfile
4713 PerlIO *
4714 PerlIO_tmpfile(void)
4715 {
4716     /*
4717      * I have no idea how portable mkstemp() is ...
4718      */
4719 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4720     dTHX;
4721     PerlIO *f = NULL;
4722     FILE *stdio = PerlSIO_tmpfile();
4723     if (stdio) {
4724         if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), &PerlIO_stdio, "w+", Nullsv))) {
4725             PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
4726             s->stdio = stdio;
4727         }
4728     }
4729     return f;
4730 #else
4731     dTHX;
4732     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4733     int fd = mkstemp(SvPVX(sv));
4734     PerlIO *f = NULL;
4735     if (fd >= 0) {
4736         f = PerlIO_fdopen(fd, "w+");
4737         if (f) {
4738             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4739         }
4740         PerlLIO_unlink(SvPVX(sv));
4741         SvREFCNT_dec(sv);
4742     }
4743     return f;
4744 #endif
4745 }
4746
4747 #undef HAS_FSETPOS
4748 #undef HAS_FGETPOS
4749
4750 #endif                          /* USE_SFIO */
4751 #endif                          /* PERLIO_IS_STDIO */
4752
4753 /*======================================================================================*/
4754 /*
4755  * Now some functions in terms of above which may be needed even if we are
4756  * not in true PerlIO mode
4757  */
4758
4759 #ifndef HAS_FSETPOS
4760 #undef PerlIO_setpos
4761 int
4762 PerlIO_setpos(PerlIO *f, SV *pos)
4763 {
4764     dTHX;
4765     if (SvOK(pos)) {
4766         STRLEN len;
4767         Off_t *posn = (Off_t *) SvPV(pos, len);
4768         if (f && len == sizeof(Off_t))
4769             return PerlIO_seek(f, *posn, SEEK_SET);
4770     }
4771     SETERRNO(EINVAL, SS_IVCHAN);
4772     return -1;
4773 }
4774 #else
4775 #undef PerlIO_setpos
4776 int
4777 PerlIO_setpos(PerlIO *f, SV *pos)
4778 {
4779     dTHX;
4780     if (SvOK(pos)) {
4781         STRLEN len;
4782         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4783         if (f && len == sizeof(Fpos_t)) {
4784 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4785             return fsetpos64(f, fpos);
4786 #else
4787             return fsetpos(f, fpos);
4788 #endif
4789         }
4790     }
4791     SETERRNO(EINVAL, SS_IVCHAN);
4792     return -1;
4793 }
4794 #endif
4795
4796 #ifndef HAS_FGETPOS
4797 #undef PerlIO_getpos
4798 int
4799 PerlIO_getpos(PerlIO *f, SV *pos)
4800 {
4801     dTHX;
4802     Off_t posn = PerlIO_tell(f);
4803     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4804     return (posn == (Off_t) - 1) ? -1 : 0;
4805 }
4806 #else
4807 #undef PerlIO_getpos
4808 int
4809 PerlIO_getpos(PerlIO *f, SV *pos)
4810 {
4811     dTHX;
4812     Fpos_t fpos;
4813     int code;
4814 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4815     code = fgetpos64(f, &fpos);
4816 #else
4817     code = fgetpos(f, &fpos);
4818 #endif
4819     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4820     return code;
4821 }
4822 #endif
4823
4824 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4825
4826 int
4827 vprintf(char *pat, char *args)
4828 {
4829     _doprnt(pat, args, stdout);
4830     return 0;                   /* wrong, but perl doesn't use the return
4831                                  * value */
4832 }
4833
4834 int
4835 vfprintf(FILE *fd, char *pat, char *args)
4836 {
4837     _doprnt(pat, args, fd);
4838     return 0;                   /* wrong, but perl doesn't use the return
4839                                  * value */
4840 }
4841
4842 #endif
4843
4844 #ifndef PerlIO_vsprintf
4845 int
4846 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4847 {
4848     int val = vsprintf(s, fmt, ap);
4849     if (n >= 0) {
4850         if (strlen(s) >= (STRLEN) n) {
4851             dTHX;
4852             (void) PerlIO_puts(Perl_error_log,
4853                                "panic: sprintf overflow - memory corrupted!\n");
4854             my_exit(1);
4855         }
4856     }
4857     return val;
4858 }
4859 #endif
4860
4861 #ifndef PerlIO_sprintf
4862 int
4863 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4864 {
4865     va_list ap;
4866     int result;
4867     va_start(ap, fmt);
4868     result = PerlIO_vsprintf(s, n, fmt, ap);
4869     va_end(ap);
4870     return result;
4871 }
4872 #endif
4873
4874
4875
4876
4877
4878
4879
4880