perlio.c

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