perlio.c

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