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