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