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