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