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