perlio.c

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