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)
 978 {
 979     if (f && *f) {
 980         char buf[8];
 981         int fd = PerlLIO_dup(PerlIO_fileno(f));
 982         PerlIO *new = PerlIO_fdopen(fd, PerlIO_modestr(f, buf));
 983         if (new) {
 984             Off_t posn = PerlIO_tell(f);
 985             PerlIO_seek(new, posn, SEEK_SET);
 986         }
 987         return new;
 988     }
 989     else {
 990         SETERRNO(EBADF, SS$_IVCHAN);
 991         return NULL;
 992     }
 993 }
 994
 995 #undef PerlIO_close
 996 int
 997 PerlIO_close(PerlIO *f)
 998 {
 999     dTHX;
1000     int code = -1;
1001     if (f && *f) {
1002         code = (*PerlIOBase(f)->tab->Close) (f);
1003         while (*f) {
1004             PerlIO_pop(aTHX_ f);
1005         }
1006     }
1007     return code;
1008 }
1009
1010 #undef PerlIO_fileno
1011 int
1012 PerlIO_fileno(PerlIO *f)
1013 {
1014     if (f && *f)
1015         return (*PerlIOBase(f)->tab->Fileno) (f);
1016     else {
1017         SETERRNO(EBADF, SS$_IVCHAN);
1018         return -1;
1019     }
1020 }
1021
1022 static const char *
1023 PerlIO_context_layers(pTHX_ const char *mode)
1024 {
1025     const char *type = NULL;
1026     /*
1027      * Need to supply default layer info from open.pm
1028      */
1029     if (PL_curcop) {
1030         SV *layers = PL_curcop->cop_io;
1031         if (layers) {
1032             STRLEN len;
1033             type = SvPV(layers, len);
1034             if (type && mode[0] != 'r') {
1035                 /*
1036                  * Skip to write part
1037                  */
1038                 const char *s = strchr(type, 0);
1039                 if (s && (s - type) < len) {
1040                     type = s + 1;
1041                 }
1042             }
1043         }
1044     }
1045     return type;
1046 }
1047
1048 static PerlIO_funcs *
1049 PerlIO_layer_from_ref(pTHX_ SV *sv)
1050 {
1051     /*
1052      * For any scalar type load the handler which is bundled with perl
1053      */
1054     if (SvTYPE(sv) < SVt_PVAV)
1055         return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1056
1057     /*
1058      * For other types allow if layer is known but don't try and load it
1059      */
1060     switch (SvTYPE(sv)) {
1061     case SVt_PVAV:
1062         return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1063     case SVt_PVHV:
1064         return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1065     case SVt_PVCV:
1066         return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1067     case SVt_PVGV:
1068         return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1069     }
1070     return NULL;
1071 }
1072
1073 PerlIO_list_t *
1074 PerlIO_resolve_layers(pTHX_ const char *layers,
1075                       const char *mode, int narg, SV **args)
1076 {
1077     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1078     int incdef = 1;
1079     if (!_perlio)
1080         PerlIO_stdstreams(aTHX);
1081     if (narg) {
1082         SV *arg = *args;
1083         /*
1084          * If it is a reference but not an object see if we have a handler
1085          * for it
1086          */
1087         if (SvROK(arg) && !sv_isobject(arg)) {
1088             PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1089             if (handler) {
1090                 def = PerlIO_list_alloc();
1091                 PerlIO_list_push(def, handler, &PL_sv_undef);
1092                 incdef = 0;
1093             }
1094             /*
1095              * Don't fail if handler cannot be found :Via(...) etc. may do
1096              * something sensible else we will just stringfy and open
1097              * resulting string.
1098              */
1099         }
1100     }
1101     if (!layers)
1102         layers = PerlIO_context_layers(aTHX_ mode);
1103     if (layers && *layers) {
1104         PerlIO_list_t *av;
1105         if (incdef) {
1106             IV i = def->cur;
1107             av = PerlIO_list_alloc();
1108             for (i = 0; i < def->cur; i++) {
1109                 PerlIO_list_push(av, def->array[i].funcs,
1110                                  def->array[i].arg);
1111             }
1112         }
1113         else {
1114             av = def;
1115         }
1116         PerlIO_parse_layers(aTHX_ av, layers);
1117         return av;
1118     }
1119     else {
1120         if (incdef)
1121             def->refcnt++;
1122         return def;
1123     }
1124 }
1125
1126 PerlIO *
1127 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1128              int imode, int perm, PerlIO *f, int narg, SV **args)
1129 {
1130     if (!f && narg == 1 && *args == &PL_sv_undef) {
1131         if ((f = PerlIO_tmpfile())) {
1132             if (!layers)
1133                 layers = PerlIO_context_layers(aTHX_ mode);
1134             if (layers && *layers)
1135                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1136         }
1137     }
1138     else {
1139         PerlIO_list_t *layera = NULL;
1140         IV n;
1141         PerlIO_funcs *tab = NULL;
1142         if (f && *f) {
1143             /*
1144              * This is "reopen" - it is not tested as perl does not use it
1145              * yet
1146              */
1147             PerlIOl *l = *f;
1148             layera = PerlIO_list_alloc();
1149             while (l) {
1150                 SV *arg =
1151                     (l->tab->Getarg) ? (*l->tab->
1152                                         Getarg) (&l) : &PL_sv_undef;
1153                 PerlIO_list_push(layera, l->tab, arg);
1154                 l = *PerlIONext(&l);
1155             }
1156         }
1157         else {
1158             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1159         }
1160         /*
1161          * Start at "top" of layer stack
1162          */
1163         n = layera->cur - 1;
1164         while (n >= 0) {
1165             PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1166             if (t && t->Open) {
1167                 tab = t;
1168                 break;
1169             }
1170             n--;
1171         }
1172         if (tab) {
1173             /*
1174              * Found that layer 'n' can do opens - call it
1175              */
1176             PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1177                          tab->name, layers, mode, fd, imode, perm, f, narg,
1178                          args);
1179             f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1180                               f, narg, args);
1181             if (f) {
1182                 if (n + 1 < layera->cur) {
1183                     /*
1184                      * More layers above the one that we used to open -
1185                      * apply them now
1186                      */
1187                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1)
1188                         != 0) {
1189                         f = NULL;
1190                     }
1191                 }
1192             }
1193         }
1194         PerlIO_list_free(layera);
1195     }
1196     return f;
1197 }
1198
1199
1200 #undef PerlIO_fdopen
1201 PerlIO *
1202 PerlIO_fdopen(int fd, const char *mode)
1203 {
1204     dTHX;
1205     return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
1206 }
1207
1208 #undef PerlIO_open
1209 PerlIO *
1210 PerlIO_open(const char *path, const char *mode)
1211 {
1212     dTHX;
1213     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
1214     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
1215 }
1216
1217 #undef PerlIO_reopen
1218 PerlIO *
1219 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1220 {
1221     dTHX;
1222     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
1223     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
1224 }
1225
1226 #undef PerlIO_read
1227 SSize_t
1228 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1229 {
1230     if (f && *f)
1231         return (*PerlIOBase(f)->tab->Read) (f, vbuf, count);
1232     else {
1233         SETERRNO(EBADF, SS$_IVCHAN);
1234         return -1;
1235     }
1236 }
1237
1238 #undef PerlIO_unread
1239 SSize_t
1240 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1241 {
1242     if (f && *f)
1243         return (*PerlIOBase(f)->tab->Unread) (f, vbuf, count);
1244     else {
1245         SETERRNO(EBADF, SS$_IVCHAN);
1246         return -1;
1247     }
1248 }
1249
1250 #undef PerlIO_write
1251 SSize_t
1252 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1253 {
1254     if (f && *f)
1255         return (*PerlIOBase(f)->tab->Write) (f, vbuf, count);
1256     else {
1257         SETERRNO(EBADF, SS$_IVCHAN);
1258         return -1;
1259     }
1260 }
1261
1262 #undef PerlIO_seek
1263 int
1264 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1265 {
1266     if (f && *f)
1267         return (*PerlIOBase(f)->tab->Seek) (f, offset, whence);
1268     else {
1269         SETERRNO(EBADF, SS$_IVCHAN);
1270         return -1;
1271     }
1272 }
1273
1274 #undef PerlIO_tell
1275 Off_t
1276 PerlIO_tell(PerlIO *f)
1277 {
1278     if (f && *f)
1279         return (*PerlIOBase(f)->tab->Tell) (f);
1280     else {
1281         SETERRNO(EBADF, SS$_IVCHAN);
1282         return -1;
1283     }
1284 }
1285
1286 #undef PerlIO_flush
1287 int
1288 PerlIO_flush(PerlIO *f)
1289 {
1290     if (f) {
1291         if (*f) {
1292             PerlIO_funcs *tab = PerlIOBase(f)->tab;
1293             if (tab && tab->Flush) {
1294                 return (*tab->Flush) (f);
1295             }
1296             else {
1297                 PerlIO_debug("Cannot flush f=%p :%s\n", f, tab->name);
1298                 SETERRNO(EBADF, SS$_IVCHAN);
1299                 return -1;
1300             }
1301         }
1302         else {
1303             PerlIO_debug("Cannot flush f=%p\n", f);
1304             SETERRNO(EBADF, SS$_IVCHAN);
1305             return -1;
1306         }
1307     }
1308     else {
1309         /*
1310          * Is it good API design to do flush-all on NULL, a potentially
1311          * errorneous input? Maybe some magical value (PerlIO*
1312          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1313          * things on fflush(NULL), but should we be bound by their design
1314          * decisions? --jhi
1315          */
1316         PerlIO **table = &_perlio;
1317         int code = 0;
1318         while ((f = *table)) {
1319             int i;
1320             table = (PerlIO **) (f++);
1321             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1322                 if (*f && PerlIO_flush(f) != 0)
1323                     code = -1;
1324                 f++;
1325             }
1326         }
1327         return code;
1328     }
1329 }
1330
1331 void
1332 PerlIOBase_flush_linebuf()
1333 {
1334     PerlIO **table = &_perlio;
1335     PerlIO *f;
1336     while ((f = *table)) {
1337         int i;
1338         table = (PerlIO **) (f++);
1339         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1340             if (*f
1341                 && (PerlIOBase(f)->
1342                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1343                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1344                 PerlIO_flush(f);
1345             f++;
1346         }
1347     }
1348 }
1349
1350 #undef PerlIO_fill
1351 int
1352 PerlIO_fill(PerlIO *f)
1353 {
1354     if (f && *f)
1355         return (*PerlIOBase(f)->tab->Fill) (f);
1356     else {
1357         SETERRNO(EBADF, SS$_IVCHAN);
1358         return -1;
1359     }
1360 }
1361
1362 #undef PerlIO_isutf8
1363 int
1364 PerlIO_isutf8(PerlIO *f)
1365 {
1366     if (f && *f)
1367         return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1368     else {
1369         SETERRNO(EBADF, SS$_IVCHAN);
1370         return -1;
1371     }
1372 }
1373
1374 #undef PerlIO_eof
1375 int
1376 PerlIO_eof(PerlIO *f)
1377 {
1378     if (f && *f)
1379         return (*PerlIOBase(f)->tab->Eof) (f);
1380     else {
1381         SETERRNO(EBADF, SS$_IVCHAN);
1382         return -1;
1383     }
1384 }
1385
1386 #undef PerlIO_error
1387 int
1388 PerlIO_error(PerlIO *f)
1389 {
1390     if (f && *f)
1391         return (*PerlIOBase(f)->tab->Error) (f);
1392     else {
1393         SETERRNO(EBADF, SS$_IVCHAN);
1394         return -1;
1395     }
1396 }
1397
1398 #undef PerlIO_clearerr
1399 void
1400 PerlIO_clearerr(PerlIO *f)
1401 {
1402     if (f && *f)
1403         (*PerlIOBase(f)->tab->Clearerr) (f);
1404     else
1405         SETERRNO(EBADF, SS$_IVCHAN);
1406 }
1407
1408 #undef PerlIO_setlinebuf
1409 void
1410 PerlIO_setlinebuf(PerlIO *f)
1411 {
1412     if (f && *f)
1413         (*PerlIOBase(f)->tab->Setlinebuf) (f);
1414     else
1415         SETERRNO(EBADF, SS$_IVCHAN);
1416 }
1417
1418 #undef PerlIO_has_base
1419 int
1420 PerlIO_has_base(PerlIO *f)
1421 {
1422     if (f && *f) {
1423         return (PerlIOBase(f)->tab->Get_base != NULL);
1424     }
1425     return 0;
1426 }
1427
1428 #undef PerlIO_fast_gets
1429 int
1430 PerlIO_fast_gets(PerlIO *f)
1431 {
1432     if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1433         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1434         return (tab->Set_ptrcnt != NULL);
1435     }
1436     return 0;
1437 }
1438
1439 #undef PerlIO_has_cntptr
1440 int
1441 PerlIO_has_cntptr(PerlIO *f)
1442 {
1443     if (f && *f) {
1444         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1445         return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1446     }
1447     return 0;
1448 }
1449
1450 #undef PerlIO_canset_cnt
1451 int
1452 PerlIO_canset_cnt(PerlIO *f)
1453 {
1454     if (f && *f) {
1455         PerlIOl *l = PerlIOBase(f);
1456         return (l->tab->Set_ptrcnt != NULL);
1457     }
1458     return 0;
1459 }
1460
1461 #undef PerlIO_get_base
1462 STDCHAR *
1463 PerlIO_get_base(PerlIO *f)
1464 {
1465     if (f && *f)
1466         return (*PerlIOBase(f)->tab->Get_base) (f);
1467     return NULL;
1468 }
1469
1470 #undef PerlIO_get_bufsiz
1471 int
1472 PerlIO_get_bufsiz(PerlIO *f)
1473 {
1474     if (f && *f)
1475         return (*PerlIOBase(f)->tab->Get_bufsiz) (f);
1476     return 0;
1477 }
1478
1479 #undef PerlIO_get_ptr
1480 STDCHAR *
1481 PerlIO_get_ptr(PerlIO *f)
1482 {
1483     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1484     if (tab->Get_ptr == NULL)
1485         return NULL;
1486     return (*tab->Get_ptr) (f);
1487 }
1488
1489 #undef PerlIO_get_cnt
1490 int
1491 PerlIO_get_cnt(PerlIO *f)
1492 {
1493     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1494     if (tab->Get_cnt == NULL)
1495         return 0;
1496     return (*tab->Get_cnt) (f);
1497 }
1498
1499 #undef PerlIO_set_cnt
1500 void
1501 PerlIO_set_cnt(PerlIO *f, int cnt)
1502 {
1503     (*PerlIOBase(f)->tab->Set_ptrcnt) (f, NULL, cnt);
1504 }
1505
1506 #undef PerlIO_set_ptrcnt
1507 void
1508 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR * ptr, int cnt)
1509 {
1510     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1511     if (tab->Set_ptrcnt == NULL) {
1512         dTHX;
1513         Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1514     }
1515     (*PerlIOBase(f)->tab->Set_ptrcnt) (f, ptr, cnt);
1516 }
1517
1518 /*--------------------------------------------------------------------------------------*/
1519 /*
1520  * utf8 and raw dummy layers
1521  */
1522
1523 IV
1524 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1525 {
1526     if (PerlIONext(f)) {
1527         dTHX;
1528         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1529         PerlIO_pop(aTHX_ f);
1530         if (tab->kind & PERLIO_K_UTF8)
1531             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1532         else
1533             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1534         return 0;
1535     }
1536     return -1;
1537 }
1538
1539 PerlIO_funcs PerlIO_utf8 = {
1540     "utf8",
1541     sizeof(PerlIOl),
1542     PERLIO_K_DUMMY | PERLIO_F_UTF8,
1543     PerlIOUtf8_pushed,
1544     NULL,
1545     NULL,
1546     NULL,
1547     NULL,
1548     NULL,
1549     NULL,
1550     NULL,
1551     NULL,
1552     NULL,
1553     NULL,
1554     NULL,                       /* flush */
1555     NULL,                       /* fill */
1556     NULL,
1557     NULL,
1558     NULL,
1559     NULL,
1560     NULL,                       /* get_base */
1561     NULL,                       /* get_bufsiz */
1562     NULL,                       /* get_ptr */
1563     NULL,                       /* get_cnt */
1564     NULL,                       /* set_ptrcnt */
1565 };
1566
1567 PerlIO_funcs PerlIO_byte = {
1568     "bytes",
1569     sizeof(PerlIOl),
1570     PERLIO_K_DUMMY,
1571     PerlIOUtf8_pushed,
1572     NULL,
1573     NULL,
1574     NULL,
1575     NULL,
1576     NULL,
1577     NULL,
1578     NULL,
1579     NULL,
1580     NULL,
1581     NULL,
1582     NULL,                       /* flush */
1583     NULL,                       /* fill */
1584     NULL,
1585     NULL,
1586     NULL,
1587     NULL,
1588     NULL,                       /* get_base */
1589     NULL,                       /* get_bufsiz */
1590     NULL,                       /* get_ptr */
1591     NULL,                       /* get_cnt */
1592     NULL,                       /* set_ptrcnt */
1593 };
1594
1595 PerlIO *
1596 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1597                IV n, const char *mode, int fd, int imode, int perm,
1598                PerlIO *old, int narg, SV **args)
1599 {
1600     PerlIO_funcs *tab = PerlIO_default_btm();
1601     return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1602                          old, narg, args);
1603 }
1604
1605 PerlIO_funcs PerlIO_raw = {
1606     "raw",
1607     sizeof(PerlIOl),
1608     PERLIO_K_DUMMY,
1609     PerlIORaw_pushed,
1610     PerlIOBase_popped,
1611     PerlIORaw_open,
1612     NULL,
1613     NULL,
1614     NULL,
1615     NULL,
1616     NULL,
1617     NULL,
1618     NULL,
1619     NULL,
1620     NULL,                       /* flush */
1621     NULL,                       /* fill */
1622     NULL,
1623     NULL,
1624     NULL,
1625     NULL,
1626     NULL,                       /* get_base */
1627     NULL,                       /* get_bufsiz */
1628     NULL,                       /* get_ptr */
1629     NULL,                       /* get_cnt */
1630     NULL,                       /* set_ptrcnt */
1631 };
1632 /*--------------------------------------------------------------------------------------*/
1633 /*--------------------------------------------------------------------------------------*/
1634 /*
1635  * "Methods" of the "base class"
1636  */
1637
1638 IV
1639 PerlIOBase_fileno(PerlIO *f)
1640 {
1641     return PerlIO_fileno(PerlIONext(f));
1642 }
1643
1644 char *
1645 PerlIO_modestr(PerlIO *f, char *buf)
1646 {
1647     char *s = buf;
1648     IV flags = PerlIOBase(f)->flags;
1649     if (flags & PERLIO_F_APPEND) {
1650         *s++ = 'a';
1651         if (flags & PERLIO_F_CANREAD) {
1652             *s++ = '+';
1653         }
1654     }
1655     else if (flags & PERLIO_F_CANREAD) {
1656         *s++ = 'r';
1657         if (flags & PERLIO_F_CANWRITE)
1658             *s++ = '+';
1659     }
1660     else if (flags & PERLIO_F_CANWRITE) {
1661         *s++ = 'w';
1662         if (flags & PERLIO_F_CANREAD) {
1663             *s++ = '+';
1664         }
1665     }
1666 #if O_TEXT != O_BINARY
1667     if (!(flags & PERLIO_F_CRLF))
1668         *s++ = 'b';
1669 #endif
1670     *s = '\0';
1671     return buf;
1672 }
1673
1674 IV
1675 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1676 {
1677     PerlIOl *l = PerlIOBase(f);
1678 #if 0
1679     const char *omode = mode;
1680     char temp[8];
1681 #endif
1682     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1683     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1684                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1685     if (tab->Set_ptrcnt != NULL)
1686         l->flags |= PERLIO_F_FASTGETS;
1687     if (mode) {
1688         if (*mode == '#' || *mode == 'I')
1689             mode++;
1690         switch (*mode++) {
1691         case 'r':
1692             l->flags |= PERLIO_F_CANREAD;
1693             break;
1694         case 'a':
1695             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1696             break;
1697         case 'w':
1698             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1699             break;
1700         default:
1701             SETERRNO(EINVAL, LIB$_INVARG);
1702             return -1;
1703         }
1704         while (*mode) {
1705             switch (*mode++) {
1706             case '+':
1707                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1708                 break;
1709             case 'b':
1710                 l->flags &= ~PERLIO_F_CRLF;
1711                 break;
1712             case 't':
1713                 l->flags |= PERLIO_F_CRLF;
1714                 break;
1715             default:
1716                 SETERRNO(EINVAL, LIB$_INVARG);
1717                 return -1;
1718             }
1719         }
1720     }
1721     else {
1722         if (l->next) {
1723             l->flags |= l->next->flags &
1724                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1725                  PERLIO_F_APPEND);
1726         }
1727     }
1728 #if 0
1729     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1730                  f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1731                  l->flags, PerlIO_modestr(f, temp));
1732 #endif
1733     return 0;
1734 }
1735
1736 IV
1737 PerlIOBase_popped(PerlIO *f)
1738 {
1739     return 0;
1740 }
1741
1742 SSize_t
1743 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1744 {
1745     dTHX;
1746     /*
1747      * Save the position as current head considers it
1748      */
1749     Off_t old = PerlIO_tell(f);
1750     SSize_t done;
1751     PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1752     PerlIOSelf(f, PerlIOBuf)->posn = old;
1753     done = PerlIOBuf_unread(f, vbuf, count);
1754     return done;
1755 }
1756
1757 SSize_t
1758 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1759 {
1760     STDCHAR *buf = (STDCHAR *) vbuf;
1761     if (f) {
1762         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1763             return 0;
1764         while (count > 0) {
1765             SSize_t avail = PerlIO_get_cnt(f);
1766             SSize_t take = 0;
1767             if (avail > 0)
1768                 take = (count < avail) ? count : avail;
1769             if (take > 0) {
1770                 STDCHAR *ptr = PerlIO_get_ptr(f);
1771                 Copy(ptr, buf, take, STDCHAR);
1772                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1773                 count -= take;
1774                 buf += take;
1775             }
1776             if (count > 0 && avail <= 0) {
1777                 if (PerlIO_fill(f) != 0)
1778                     break;
1779             }
1780         }
1781         return (buf - (STDCHAR *) vbuf);
1782     }
1783     return 0;
1784 }
1785
1786 IV
1787 PerlIOBase_noop_ok(PerlIO *f)
1788 {
1789     return 0;
1790 }
1791
1792 IV
1793 PerlIOBase_noop_fail(PerlIO *f)
1794 {
1795     return -1;
1796 }
1797
1798 IV
1799 PerlIOBase_close(PerlIO *f)
1800 {
1801     IV code = 0;
1802     PerlIO *n = PerlIONext(f);
1803     if (PerlIO_flush(f) != 0)
1804         code = -1;
1805     if (n && *n && (*PerlIOBase(n)->tab->Close) (n) != 0)
1806         code = -1;
1807     PerlIOBase(f)->flags &=
1808         ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1809     return code;
1810 }
1811
1812 IV
1813 PerlIOBase_eof(PerlIO *f)
1814 {
1815     if (f && *f) {
1816         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1817     }
1818     return 1;
1819 }
1820
1821 IV
1822 PerlIOBase_error(PerlIO *f)
1823 {
1824     if (f && *f) {
1825         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1826     }
1827     return 1;
1828 }
1829
1830 void
1831 PerlIOBase_clearerr(PerlIO *f)
1832 {
1833     if (f && *f) {
1834         PerlIO *n = PerlIONext(f);
1835         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
1836         if (n)
1837             PerlIO_clearerr(n);
1838     }
1839 }
1840
1841 void
1842 PerlIOBase_setlinebuf(PerlIO *f)
1843 {
1844     if (f) {
1845         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1846     }
1847 }
1848
1849 /*--------------------------------------------------------------------------------------*/
1850 /*
1851  * Bottom-most level for UNIX-like case
1852  */
1853
1854 typedef struct {
1855     struct _PerlIO base;        /* The generic part */
1856     int fd;                     /* UNIX like file descriptor */
1857     int oflags;                 /* open/fcntl flags */
1858 } PerlIOUnix;
1859
1860 int
1861 PerlIOUnix_oflags(const char *mode)
1862 {
1863     int oflags = -1;
1864     if (*mode == 'I' || *mode == '#')
1865         mode++;
1866     switch (*mode) {
1867     case 'r':
1868         oflags = O_RDONLY;
1869         if (*++mode == '+') {
1870             oflags = O_RDWR;
1871             mode++;
1872         }
1873         break;
1874
1875     case 'w':
1876         oflags = O_CREAT | O_TRUNC;
1877         if (*++mode == '+') {
1878             oflags |= O_RDWR;
1879             mode++;
1880         }
1881         else
1882             oflags |= O_WRONLY;
1883         break;
1884
1885     case 'a':
1886         oflags = O_CREAT | O_APPEND;
1887         if (*++mode == '+') {
1888             oflags |= O_RDWR;
1889             mode++;
1890         }
1891         else
1892             oflags |= O_WRONLY;
1893         break;
1894     }
1895     if (*mode == 'b') {
1896         oflags |= O_BINARY;
1897         oflags &= ~O_TEXT;
1898         mode++;
1899     }
1900     else if (*mode == 't') {
1901         oflags |= O_TEXT;
1902         oflags &= ~O_BINARY;
1903         mode++;
1904     }
1905     /*
1906      * Always open in binary mode
1907      */
1908     oflags |= O_BINARY;
1909     if (*mode || oflags == -1) {
1910         SETERRNO(EINVAL, LIB$_INVARG);
1911         oflags = -1;
1912     }
1913     return oflags;
1914 }
1915
1916 IV
1917 PerlIOUnix_fileno(PerlIO *f)
1918 {
1919     return PerlIOSelf(f, PerlIOUnix)->fd;
1920 }
1921
1922 IV
1923 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1924 {
1925     IV code = PerlIOBase_pushed(f, mode, arg);
1926     if (*PerlIONext(f)) {
1927         PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
1928         s->fd = PerlIO_fileno(PerlIONext(f));
1929         /*
1930          * XXX could (or should) we retrieve the oflags from the open file
1931          * handle rather than believing the "mode" we are passed in? XXX
1932          * Should the value on NULL mode be 0 or -1?
1933          */
1934         s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
1935     }
1936     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1937     return code;
1938 }
1939
1940 PerlIO *
1941 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1942                 IV n, const char *mode, int fd, int imode,
1943                 int perm, PerlIO *f, int narg, SV **args)
1944 {
1945     if (f) {
1946         if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1947             (*PerlIOBase(f)->tab->Close) (f);
1948     }
1949     if (narg > 0) {
1950         char *path = SvPV_nolen(*args);
1951         if (*mode == '#')
1952             mode++;
1953         else {
1954             imode = PerlIOUnix_oflags(mode);
1955             perm = 0666;
1956         }
1957         if (imode != -1) {
1958             fd = PerlLIO_open3(path, imode, perm);
1959         }
1960     }
1961     if (fd >= 0) {
1962         PerlIOUnix *s;
1963         if (*mode == 'I')
1964             mode++;
1965         if (!f) {
1966             f = PerlIO_allocate(aTHX);
1967             s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
1968                            PerlIOUnix);
1969         }
1970         else
1971             s = PerlIOSelf(f, PerlIOUnix);
1972         s->fd = fd;
1973         s->oflags = imode;
1974         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1975         return f;
1976     }
1977     else {
1978         if (f) {
1979             /*
1980              * FIXME: pop layers ???
1981              */
1982         }
1983         return NULL;
1984     }
1985 }
1986
1987 PerlIO *
1988 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
1989 {
1990     PerlIO_funcs *self = PerlIOBase(o)->tab;
1991     SV *arg = Nullsv;
1992     char buf[8];
1993     if (self->Getarg) {
1994         arg = (*self->Getarg)(o);
1995 #ifdef sv_dup
1996         if (arg) {
1997             arg = sv_dup(arg, param);
1998         }
1999 #endif
2000     }
2001     if (!f) {
2002         f = PerlIO_allocate(aTHX);
2003     }
2004     f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2005     return f;
2006 }
2007
2008 PerlIO *
2009 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
2010 {
2011     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2012     int fd = PerlLIO_dup(os->fd);
2013     if (fd >= 0) {
2014         f = PerlIOBase_dup(aTHX_ f, o, param);
2015         if (f) {
2016             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2017             PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2018             s->fd = fd;
2019             return f;
2020         }
2021         else {
2022             PerlLIO_close(fd);
2023         }
2024     }
2025     return NULL;
2026 }
2027
2028
2029 SSize_t
2030 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2031 {
2032     dTHX;
2033     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2034     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2035         return 0;
2036     while (1) {
2037         SSize_t len = PerlLIO_read(fd, vbuf, count);
2038         if (len >= 0 || errno != EINTR) {
2039             if (len < 0)
2040                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2041             else if (len == 0 && count != 0)
2042                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2043             return len;
2044         }
2045         PERL_ASYNC_CHECK();
2046     }
2047 }
2048
2049 SSize_t
2050 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2051 {
2052     dTHX;
2053     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2054     while (1) {
2055         SSize_t len = PerlLIO_write(fd, vbuf, count);
2056         if (len >= 0 || errno != EINTR) {
2057             if (len < 0)
2058                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2059             return len;
2060         }
2061         PERL_ASYNC_CHECK();
2062     }
2063 }
2064
2065 IV
2066 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2067 {
2068     dSYS;
2069     Off_t new =
2070         PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2071     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2072     return (new == (Off_t) - 1) ? -1 : 0;
2073 }
2074
2075 Off_t
2076 PerlIOUnix_tell(PerlIO *f)
2077 {
2078     dSYS;
2079     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2080 }
2081
2082
2083 IV
2084 PerlIOUnix_close(PerlIO *f)
2085 {
2086     dTHX;
2087     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2088     int code = 0;
2089     while (PerlLIO_close(fd) != 0) {
2090         if (errno != EINTR) {
2091             code = -1;
2092             break;
2093         }
2094         PERL_ASYNC_CHECK();
2095     }
2096     if (code == 0) {
2097         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2098     }
2099     return code;
2100 }
2101
2102 PerlIO_funcs PerlIO_unix = {
2103     "unix",
2104     sizeof(PerlIOUnix),
2105     PERLIO_K_RAW,
2106     PerlIOUnix_pushed,
2107     PerlIOBase_noop_ok,
2108     PerlIOUnix_open,
2109     NULL,
2110     PerlIOUnix_fileno,
2111     PerlIOUnix_dup,
2112     PerlIOUnix_read,
2113     PerlIOBase_unread,
2114     PerlIOUnix_write,
2115     PerlIOUnix_seek,
2116     PerlIOUnix_tell,
2117     PerlIOUnix_close,
2118     PerlIOBase_noop_ok,         /* flush */
2119     PerlIOBase_noop_fail,       /* fill */
2120     PerlIOBase_eof,
2121     PerlIOBase_error,
2122     PerlIOBase_clearerr,
2123     PerlIOBase_setlinebuf,
2124     NULL,                       /* get_base */
2125     NULL,                       /* get_bufsiz */
2126     NULL,                       /* get_ptr */
2127     NULL,                       /* get_cnt */
2128     NULL,                       /* set_ptrcnt */
2129 };
2130
2131 /*--------------------------------------------------------------------------------------*/
2132 /*
2133  * stdio as a layer
2134  */
2135
2136 typedef struct {
2137     struct _PerlIO base;
2138     FILE *stdio;                /* The stream */
2139 } PerlIOStdio;
2140
2141 IV
2142 PerlIOStdio_fileno(PerlIO *f)
2143 {
2144     dSYS;
2145     return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2146 }
2147
2148 char *
2149 PerlIOStdio_mode(const char *mode, char *tmode)
2150 {
2151     char *ret = tmode;
2152     while (*mode) {
2153         *tmode++ = *mode++;
2154     }
2155     if (O_BINARY != O_TEXT) {
2156         *tmode++ = 'b';
2157     }
2158     *tmode = '\0';
2159     return ret;
2160 }
2161
2162 /*
2163  * This isn't used yet ...
2164  */
2165 IV
2166 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2167 {
2168     if (*PerlIONext(f)) {
2169         dSYS;
2170         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2171         char tmode[8];
2172         FILE *stdio =
2173             PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2174                            PerlIOStdio_mode(mode, tmode));
2175         if (stdio)
2176             s->stdio = stdio;
2177         else
2178             return -1;
2179     }
2180     return PerlIOBase_pushed(f, mode, arg);
2181 }
2182
2183 #undef PerlIO_importFILE
2184 PerlIO *
2185 PerlIO_importFILE(FILE *stdio, int fl)
2186 {
2187     dTHX;
2188     PerlIO *f = NULL;
2189     if (stdio) {
2190         PerlIOStdio *s =
2191             PerlIOSelf(PerlIO_push
2192                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2193                         "r+", Nullsv), PerlIOStdio);
2194         s->stdio = stdio;
2195     }
2196     return f;
2197 }
2198
2199 PerlIO *
2200 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2201                  IV n, const char *mode, int fd, int imode,
2202                  int perm, PerlIO *f, int narg, SV **args)
2203 {
2204     char tmode[8];
2205     if (f) {
2206         char *path = SvPV_nolen(*args);
2207         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2208         FILE *stdio =
2209             PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2210                             s->stdio);
2211         if (!s->stdio)
2212             return NULL;
2213         s->stdio = stdio;
2214         return f;
2215     }
2216     else {
2217         if (narg > 0) {
2218             char *path = SvPV_nolen(*args);
2219             if (*mode == '#') {
2220                 mode++;
2221                 fd = PerlLIO_open3(path, imode, perm);
2222             }
2223             else {
2224                 FILE *stdio = PerlSIO_fopen(path, mode);
2225                 if (stdio) {
2226                     PerlIOStdio *s =
2227                         PerlIOSelf(PerlIO_push
2228                                    (aTHX_(f = PerlIO_allocate(aTHX)), self,
2229                                     (mode = PerlIOStdio_mode(mode, tmode)),
2230                                     PerlIOArg),
2231                                    PerlIOStdio);
2232                     s->stdio = stdio;
2233                 }
2234                 return f;
2235             }
2236         }
2237         if (fd >= 0) {
2238             FILE *stdio = NULL;
2239             int init = 0;
2240             if (*mode == 'I') {
2241                 init = 1;
2242                 mode++;
2243             }
2244             if (init) {
2245                 switch (fd) {
2246                 case 0:
2247                     stdio = PerlSIO_stdin;
2248                     break;
2249                 case 1:
2250                     stdio = PerlSIO_stdout;
2251                     break;
2252                 case 2:
2253                     stdio = PerlSIO_stderr;
2254                     break;
2255                 }
2256             }
2257             else {
2258                 stdio = PerlSIO_fdopen(fd, mode =
2259                                        PerlIOStdio_mode(mode, tmode));
2260             }
2261             if (stdio) {
2262                 PerlIOStdio *s =
2263                     PerlIOSelf(PerlIO_push
2264                                (aTHX_(f = PerlIO_allocate(aTHX)), self,
2265                                 mode, PerlIOArg), PerlIOStdio);
2266                 s->stdio = stdio;
2267                 return f;
2268             }
2269         }
2270     }
2271     return NULL;
2272 }
2273
2274 SSize_t
2275 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2276 {
2277     dSYS;
2278     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2279     SSize_t got = 0;
2280     if (count == 1) {
2281         STDCHAR *buf = (STDCHAR *) vbuf;
2282         /*
2283          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2284          * stdio does not do that for fread()
2285          */
2286         int ch = PerlSIO_fgetc(s);
2287         if (ch != EOF) {
2288             *buf = ch;
2289             got = 1;
2290         }
2291     }
2292     else
2293         got = PerlSIO_fread(vbuf, 1, count, s);
2294     return got;
2295 }
2296
2297 SSize_t
2298 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2299 {
2300     dSYS;
2301     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2302     STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2303     SSize_t unread = 0;
2304     while (count > 0) {
2305         int ch = *buf-- & 0xff;
2306         if (PerlSIO_ungetc(ch, s) != ch)
2307             break;
2308         unread++;
2309         count--;
2310     }
2311     return unread;
2312 }
2313
2314 SSize_t
2315 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2316 {
2317     dSYS;
2318     return PerlSIO_fwrite(vbuf, 1, count,
2319                           PerlIOSelf(f, PerlIOStdio)->stdio);
2320 }
2321
2322 IV
2323 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2324 {
2325     dSYS;
2326     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2327     return PerlSIO_fseek(stdio, offset, whence);
2328 }
2329
2330 Off_t
2331 PerlIOStdio_tell(PerlIO *f)
2332 {
2333     dSYS;
2334     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2335     return PerlSIO_ftell(stdio);
2336 }
2337
2338 IV
2339 PerlIOStdio_close(PerlIO *f)
2340 {
2341     dSYS;
2342 #ifdef SOCKS5_VERSION_NAME
2343     int optval;
2344     Sock_size_t optlen = sizeof(int);
2345 #endif
2346     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2347     return (
2348 #ifdef SOCKS5_VERSION_NAME
2349                (getsockopt
2350                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2351                  &optlen) <
2352                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2353 #else
2354                PerlSIO_fclose(stdio)
2355 #endif
2356         );
2357
2358 }
2359
2360 IV
2361 PerlIOStdio_flush(PerlIO *f)
2362 {
2363     dSYS;
2364     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2365     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2366         return PerlSIO_fflush(stdio);
2367     }
2368     else {
2369 #if 0
2370         /*
2371          * FIXME: This discards ungetc() and pre-read stuff which is not
2372          * right if this is just a "sync" from a layer above Suspect right
2373          * design is to do _this_ but not have layer above flush this
2374          * layer read-to-read
2375          */
2376         /*
2377          * Not writeable - sync by attempting a seek
2378          */
2379         int err = errno;
2380         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2381             errno = err;
2382 #endif
2383     }
2384     return 0;
2385 }
2386
2387 IV
2388 PerlIOStdio_fill(PerlIO *f)
2389 {
2390     dSYS;
2391     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2392     int c;
2393     /*
2394      * fflush()ing read-only streams can cause trouble on some stdio-s
2395      */
2396     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2397         if (PerlSIO_fflush(stdio) != 0)
2398             return EOF;
2399     }
2400     c = PerlSIO_fgetc(stdio);
2401     if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2402         return EOF;
2403     return 0;
2404 }
2405
2406 IV
2407 PerlIOStdio_eof(PerlIO *f)
2408 {
2409     dSYS;
2410     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2411 }
2412
2413 IV
2414 PerlIOStdio_error(PerlIO *f)
2415 {
2416     dSYS;
2417     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2418 }
2419
2420 void
2421 PerlIOStdio_clearerr(PerlIO *f)
2422 {
2423     dSYS;
2424     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2425 }
2426
2427 void
2428 PerlIOStdio_setlinebuf(PerlIO *f)
2429 {
2430     dSYS;
2431 #ifdef HAS_SETLINEBUF
2432     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2433 #else
2434     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2435 #endif
2436 }
2437
2438 #ifdef FILE_base
2439 STDCHAR *
2440 PerlIOStdio_get_base(PerlIO *f)
2441 {
2442     dSYS;
2443     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2444     return PerlSIO_get_base(stdio);
2445 }
2446
2447 Size_t
2448 PerlIOStdio_get_bufsiz(PerlIO *f)
2449 {
2450     dSYS;
2451     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2452     return PerlSIO_get_bufsiz(stdio);
2453 }
2454 #endif
2455
2456 #ifdef USE_STDIO_PTR
2457 STDCHAR *
2458 PerlIOStdio_get_ptr(PerlIO *f)
2459 {
2460     dSYS;
2461     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2462     return PerlSIO_get_ptr(stdio);
2463 }
2464
2465 SSize_t
2466 PerlIOStdio_get_cnt(PerlIO *f)
2467 {
2468     dSYS;
2469     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2470     return PerlSIO_get_cnt(stdio);
2471 }
2472
2473 void
2474 PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2475 {
2476     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2477     dSYS;
2478     if (ptr != NULL) {
2479 #ifdef STDIO_PTR_LVALUE
2480         PerlSIO_set_ptr(stdio, ptr);
2481 #ifdef STDIO_PTR_LVAL_SETS_CNT
2482         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2483             dTHX;
2484             assert(PerlSIO_get_cnt(stdio) == (cnt));
2485         }
2486 #endif
2487 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2488         /*
2489          * Setting ptr _does_ change cnt - we are done
2490          */
2491         return;
2492 #endif
2493 #else                           /* STDIO_PTR_LVALUE */
2494         PerlProc_abort();
2495 #endif                          /* STDIO_PTR_LVALUE */
2496     }
2497     /*
2498      * Now (or only) set cnt
2499      */
2500 #ifdef STDIO_CNT_LVALUE
2501     PerlSIO_set_cnt(stdio, cnt);
2502 #else                           /* STDIO_CNT_LVALUE */
2503 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2504     PerlSIO_set_ptr(stdio,
2505                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2506                                               cnt));
2507 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2508     PerlProc_abort();
2509 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2510 #endif                          /* STDIO_CNT_LVALUE */
2511 }
2512
2513 #endif
2514
2515 PerlIO *
2516 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
2517 {
2518  return NULL;
2519 }
2520
2521 PerlIO_funcs PerlIO_stdio = {
2522     "stdio",
2523     sizeof(PerlIOStdio),
2524     PERLIO_K_BUFFERED,
2525     PerlIOBase_pushed,
2526     PerlIOBase_noop_ok,
2527     PerlIOStdio_open,
2528     NULL,
2529     PerlIOStdio_fileno,
2530     PerlIOStdio_dup,
2531     PerlIOStdio_read,
2532     PerlIOStdio_unread,
2533     PerlIOStdio_write,
2534     PerlIOStdio_seek,
2535     PerlIOStdio_tell,
2536     PerlIOStdio_close,
2537     PerlIOStdio_flush,
2538     PerlIOStdio_fill,
2539     PerlIOStdio_eof,
2540     PerlIOStdio_error,
2541     PerlIOStdio_clearerr,
2542     PerlIOStdio_setlinebuf,
2543 #ifdef FILE_base
2544     PerlIOStdio_get_base,
2545     PerlIOStdio_get_bufsiz,
2546 #else
2547     NULL,
2548     NULL,
2549 #endif
2550 #ifdef USE_STDIO_PTR
2551     PerlIOStdio_get_ptr,
2552     PerlIOStdio_get_cnt,
2553 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2554     PerlIOStdio_set_ptrcnt
2555 #else                           /* STDIO_PTR_LVALUE */
2556     NULL
2557 #endif                          /* STDIO_PTR_LVALUE */
2558 #else                           /* USE_STDIO_PTR */
2559     NULL,
2560     NULL,
2561     NULL
2562 #endif                          /* USE_STDIO_PTR */
2563 };
2564
2565 #undef PerlIO_exportFILE
2566 FILE *
2567 PerlIO_exportFILE(PerlIO *f, int fl)
2568 {
2569     FILE *stdio;
2570     PerlIO_flush(f);
2571     stdio = fdopen(PerlIO_fileno(f), "r+");
2572     if (stdio) {
2573         dTHX;
2574         PerlIOStdio *s =
2575             PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2576                        PerlIOStdio);
2577         s->stdio = stdio;
2578     }
2579     return stdio;
2580 }
2581
2582 #undef PerlIO_findFILE
2583 FILE *
2584 PerlIO_findFILE(PerlIO *f)
2585 {
2586     PerlIOl *l = *f;
2587     while (l) {
2588         if (l->tab == &PerlIO_stdio) {
2589             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2590             return s->stdio;
2591         }
2592         l = *PerlIONext(&l);
2593     }
2594     return PerlIO_exportFILE(f, 0);
2595 }
2596
2597 #undef PerlIO_releaseFILE
2598 void
2599 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2600 {
2601 }
2602
2603 /*--------------------------------------------------------------------------------------*/
2604 /*
2605  * perlio buffer layer
2606  */
2607
2608 IV
2609 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2610 {
2611     dSYS;
2612     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2613     int fd = PerlIO_fileno(f);
2614     Off_t posn;
2615     if (fd >= 0 && PerlLIO_isatty(fd)) {
2616         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2617     }
2618     posn = PerlIO_tell(PerlIONext(f));
2619     if (posn != (Off_t) - 1) {
2620         b->posn = posn;
2621     }
2622     return PerlIOBase_pushed(f, mode, arg);
2623 }
2624
2625 PerlIO *
2626 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2627                IV n, const char *mode, int fd, int imode, int perm,
2628                PerlIO *f, int narg, SV **args)
2629 {
2630     if (f) {
2631         PerlIO *next = PerlIONext(f);
2632         PerlIO_funcs *tab =
2633             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2634         next =
2635             (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2636                           next, narg, args);
2637         if (!next
2638             || (*PerlIOBase(f)->tab->Pushed) (f, mode, PerlIOArg) != 0) {
2639             return NULL;
2640         }
2641     }
2642     else {
2643         PerlIO_funcs *tab =
2644             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2645         int init = 0;
2646         if (*mode == 'I') {
2647             init = 1;
2648             /*
2649              * mode++;
2650              */
2651         }
2652         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2653                           NULL, narg, args);
2654         if (f) {
2655             PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2656             fd = PerlIO_fileno(f);
2657 #if O_BINARY != O_TEXT
2658             /*
2659              * do something about failing setmode()? --jhi
2660              */
2661             PerlLIO_setmode(fd, O_BINARY);
2662 #endif
2663             if (init && fd == 2) {
2664                 /*
2665                  * Initial stderr is unbuffered
2666                  */
2667                 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2668             }
2669         }
2670     }
2671     return f;
2672 }
2673
2674 /*
2675  * This "flush" is akin to sfio's sync in that it handles files in either
2676  * read or write state
2677  */
2678 IV
2679 PerlIOBuf_flush(PerlIO *f)
2680 {
2681     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2682     int code = 0;
2683     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2684         /*
2685          * write() the buffer
2686          */
2687         STDCHAR *buf = b->buf;
2688         STDCHAR *p = buf;
2689         PerlIO *n = PerlIONext(f);
2690         while (p < b->ptr) {
2691             SSize_t count = PerlIO_write(n, p, b->ptr - p);
2692             if (count > 0) {
2693                 p += count;
2694             }
2695             else if (count < 0 || PerlIO_error(n)) {
2696                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2697                 code = -1;
2698                 break;
2699             }
2700         }
2701         b->posn += (p - buf);
2702     }
2703     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2704         STDCHAR *buf = PerlIO_get_base(f);
2705         /*
2706          * Note position change
2707          */
2708         b->posn += (b->ptr - buf);
2709         if (b->ptr < b->end) {
2710             /*
2711              * We did not consume all of it
2712              */
2713             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
2714                 b->posn = PerlIO_tell(PerlIONext(f));
2715             }
2716         }
2717     }
2718     b->ptr = b->end = b->buf;
2719     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2720     /*
2721      * FIXME: Is this right for read case ?
2722      */
2723     if (PerlIO_flush(PerlIONext(f)) != 0)
2724         code = -1;
2725     return code;
2726 }
2727
2728 IV
2729 PerlIOBuf_fill(PerlIO *f)
2730 {
2731     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2732     PerlIO *n = PerlIONext(f);
2733     SSize_t avail;
2734     /*
2735      * FIXME: doing the down-stream flush is a bad idea if it causes
2736      * pre-read data in stdio buffer to be discarded but this is too
2737      * simplistic - as it skips _our_ hosekeeping and breaks tell tests.
2738      * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
2739      */
2740     if (PerlIO_flush(f) != 0)
2741         return -1;
2742     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2743         PerlIOBase_flush_linebuf();
2744
2745     if (!b->buf)
2746         PerlIO_get_base(f);     /* allocate via vtable */
2747
2748     b->ptr = b->end = b->buf;
2749     if (PerlIO_fast_gets(n)) {
2750         /*
2751          * Layer below is also buffered We do _NOT_ want to call its
2752          * ->Read() because that will loop till it gets what we asked for
2753          * which may hang on a pipe etc. Instead take anything it has to
2754          * hand, or ask it to fill _once_.
2755          */
2756         avail = PerlIO_get_cnt(n);
2757         if (avail <= 0) {
2758             avail = PerlIO_fill(n);
2759             if (avail == 0)
2760                 avail = PerlIO_get_cnt(n);
2761             else {
2762                 if (!PerlIO_error(n) && PerlIO_eof(n))
2763                     avail = 0;
2764             }
2765         }
2766         if (avail > 0) {
2767             STDCHAR *ptr = PerlIO_get_ptr(n);
2768             SSize_t cnt = avail;
2769             if (avail > b->bufsiz)
2770                 avail = b->bufsiz;
2771             Copy(ptr, b->buf, avail, STDCHAR);
2772             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
2773         }
2774     }
2775     else {
2776         avail = PerlIO_read(n, b->ptr, b->bufsiz);
2777     }
2778     if (avail <= 0) {
2779         if (avail == 0)
2780             PerlIOBase(f)->flags |= PERLIO_F_EOF;
2781         else
2782             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2783         return -1;
2784     }
2785     b->end = b->buf + avail;
2786     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2787     return 0;
2788 }
2789
2790 SSize_t
2791 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2792 {
2793     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2794     if (f) {
2795         if (!b->ptr)
2796             PerlIO_get_base(f);
2797         return PerlIOBase_read(f, vbuf, count);
2798     }
2799     return 0;
2800 }
2801
2802 SSize_t
2803 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2804 {
2805     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
2806     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2807     SSize_t unread = 0;
2808     SSize_t avail;
2809     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2810         PerlIO_flush(f);
2811     if (!b->buf)
2812         PerlIO_get_base(f);
2813     if (b->buf) {
2814         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2815             /*
2816              * Buffer is already a read buffer, we can overwrite any chars
2817              * which have been read back to buffer start
2818              */
2819             avail = (b->ptr - b->buf);
2820         }
2821         else {
2822             /*
2823              * Buffer is idle, set it up so whole buffer is available for
2824              * unread
2825              */
2826             avail = b->bufsiz;
2827             b->end = b->buf + avail;
2828             b->ptr = b->end;
2829             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2830             /*
2831              * Buffer extends _back_ from where we are now
2832              */
2833             b->posn -= b->bufsiz;
2834         }
2835         if (avail > (SSize_t) count) {
2836             /*
2837              * If we have space for more than count, just move count
2838              */
2839             avail = count;
2840         }
2841         if (avail > 0) {
2842             b->ptr -= avail;
2843             buf -= avail;
2844             /*
2845              * In simple stdio-like ungetc() case chars will be already
2846              * there
2847              */
2848             if (buf != b->ptr) {
2849                 Copy(buf, b->ptr, avail, STDCHAR);
2850             }
2851             count -= avail;
2852             unread += avail;
2853             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2854         }
2855     }
2856     return unread;
2857 }
2858
2859 SSize_t
2860 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2861 {
2862     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2863     const STDCHAR *buf = (const STDCHAR *) vbuf;
2864     Size_t written = 0;
2865     if (!b->buf)
2866         PerlIO_get_base(f);
2867     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2868         return 0;
2869     while (count > 0) {
2870         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2871         if ((SSize_t) count < avail)
2872             avail = count;
2873         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2874         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
2875             while (avail > 0) {
2876                 int ch = *buf++;
2877                 *(b->ptr)++ = ch;
2878                 count--;
2879                 avail--;
2880                 written++;
2881                 if (ch == '\n') {
2882                     PerlIO_flush(f);
2883                     break;
2884                 }
2885             }
2886         }
2887         else {
2888             if (avail) {
2889                 Copy(buf, b->ptr, avail, STDCHAR);
2890                 count -= avail;
2891                 buf += avail;
2892                 written += avail;
2893                 b->ptr += avail;
2894             }
2895         }
2896         if (b->ptr >= (b->buf + b->bufsiz))
2897             PerlIO_flush(f);
2898     }
2899     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2900         PerlIO_flush(f);
2901     return written;
2902 }
2903
2904 IV
2905 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2906 {
2907     IV code;
2908     if ((code = PerlIO_flush(f)) == 0) {
2909         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2910         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2911         code = PerlIO_seek(PerlIONext(f), offset, whence);
2912         if (code == 0) {
2913             b->posn = PerlIO_tell(PerlIONext(f));
2914         }
2915     }
2916     return code;
2917 }
2918
2919 Off_t
2920 PerlIOBuf_tell(PerlIO *f)
2921 {
2922     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2923     /*
2924      * b->posn is file position where b->buf was read, or will be written
2925      */
2926     Off_t posn = b->posn;
2927     if (b->buf) {
2928         /*
2929          * If buffer is valid adjust position by amount in buffer
2930          */
2931         posn += (b->ptr - b->buf);
2932     }
2933     return posn;
2934 }
2935
2936 IV
2937 PerlIOBuf_close(PerlIO *f)
2938 {
2939     IV code = PerlIOBase_close(f);
2940     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2941     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
2942         PerlMemShared_free(b->buf);
2943     }
2944     b->buf = NULL;
2945     b->ptr = b->end = b->buf;
2946     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2947     return code;
2948 }
2949
2950 STDCHAR *
2951 PerlIOBuf_get_ptr(PerlIO *f)
2952 {
2953     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2954     if (!b->buf)
2955         PerlIO_get_base(f);
2956     return b->ptr;
2957 }
2958
2959 SSize_t
2960 PerlIOBuf_get_cnt(PerlIO *f)
2961 {
2962     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2963     if (!b->buf)
2964         PerlIO_get_base(f);
2965     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2966         return (b->end - b->ptr);
2967     return 0;
2968 }
2969
2970 STDCHAR *
2971 PerlIOBuf_get_base(PerlIO *f)
2972 {
2973     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2974     if (!b->buf) {
2975         if (!b->bufsiz)
2976             b->bufsiz = 4096;
2977         b->buf = PerlMemShared_calloc(b->bufsiz, sizeof(STDCHAR));
2978         if (!b->buf) {
2979             b->buf = (STDCHAR *) & b->oneword;
2980             b->bufsiz = sizeof(b->oneword);
2981         }
2982         b->ptr = b->buf;
2983         b->end = b->ptr;
2984     }
2985     return b->buf;
2986 }
2987
2988 Size_t
2989 PerlIOBuf_bufsiz(PerlIO *f)
2990 {
2991     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2992     if (!b->buf)
2993         PerlIO_get_base(f);
2994     return (b->end - b->buf);
2995 }
2996
2997 void
2998 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2999 {
3000     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3001     if (!b->buf)
3002         PerlIO_get_base(f);
3003     b->ptr = ptr;
3004     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3005         dTHX;
3006         assert(PerlIO_get_cnt(f) == cnt);
3007         assert(b->ptr >= b->buf);
3008     }
3009     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3010 }
3011
3012 PerlIO *
3013 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
3014 {
3015  return NULL;
3016 }
3017
3018
3019
3020 PerlIO_funcs PerlIO_perlio = {
3021     "perlio",
3022     sizeof(PerlIOBuf),
3023     PERLIO_K_BUFFERED,
3024     PerlIOBuf_pushed,
3025     PerlIOBase_noop_ok,
3026     PerlIOBuf_open,
3027     NULL,
3028     PerlIOBase_fileno,
3029     PerlIOBuf_dup,
3030     PerlIOBuf_read,
3031     PerlIOBuf_unread,
3032     PerlIOBuf_write,
3033     PerlIOBuf_seek,
3034     PerlIOBuf_tell,
3035     PerlIOBuf_close,
3036     PerlIOBuf_flush,
3037     PerlIOBuf_fill,
3038     PerlIOBase_eof,
3039     PerlIOBase_error,
3040     PerlIOBase_clearerr,
3041     PerlIOBase_setlinebuf,
3042     PerlIOBuf_get_base,
3043     PerlIOBuf_bufsiz,
3044     PerlIOBuf_get_ptr,
3045     PerlIOBuf_get_cnt,
3046     PerlIOBuf_set_ptrcnt,
3047 };
3048
3049 /*--------------------------------------------------------------------------------------*/
3050 /*
3051  * Temp layer to hold unread chars when cannot do it any other way
3052  */
3053
3054 IV
3055 PerlIOPending_fill(PerlIO *f)
3056 {
3057     /*
3058      * Should never happen
3059      */
3060     PerlIO_flush(f);
3061     return 0;
3062 }
3063
3064 IV
3065 PerlIOPending_close(PerlIO *f)
3066 {
3067     /*
3068      * A tad tricky - flush pops us, then we close new top
3069      */
3070     PerlIO_flush(f);
3071     return PerlIO_close(f);
3072 }
3073
3074 IV
3075 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3076 {
3077     /*
3078      * A tad tricky - flush pops us, then we seek new top
3079      */
3080     PerlIO_flush(f);
3081     return PerlIO_seek(f, offset, whence);
3082 }
3083
3084
3085 IV
3086 PerlIOPending_flush(PerlIO *f)
3087 {
3088     dTHX;
3089     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3090     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3091         PerlMemShared_free(b->buf);
3092         b->buf = NULL;
3093     }
3094     PerlIO_pop(aTHX_ f);
3095     return 0;
3096 }
3097
3098 void
3099 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3100 {
3101     if (cnt <= 0) {
3102         PerlIO_flush(f);
3103     }
3104     else {
3105         PerlIOBuf_set_ptrcnt(f, ptr, cnt);
3106     }
3107 }
3108
3109 IV
3110 PerlIOPending_pushed(PerlIO *f, const char *mode, SV *arg)
3111 {
3112     IV code = PerlIOBase_pushed(f, mode, arg);
3113     PerlIOl *l = PerlIOBase(f);
3114     /*
3115      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3116      * etc. get muddled when it changes mid-string when we auto-pop.
3117      */
3118     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3119         (PerlIOBase(PerlIONext(f))->
3120          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3121     return code;
3122 }
3123
3124 SSize_t
3125 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3126 {
3127     SSize_t avail = PerlIO_get_cnt(f);
3128     SSize_t got = 0;
3129     if (count < avail)
3130         avail = count;
3131     if (avail > 0)
3132         got = PerlIOBuf_read(f, vbuf, avail);
3133     if (got >= 0 && got < count) {
3134         SSize_t more =
3135             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3136         if (more >= 0 || got == 0)
3137             got += more;
3138     }
3139     return got;
3140 }
3141
3142 PerlIO_funcs PerlIO_pending = {
3143     "pending",
3144     sizeof(PerlIOBuf),
3145     PERLIO_K_BUFFERED,
3146     PerlIOPending_pushed,
3147     PerlIOBase_noop_ok,
3148     NULL,
3149     NULL,
3150     PerlIOBase_fileno,
3151     PerlIOBuf_dup,
3152     PerlIOPending_read,
3153     PerlIOBuf_unread,
3154     PerlIOBuf_write,
3155     PerlIOPending_seek,
3156     PerlIOBuf_tell,
3157     PerlIOPending_close,
3158     PerlIOPending_flush,
3159     PerlIOPending_fill,
3160     PerlIOBase_eof,
3161     PerlIOBase_error,
3162     PerlIOBase_clearerr,
3163     PerlIOBase_setlinebuf,
3164     PerlIOBuf_get_base,
3165     PerlIOBuf_bufsiz,
3166     PerlIOBuf_get_ptr,
3167     PerlIOBuf_get_cnt,
3168     PerlIOPending_set_ptrcnt,
3169 };
3170
3171
3172
3173 /*--------------------------------------------------------------------------------------*/
3174 /*
3175  * crlf - translation On read translate CR,LF to "\n" we do this by
3176  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3177  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3178  */
3179
3180 typedef struct {
3181     PerlIOBuf base;             /* PerlIOBuf stuff */
3182     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3183                                  * buffer */
3184 } PerlIOCrlf;
3185
3186 IV
3187 PerlIOCrlf_pushed(PerlIO *f, const char *mode, SV *arg)
3188 {
3189     IV code;
3190     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3191     code = PerlIOBuf_pushed(f, mode, arg);
3192 #if 0
3193     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3194                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3195                  PerlIOBase(f)->flags);
3196 #endif
3197     return code;
3198 }
3199
3200
3201 SSize_t
3202 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3203 {
3204     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3205     if (c->nl) {
3206         *(c->nl) = 0xd;
3207         c->nl = NULL;
3208     }
3209     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3210         return PerlIOBuf_unread(f, vbuf, count);
3211     else {
3212         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3213         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3214         SSize_t unread = 0;
3215         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3216             PerlIO_flush(f);
3217         if (!b->buf)
3218             PerlIO_get_base(f);
3219         if (b->buf) {
3220             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3221                 b->end = b->ptr = b->buf + b->bufsiz;
3222                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3223                 b->posn -= b->bufsiz;
3224             }
3225             while (count > 0 && b->ptr > b->buf) {
3226                 int ch = *--buf;
3227                 if (ch == '\n') {
3228                     if (b->ptr - 2 >= b->buf) {
3229                         *--(b->ptr) = 0xa;
3230                         *--(b->ptr) = 0xd;
3231                         unread++;
3232                         count--;
3233                     }
3234                     else {
3235                         buf++;
3236                         break;
3237                     }
3238                 }
3239                 else {
3240                     *--(b->ptr) = ch;
3241                     unread++;
3242                     count--;
3243                 }
3244             }
3245         }
3246         return unread;
3247     }
3248 }
3249
3250 SSize_t
3251 PerlIOCrlf_get_cnt(PerlIO *f)
3252 {
3253     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3254     if (!b->buf)
3255         PerlIO_get_base(f);
3256     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3257         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3258         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) {
3259             STDCHAR *nl = b->ptr;
3260           scan:
3261             while (nl < b->end && *nl != 0xd)
3262                 nl++;
3263             if (nl < b->end && *nl == 0xd) {
3264               test:
3265                 if (nl + 1 < b->end) {
3266                     if (nl[1] == 0xa) {
3267                         *nl = '\n';
3268                         c->nl = nl;
3269                     }
3270                     else {
3271                         /*
3272                          * Not CR,LF but just CR
3273                          */
3274                         nl++;
3275                         goto scan;
3276                     }
3277                 }
3278                 else {
3279                     /*
3280                      * Blast - found CR as last char in buffer
3281                      */
3282                     if (b->ptr < nl) {
3283                         /*
3284                          * They may not care, defer work as long as
3285                          * possible
3286                          */
3287                         return (nl - b->ptr);
3288                     }
3289                     else {
3290                         int code;
3291                         b->ptr++;       /* say we have read it as far as
3292                                          * flush() is concerned */
3293                         b->buf++;       /* Leave space an front of buffer */
3294                         b->bufsiz--;    /* Buffer is thus smaller */
3295                         code = PerlIO_fill(f);  /* Fetch some more */
3296                         b->bufsiz++;    /* Restore size for next time */
3297                         b->buf--;       /* Point at space */
3298                         b->ptr = nl = b->buf;   /* Which is what we hand
3299                                                  * off */
3300                         b->posn--;      /* Buffer starts here */
3301                         *nl = 0xd;      /* Fill in the CR */
3302                         if (code == 0)
3303                             goto test;  /* fill() call worked */
3304                         /*
3305                          * CR at EOF - just fall through
3306                          */
3307                     }
3308                 }
3309             }
3310         }
3311         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3312     }
3313     return 0;
3314 }
3315
3316 void
3317 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3318 {
3319     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3320     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3321     IV flags = PerlIOBase(f)->flags;
3322     if (!b->buf)
3323         PerlIO_get_base(f);
3324     if (!ptr) {
3325         if (c->nl)
3326             ptr = c->nl + 1;
3327         else {
3328             ptr = b->end;
3329             if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3330                 ptr--;
3331         }
3332         ptr -= cnt;
3333     }
3334     else {
3335         /*
3336          * Test code - delete when it works ...
3337          */
3338         STDCHAR *chk;
3339         if (c->nl)
3340             chk = c->nl + 1;
3341         else {
3342             chk = b->end;
3343             if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3344                 chk--;
3345         }
3346         chk -= cnt;
3347
3348         if (ptr != chk) {
3349             dTHX;
3350             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3351                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3352                        b->end, cnt);
3353         }
3354     }
3355     if (c->nl) {
3356         if (ptr > c->nl) {
3357             /*
3358              * They have taken what we lied about
3359              */
3360             *(c->nl) = 0xd;
3361             c->nl = NULL;
3362             ptr++;
3363         }
3364     }
3365     b->ptr = ptr;
3366     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3367 }
3368
3369 SSize_t
3370 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3371 {
3372     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3373         return PerlIOBuf_write(f, vbuf, count);
3374     else {
3375         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3376         const STDCHAR *buf = (const STDCHAR *) vbuf;
3377         const STDCHAR *ebuf = buf + count;
3378         if (!b->buf)
3379             PerlIO_get_base(f);
3380         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3381             return 0;
3382         while (buf < ebuf) {
3383             STDCHAR *eptr = b->buf + b->bufsiz;
3384             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3385             while (buf < ebuf && b->ptr < eptr) {
3386                 if (*buf == '\n') {
3387                     if ((b->ptr + 2) > eptr) {
3388                         /*
3389                          * Not room for both
3390                          */
3391                         PerlIO_flush(f);
3392                         break;
3393                     }
3394                     else {
3395                         *(b->ptr)++ = 0xd;      /* CR */
3396                         *(b->ptr)++ = 0xa;      /* LF */
3397                         buf++;
3398                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3399                             PerlIO_flush(f);
3400                             break;
3401                         }
3402                     }
3403                 }
3404                 else {
3405                     int ch = *buf++;
3406                     *(b->ptr)++ = ch;
3407                 }
3408                 if (b->ptr >= eptr) {
3409                     PerlIO_flush(f);
3410                     break;
3411                 }
3412             }
3413         }
3414         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3415             PerlIO_flush(f);
3416         return (buf - (STDCHAR *) vbuf);
3417     }
3418 }
3419
3420 IV
3421 PerlIOCrlf_flush(PerlIO *f)
3422 {
3423     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3424     if (c->nl) {
3425         *(c->nl) = 0xd;
3426         c->nl = NULL;
3427     }
3428     return PerlIOBuf_flush(f);
3429 }
3430
3431 PerlIO_funcs PerlIO_crlf = {
3432     "crlf",
3433     sizeof(PerlIOCrlf),
3434     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3435     PerlIOCrlf_pushed,
3436     PerlIOBase_noop_ok,         /* popped */
3437     PerlIOBuf_open,
3438     NULL,
3439     PerlIOBase_fileno,
3440     PerlIOBuf_dup,
3441     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3442                                  * ... */
3443     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3444     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3445     PerlIOBuf_seek,
3446     PerlIOBuf_tell,
3447     PerlIOBuf_close,
3448     PerlIOCrlf_flush,
3449     PerlIOBuf_fill,
3450     PerlIOBase_eof,
3451     PerlIOBase_error,
3452     PerlIOBase_clearerr,
3453     PerlIOBase_setlinebuf,
3454     PerlIOBuf_get_base,
3455     PerlIOBuf_bufsiz,
3456     PerlIOBuf_get_ptr,
3457     PerlIOCrlf_get_cnt,
3458     PerlIOCrlf_set_ptrcnt,
3459 };
3460
3461 #ifdef HAS_MMAP
3462 /*--------------------------------------------------------------------------------------*/
3463 /*
3464  * mmap as "buffer" layer
3465  */
3466
3467 typedef struct {
3468     PerlIOBuf base;             /* PerlIOBuf stuff */
3469     Mmap_t mptr;                /* Mapped address */
3470     Size_t len;                 /* mapped length */
3471     STDCHAR *bbuf;              /* malloced buffer if map fails */
3472 } PerlIOMmap;
3473
3474 static size_t page_size = 0;
3475
3476 IV
3477 PerlIOMmap_map(PerlIO *f)
3478 {
3479     dTHX;
3480     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3481     IV flags = PerlIOBase(f)->flags;
3482     IV code = 0;
3483     if (m->len)
3484         abort();
3485     if (flags & PERLIO_F_CANREAD) {
3486         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3487         int fd = PerlIO_fileno(f);
3488         struct stat st;
3489         code = fstat(fd, &st);
3490         if (code == 0 && S_ISREG(st.st_mode)) {
3491             SSize_t len = st.st_size - b->posn;
3492             if (len > 0) {
3493                 Off_t posn;
3494                 if (!page_size) {
3495 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3496                     {
3497                         SETERRNO(0, SS$_NORMAL);
3498 #   ifdef _SC_PAGESIZE
3499                         page_size = sysconf(_SC_PAGESIZE);
3500 #   else
3501                         page_size = sysconf(_SC_PAGE_SIZE);
3502 #   endif
3503                         if ((long) page_size < 0) {
3504                             if (errno) {
3505                                 SV *error = ERRSV;
3506                                 char *msg;
3507                                 STRLEN n_a;
3508                                 (void) SvUPGRADE(error, SVt_PV);
3509                                 msg = SvPVx(error, n_a);
3510                                 Perl_croak(aTHX_ "panic: sysconf: %s",
3511                                            msg);
3512                             }
3513                             else
3514                                 Perl_croak(aTHX_
3515                                            "panic: sysconf: pagesize unknown");
3516                         }
3517                     }
3518 #else
3519 #   ifdef HAS_GETPAGESIZE
3520                     page_size = getpagesize();
3521 #   else
3522 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3523                     page_size = PAGESIZE;       /* compiletime, bad */
3524 #       endif
3525 #   endif
3526 #endif
3527                     if ((IV) page_size <= 0)
3528                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3529                                    (IV) page_size);
3530                 }
3531                 if (b->posn < 0) {
3532                     /*
3533                      * This is a hack - should never happen - open should
3534                      * have set it !
3535                      */
3536                     b->posn = PerlIO_tell(PerlIONext(f));
3537                 }
3538                 posn = (b->posn / page_size) * page_size;
3539                 len = st.st_size - posn;
3540                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3541                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3542 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3543                     madvise(m->mptr, len, MADV_SEQUENTIAL);
3544 #endif
3545 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3546                     madvise(m->mptr, len, MADV_WILLNEED);
3547 #endif
3548                     PerlIOBase(f)->flags =
3549                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3550                     b->end = ((STDCHAR *) m->mptr) + len;
3551                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3552                     b->ptr = b->buf;
3553                     m->len = len;
3554                 }
3555                 else {
3556                     b->buf = NULL;
3557                 }
3558             }
3559             else {
3560                 PerlIOBase(f)->flags =
3561                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3562                 b->buf = NULL;
3563                 b->ptr = b->end = b->ptr;
3564                 code = -1;
3565             }
3566         }
3567     }
3568     return code;
3569 }
3570
3571 IV
3572 PerlIOMmap_unmap(PerlIO *f)
3573 {
3574     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3575     PerlIOBuf *b = &m->base;
3576     IV code = 0;
3577     if (m->len) {
3578         if (b->buf) {
3579             code = munmap(m->mptr, m->len);
3580             b->buf = NULL;
3581             m->len = 0;
3582             m->mptr = NULL;
3583             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3584                 code = -1;
3585         }
3586         b->ptr = b->end = b->buf;
3587         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3588     }
3589     return code;
3590 }
3591
3592 STDCHAR *
3593 PerlIOMmap_get_base(PerlIO *f)
3594 {
3595     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3596     PerlIOBuf *b = &m->base;
3597     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3598         /*
3599          * Already have a readbuffer in progress
3600          */
3601         return b->buf;
3602     }
3603     if (b->buf) {
3604         /*
3605          * We have a write buffer or flushed PerlIOBuf read buffer
3606          */
3607         m->bbuf = b->buf;       /* save it in case we need it again */
3608         b->buf = NULL;          /* Clear to trigger below */
3609     }
3610     if (!b->buf) {
3611         PerlIOMmap_map(f);      /* Try and map it */
3612         if (!b->buf) {
3613             /*
3614              * Map did not work - recover PerlIOBuf buffer if we have one
3615              */
3616             b->buf = m->bbuf;
3617         }
3618     }
3619     b->ptr = b->end = b->buf;
3620     if (b->buf)
3621         return b->buf;
3622     return PerlIOBuf_get_base(f);
3623 }
3624
3625 SSize_t
3626 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3627 {
3628     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3629     PerlIOBuf *b = &m->base;
3630     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3631         PerlIO_flush(f);
3632     if (b->ptr && (b->ptr - count) >= b->buf
3633         && memEQ(b->ptr - count, vbuf, count)) {
3634         b->ptr -= count;
3635         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3636         return count;
3637     }
3638     if (m->len) {
3639         /*
3640          * Loose the unwritable mapped buffer
3641          */
3642         PerlIO_flush(f);
3643         /*
3644          * If flush took the "buffer" see if we have one from before
3645          */
3646         if (!b->buf && m->bbuf)
3647             b->buf = m->bbuf;
3648         if (!b->buf) {
3649             PerlIOBuf_get_base(f);
3650             m->bbuf = b->buf;
3651         }
3652     }
3653     return PerlIOBuf_unread(f, vbuf, count);
3654 }
3655
3656 SSize_t
3657 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3658 {
3659     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3660     PerlIOBuf *b = &m->base;
3661     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3662         /*
3663          * No, or wrong sort of, buffer
3664          */
3665         if (m->len) {
3666             if (PerlIOMmap_unmap(f) != 0)
3667                 return 0;
3668         }
3669         /*
3670          * If unmap took the "buffer" see if we have one from before
3671          */
3672         if (!b->buf && m->bbuf)
3673             b->buf = m->bbuf;
3674         if (!b->buf) {
3675             PerlIOBuf_get_base(f);
3676             m->bbuf = b->buf;
3677         }
3678     }
3679     return PerlIOBuf_write(f, vbuf, count);
3680 }
3681
3682 IV
3683 PerlIOMmap_flush(PerlIO *f)
3684 {
3685     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3686     PerlIOBuf *b = &m->base;
3687     IV code = PerlIOBuf_flush(f);
3688     /*
3689      * Now we are "synced" at PerlIOBuf level
3690      */
3691     if (b->buf) {
3692         if (m->len) {
3693             /*
3694              * Unmap the buffer
3695              */
3696             if (PerlIOMmap_unmap(f) != 0)
3697                 code = -1;
3698         }
3699         else {
3700             /*
3701              * We seem to have a PerlIOBuf buffer which was not mapped
3702              * remember it in case we need one later
3703              */
3704             m->bbuf = b->buf;
3705         }
3706     }
3707     return code;
3708 }
3709
3710 IV
3711 PerlIOMmap_fill(PerlIO *f)
3712 {
3713     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3714     IV code = PerlIO_flush(f);
3715     if (code == 0 && !b->buf) {
3716         code = PerlIOMmap_map(f);
3717     }
3718     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3719         code = PerlIOBuf_fill(f);
3720     }
3721     return code;
3722 }
3723
3724 IV
3725 PerlIOMmap_close(PerlIO *f)
3726 {
3727     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3728     PerlIOBuf *b = &m->base;
3729     IV code = PerlIO_flush(f);
3730     if (m->bbuf) {
3731         b->buf = m->bbuf;
3732         m->bbuf = NULL;
3733         b->ptr = b->end = b->buf;
3734     }
3735     if (PerlIOBuf_close(f) != 0)
3736         code = -1;
3737     return code;
3738 }
3739
3740 PerlIO *
3741 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
3742 {
3743  return NULL;
3744 }
3745
3746
3747 PerlIO_funcs PerlIO_mmap = {
3748     "mmap",
3749     sizeof(PerlIOMmap),
3750     PERLIO_K_BUFFERED,
3751     PerlIOBuf_pushed,
3752     PerlIOBase_noop_ok,
3753     PerlIOBuf_open,
3754     NULL,
3755     PerlIOBase_fileno,
3756     PerlIOMmap_dup,
3757     PerlIOBuf_read,
3758     PerlIOMmap_unread,
3759     PerlIOMmap_write,
3760     PerlIOBuf_seek,
3761     PerlIOBuf_tell,
3762     PerlIOBuf_close,
3763     PerlIOMmap_flush,
3764     PerlIOMmap_fill,
3765     PerlIOBase_eof,
3766     PerlIOBase_error,
3767     PerlIOBase_clearerr,
3768     PerlIOBase_setlinebuf,
3769     PerlIOMmap_get_base,
3770     PerlIOBuf_bufsiz,
3771     PerlIOBuf_get_ptr,
3772     PerlIOBuf_get_cnt,
3773     PerlIOBuf_set_ptrcnt,
3774 };
3775
3776 #endif                          /* HAS_MMAP */
3777
3778 void
3779 PerlIO_init(void)
3780 {
3781     dTHX;
3782 #ifndef WIN32
3783     call_atexit(PerlIO_cleanup_layers, NULL);
3784 #endif
3785     if (!_perlio) {
3786 #ifndef WIN32
3787         atexit(&PerlIO_cleanup);
3788 #endif
3789     }
3790 }
3791
3792 #undef PerlIO_stdin
3793 PerlIO *
3794 PerlIO_stdin(void)
3795 {
3796     if (!_perlio) {
3797         dTHX;
3798         PerlIO_stdstreams(aTHX);
3799     }
3800     return &_perlio[1];
3801 }
3802
3803 #undef PerlIO_stdout
3804 PerlIO *
3805 PerlIO_stdout(void)
3806 {
3807     if (!_perlio) {
3808         dTHX;
3809         PerlIO_stdstreams(aTHX);
3810     }
3811     return &_perlio[2];
3812 }
3813
3814 #undef PerlIO_stderr
3815 PerlIO *
3816 PerlIO_stderr(void)
3817 {
3818     if (!_perlio) {
3819         dTHX;
3820         PerlIO_stdstreams(aTHX);
3821     }
3822     return &_perlio[3];
3823 }
3824
3825 /*--------------------------------------------------------------------------------------*/
3826
3827 #undef PerlIO_getname
3828 char *
3829 PerlIO_getname(PerlIO *f, char *buf)
3830 {
3831     dTHX;
3832     char *name = NULL;
3833 #ifdef VMS
3834     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3835     if (stdio)
3836         name = fgetname(stdio, buf);
3837 #else
3838     Perl_croak(aTHX_ "Don't know how to get file name");
3839 #endif
3840     return name;
3841 }
3842
3843
3844 /*--------------------------------------------------------------------------------------*/
3845 /*
3846  * Functions which can be called on any kind of PerlIO implemented in
3847  * terms of above
3848  */
3849
3850 #undef PerlIO_getc
3851 int
3852 PerlIO_getc(PerlIO *f)
3853 {
3854     STDCHAR buf[1];
3855     SSize_t count = PerlIO_read(f, buf, 1);
3856     if (count == 1) {
3857         return (unsigned char) buf[0];
3858     }
3859     return EOF;
3860 }
3861
3862 #undef PerlIO_ungetc
3863 int
3864 PerlIO_ungetc(PerlIO *f, int ch)
3865 {
3866     if (ch != EOF) {
3867         STDCHAR buf = ch;
3868         if (PerlIO_unread(f, &buf, 1) == 1)
3869             return ch;
3870     }
3871     return EOF;
3872 }
3873
3874 #undef PerlIO_putc
3875 int
3876 PerlIO_putc(PerlIO *f, int ch)
3877 {
3878     STDCHAR buf = ch;
3879     return PerlIO_write(f, &buf, 1);
3880 }
3881
3882 #undef PerlIO_puts
3883 int
3884 PerlIO_puts(PerlIO *f, const char *s)
3885 {
3886     STRLEN len = strlen(s);
3887     return PerlIO_write(f, s, len);
3888 }
3889
3890 #undef PerlIO_rewind
3891 void
3892 PerlIO_rewind(PerlIO *f)
3893 {
3894     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
3895     PerlIO_clearerr(f);
3896 }
3897
3898 #undef PerlIO_vprintf
3899 int
3900 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3901 {
3902     dTHX;
3903     SV *sv = newSVpvn("", 0);
3904     char *s;
3905     STRLEN len;
3906     SSize_t wrote;
3907 #ifdef NEED_VA_COPY
3908     va_list apc;
3909     Perl_va_copy(ap, apc);
3910     sv_vcatpvf(sv, fmt, &apc);
3911 #else
3912     sv_vcatpvf(sv, fmt, &ap);
3913 #endif
3914     s = SvPV(sv, len);
3915     wrote = PerlIO_write(f, s, len);
3916     SvREFCNT_dec(sv);
3917     return wrote;
3918 }
3919
3920 #undef PerlIO_printf
3921 int
3922 PerlIO_printf(PerlIO *f, const char *fmt, ...)
3923 {
3924     va_list ap;
3925     int result;
3926     va_start(ap, fmt);
3927     result = PerlIO_vprintf(f, fmt, ap);
3928     va_end(ap);
3929     return result;
3930 }
3931
3932 #undef PerlIO_stdoutf
3933 int
3934 PerlIO_stdoutf(const char *fmt, ...)
3935 {
3936     va_list ap;
3937     int result;
3938     va_start(ap, fmt);
3939     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
3940     va_end(ap);
3941     return result;
3942 }
3943
3944 #undef PerlIO_tmpfile
3945 PerlIO *
3946 PerlIO_tmpfile(void)
3947 {
3948     /*
3949      * I have no idea how portable mkstemp() is ...
3950      */
3951 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3952     dTHX;
3953     PerlIO *f = NULL;
3954     FILE *stdio = PerlSIO_tmpfile();
3955     if (stdio) {
3956         PerlIOStdio *s =
3957             PerlIOSelf(PerlIO_push
3958                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
3959                         "w+", Nullsv), PerlIOStdio);
3960         s->stdio = stdio;
3961     }
3962     return f;
3963 #else
3964     dTHX;
3965     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
3966     int fd = mkstemp(SvPVX(sv));
3967     PerlIO *f = NULL;
3968     if (fd >= 0) {
3969         f = PerlIO_fdopen(fd, "w+");
3970         if (f) {
3971             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3972         }
3973         PerlLIO_unlink(SvPVX(sv));
3974         SvREFCNT_dec(sv);
3975     }
3976     return f;
3977 #endif
3978 }
3979
3980 #undef HAS_FSETPOS
3981 #undef HAS_FGETPOS
3982
3983 #endif                          /* USE_SFIO */
3984 #endif                          /* PERLIO_IS_STDIO */
3985
3986 /*======================================================================================*/
3987 /*
3988  * Now some functions in terms of above which may be needed even if we are
3989  * not in true PerlIO mode
3990  */
3991
3992 #ifndef HAS_FSETPOS
3993 #undef PerlIO_setpos
3994 int
3995 PerlIO_setpos(PerlIO *f, SV *pos)
3996 {
3997     dTHX;
3998     if (SvOK(pos)) {
3999         STRLEN len;
4000         Off_t *posn = (Off_t *) SvPV(pos, len);
4001         if (f && len == sizeof(Off_t))
4002             return PerlIO_seek(f, *posn, SEEK_SET);
4003     }
4004     SETERRNO(EINVAL, SS$_IVCHAN);
4005     return -1;
4006 }
4007 #else
4008 #undef PerlIO_setpos
4009 int
4010 PerlIO_setpos(PerlIO *f, SV *pos)
4011 {
4012     dTHX;
4013     if (SvOK(pos)) {
4014         STRLEN len;
4015         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4016         if (f && len == sizeof(Fpos_t)) {
4017 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4018             return fsetpos64(f, fpos);
4019 #else
4020             return fsetpos(f, fpos);
4021 #endif
4022         }
4023     }
4024     SETERRNO(EINVAL, SS$_IVCHAN);
4025     return -1;
4026 }
4027 #endif
4028
4029 #ifndef HAS_FGETPOS
4030 #undef PerlIO_getpos
4031 int
4032 PerlIO_getpos(PerlIO *f, SV *pos)
4033 {
4034     dTHX;
4035     Off_t posn = PerlIO_tell(f);
4036     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4037     return (posn == (Off_t) - 1) ? -1 : 0;
4038 }
4039 #else
4040 #undef PerlIO_getpos
4041 int
4042 PerlIO_getpos(PerlIO *f, SV *pos)
4043 {
4044     dTHX;
4045     Fpos_t fpos;
4046     int code;
4047 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4048     code = fgetpos64(f, &fpos);
4049 #else
4050     code = fgetpos(f, &fpos);
4051 #endif
4052     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4053     return code;
4054 }
4055 #endif
4056
4057 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4058
4059 int
4060 vprintf(char *pat, char *args)
4061 {
4062     _doprnt(pat, args, stdout);
4063     return 0;                   /* wrong, but perl doesn't use the return
4064                                  * value */
4065 }
4066
4067 int
4068 vfprintf(FILE *fd, char *pat, char *args)
4069 {
4070     _doprnt(pat, args, fd);
4071     return 0;                   /* wrong, but perl doesn't use the return
4072                                  * value */
4073 }
4074
4075 #endif
4076
4077 #ifndef PerlIO_vsprintf
4078 int
4079 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4080 {
4081     int val = vsprintf(s, fmt, ap);
4082     if (n >= 0) {
4083         if (strlen(s) >= (STRLEN) n) {
4084             dTHX;
4085             (void) PerlIO_puts(Perl_error_log,
4086                                "panic: sprintf overflow - memory corrupted!\n");
4087             my_exit(1);
4088         }
4089     }
4090     return val;
4091 }
4092 #endif
4093
4094 #ifndef PerlIO_sprintf
4095 int
4096 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4097 {
4098     va_list ap;
4099     int result;
4100     va_start(ap, fmt);
4101     result = PerlIO_vsprintf(s, n, fmt, ap);
4102     va_end(ap);
4103     return result;
4104 }
4105 #endif