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