perlio.c

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