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