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         mode = "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         PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1020                      (mode) ? mode : "(Null)", (void*)arg);
1021         if ((*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
1022             return NULL;
1023         }
1024     }
1025     return f;
1026 }
1027
1028 IV
1029 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1030 {
1031     PerlIO_pop(aTHX_ f);
1032     if (*f) {
1033         PerlIO_flush(f);
1034         PerlIO_pop(aTHX_ f);
1035         return 0;
1036     }
1037     return -1;
1038 }
1039
1040 IV
1041 PerlIOBase_binmode(pTHX_ PerlIO *f)
1042 {
1043    if (PerlIOValid(f)) {
1044         /* Is layer suitable for raw stream ? */
1045         if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1046             /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1047             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1048         }
1049         else {
1050             /* Not suitable - pop it */
1051             PerlIO_pop(aTHX_ f);
1052         }
1053         return 0;
1054    }
1055    return -1;
1056 }
1057
1058 IV
1059 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1060 {
1061
1062     if (PerlIOValid(f)) {
1063         PerlIO *t;
1064         PerlIOl *l;
1065         PerlIO_flush(f);
1066         /*
1067          * Strip all layers that are not suitable for a raw stream
1068          */
1069         t = f;
1070         while (t && (l = *t)) {
1071             if (l->tab->Binmode) {
1072                 /* Has a handler - normal case */
1073                 if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1074                     if (*t == l) {
1075                         /* Layer still there - move down a layer */
1076                         t = PerlIONext(t);
1077                     }
1078                 }
1079                 else {
1080                     return -1;
1081                 }
1082             }
1083             else {
1084                 /* No handler - pop it */
1085                 PerlIO_pop(aTHX_ t);
1086             }
1087         }
1088         if (PerlIOValid(f)) {
1089             PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1090             return 0;
1091         }
1092     }
1093     return -1;
1094 }
1095
1096 int
1097 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1098                     PerlIO_list_t *layers, IV n, IV max)
1099 {
1100     int code = 0;
1101     while (n < max) {
1102         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1103         if (tab) {
1104             if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1105                 code = -1;
1106                 break;
1107             }
1108         }
1109         n++;
1110     }
1111     return code;
1112 }
1113
1114 int
1115 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1116 {
1117     int code = 0;
1118     if (f && names) {
1119         PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1120         code = PerlIO_parse_layers(aTHX_ layers, names);
1121         if (code == 0) {
1122             code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1123         }
1124         PerlIO_list_free(aTHX_ layers);
1125     }
1126     return code;
1127 }
1128
1129
1130 /*--------------------------------------------------------------------------------------*/
1131 /*
1132  * Given the abstraction above the public API functions
1133  */
1134
1135 int
1136 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1137 {
1138     PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1139                  (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1140                  (names) ? names : "(Null)");
1141     if (names) {
1142         /* Do not flush etc. if (e.g.) switching encodings.
1143            if a pushed layer knows it needs to flush lower layers
1144            (for example :unix which is never going to call them)
1145            it can do the flush when it is pushed.
1146          */
1147         return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1148     }
1149     else {
1150         /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1151 #ifdef PERLIO_USING_CRLF
1152         /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1153            O_BINARY so we can look for it in mode.
1154          */
1155         if (!(mode & O_BINARY)) {
1156             /* Text mode */
1157             /* FIXME?: Looking down the layer stack seems wrong,
1158                but is a way of reaching past (say) an encoding layer
1159                to flip CRLF-ness of the layer(s) below
1160              */
1161             while (*f) {
1162                 /* Perhaps we should turn on bottom-most aware layer
1163                    e.g. Ilya's idea that UNIX TTY could serve
1164                  */
1165                 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1166                     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1167                         /* Not in text mode - flush any pending stuff and flip it */
1168                         PerlIO_flush(f);
1169                         PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1170                     }
1171                     /* Only need to turn it on in one layer so we are done */
1172                     return TRUE;
1173                 }
1174                 f = PerlIONext(f);
1175             }
1176             /* Not finding a CRLF aware layer presumably means we are binary
1177                which is not what was requested - so we failed
1178                We _could_ push :crlf layer but so could caller
1179              */
1180             return FALSE;
1181         }
1182 #endif
1183         /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1184            So code that used to be here is now in PerlIORaw_pushed().
1185          */
1186         return PerlIO_push(aTHX_ f, &PerlIO_raw, Nullch, Nullsv) ? TRUE : FALSE;
1187     }
1188 }
1189
1190 int
1191 PerlIO__close(pTHX_ PerlIO *f)
1192 {
1193     if (PerlIOValid(f))
1194         return (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1195     else {
1196         SETERRNO(EBADF, SS$_IVCHAN);
1197         return -1;
1198     }
1199 }
1200
1201 int
1202 Perl_PerlIO_close(pTHX_ PerlIO *f)
1203 {
1204     int code = -1;
1205     if (PerlIOValid(f)) {
1206         code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1207         while (*f) {
1208             PerlIO_pop(aTHX_ f);
1209         }
1210     }
1211     return code;
1212 }
1213
1214 int
1215 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1216 {
1217     if (PerlIOValid(f))
1218         return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
1219     else {
1220         SETERRNO(EBADF, SS$_IVCHAN);
1221         return -1;
1222     }
1223 }
1224
1225 static const char *
1226 PerlIO_context_layers(pTHX_ const char *mode)
1227 {
1228     const char *type = NULL;
1229     /*
1230      * Need to supply default layer info from open.pm
1231      */
1232     if (PL_curcop) {
1233         SV *layers = PL_curcop->cop_io;
1234         if (layers) {
1235             STRLEN len;
1236             type = SvPV(layers, len);
1237             if (type && mode[0] != 'r') {
1238                 /*
1239                  * Skip to write part
1240                  */
1241                 const char *s = strchr(type, 0);
1242                 if (s && (STRLEN)(s - type) < len) {
1243                     type = s + 1;
1244                 }
1245             }
1246         }
1247     }
1248     return type;
1249 }
1250
1251 static PerlIO_funcs *
1252 PerlIO_layer_from_ref(pTHX_ SV *sv)
1253 {
1254     /*
1255      * For any scalar type load the handler which is bundled with perl
1256      */
1257     if (SvTYPE(sv) < SVt_PVAV)
1258         return PerlIO_find_layer(aTHX_ "scalar", 6, 1);
1259
1260     /*
1261      * For other types allow if layer is known but don't try and load it
1262      */
1263     switch (SvTYPE(sv)) {
1264     case SVt_PVAV:
1265         return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1266     case SVt_PVHV:
1267         return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1268     case SVt_PVCV:
1269         return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1270     case SVt_PVGV:
1271         return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1272     }
1273     return NULL;
1274 }
1275
1276 PerlIO_list_t *
1277 PerlIO_resolve_layers(pTHX_ const char *layers,
1278                       const char *mode, int narg, SV **args)
1279 {
1280     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1281     int incdef = 1;
1282     if (!PL_perlio)
1283         PerlIO_stdstreams(aTHX);
1284     if (narg) {
1285         SV *arg = *args;
1286         /*
1287          * If it is a reference but not an object see if we have a handler
1288          * for it
1289          */
1290         if (SvROK(arg) && !sv_isobject(arg)) {
1291             PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1292             if (handler) {
1293                 def = PerlIO_list_alloc(aTHX);
1294                 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1295                 incdef = 0;
1296             }
1297             /*
1298              * Don't fail if handler cannot be found :via(...) etc. may do
1299              * something sensible else we will just stringfy and open
1300              * resulting string.
1301              */
1302         }
1303     }
1304     if (!layers)
1305         layers = PerlIO_context_layers(aTHX_ mode);
1306     if (layers && *layers) {
1307         PerlIO_list_t *av;
1308         if (incdef) {
1309             IV i = def->cur;
1310             av = PerlIO_list_alloc(aTHX);
1311             for (i = 0; i < def->cur; i++) {
1312                 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1313                                  def->array[i].arg);
1314             }
1315         }
1316         else {
1317             av = def;
1318         }
1319         if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1320              return av;
1321         }
1322         else {
1323             PerlIO_list_free(aTHX_ av);
1324             return (PerlIO_list_t *) NULL;
1325         }
1326     }
1327     else {
1328         if (incdef)
1329             def->refcnt++;
1330         return def;
1331     }
1332 }
1333
1334 PerlIO *
1335 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1336              int imode, int perm, PerlIO *f, int narg, SV **args)
1337 {
1338     if (!f && narg == 1 && *args == &PL_sv_undef) {
1339         if ((f = PerlIO_tmpfile())) {
1340             if (!layers)
1341                 layers = PerlIO_context_layers(aTHX_ mode);
1342             if (layers && *layers)
1343                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1344         }
1345     }
1346     else {
1347         PerlIO_list_t *layera = NULL;
1348         IV n;
1349         PerlIO_funcs *tab = NULL;
1350         if (PerlIOValid(f)) {
1351             /*
1352              * This is "reopen" - it is not tested as perl does not use it
1353              * yet
1354              */
1355             PerlIOl *l = *f;
1356             layera = PerlIO_list_alloc(aTHX);
1357             while (l) {
1358                 SV *arg = (l->tab->Getarg)
1359                         ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1360                         : &PL_sv_undef;
1361                 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1362                 l = *PerlIONext(&l);
1363             }
1364         }
1365         else {
1366             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1367             if (!layera) {
1368                 return NULL;
1369             }
1370         }
1371         /*
1372          * Start at "top" of layer stack
1373          */
1374         n = layera->cur - 1;
1375         while (n >= 0) {
1376             PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1377             if (t && t->Open) {
1378                 tab = t;
1379                 break;
1380             }
1381             n--;
1382         }
1383         if (tab) {
1384             /*
1385              * Found that layer 'n' can do opens - call it
1386              */
1387             if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1388                 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1389             }
1390             PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1391                          tab->name, layers, mode, fd, imode, perm,
1392                          (void*)f, narg, (void*)args);
1393             f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1394                               f, narg, args);
1395             if (f) {
1396                 if (n + 1 < layera->cur) {
1397                     /*
1398                      * More layers above the one that we used to open -
1399                      * apply them now
1400                      */
1401                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1402                         /* If pushing layers fails close the file */
1403                         PerlIO_close(f);
1404                         f = NULL;
1405                     }
1406                 }
1407             }
1408         }
1409         PerlIO_list_free(aTHX_ layera);
1410     }
1411     return f;
1412 }
1413
1414
1415 SSize_t
1416 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1417 {
1418     if (PerlIOValid(f))
1419         return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
1420     else {
1421         SETERRNO(EBADF, SS$_IVCHAN);
1422         return -1;
1423     }
1424 }
1425
1426 SSize_t
1427 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1428 {
1429     if (PerlIOValid(f))
1430         return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
1431     else {
1432         SETERRNO(EBADF, SS$_IVCHAN);
1433         return -1;
1434     }
1435 }
1436
1437 SSize_t
1438 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1439 {
1440     if (PerlIOValid(f))
1441         return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
1442     else {
1443         SETERRNO(EBADF, SS$_IVCHAN);
1444         return -1;
1445     }
1446 }
1447
1448 int
1449 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1450 {
1451     if (PerlIOValid(f))
1452         return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
1453     else {
1454         SETERRNO(EBADF, SS$_IVCHAN);
1455         return -1;
1456     }
1457 }
1458
1459 Off_t
1460 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1461 {
1462     if (PerlIOValid(f))
1463         return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
1464     else {
1465         SETERRNO(EBADF, SS$_IVCHAN);
1466         return -1;
1467     }
1468 }
1469
1470 int
1471 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1472 {
1473     if (f) {
1474         if (*f) {
1475             PerlIO_funcs *tab = PerlIOBase(f)->tab;
1476             if (tab && tab->Flush) {
1477                 return (*tab->Flush) (aTHX_ f);
1478             }
1479             else {
1480                 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
1481                 SETERRNO(EBADF, SS$_IVCHAN);
1482                 return -1;
1483             }
1484         }
1485         else {
1486             PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1487             SETERRNO(EBADF, SS$_IVCHAN);
1488             return -1;
1489         }
1490     }
1491     else {
1492         /*
1493          * Is it good API design to do flush-all on NULL, a potentially
1494          * errorneous input? Maybe some magical value (PerlIO*
1495          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1496          * things on fflush(NULL), but should we be bound by their design
1497          * decisions? --jhi
1498          */
1499         PerlIO **table = &PL_perlio;
1500         int code = 0;
1501         while ((f = *table)) {
1502             int i;
1503             table = (PerlIO **) (f++);
1504             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1505                 if (*f && PerlIO_flush(f) != 0)
1506                     code = -1;
1507                 f++;
1508             }
1509         }
1510         return code;
1511     }
1512 }
1513
1514 void
1515 PerlIOBase_flush_linebuf(pTHX)
1516 {
1517     PerlIO **table = &PL_perlio;
1518     PerlIO *f;
1519     while ((f = *table)) {
1520         int i;
1521         table = (PerlIO **) (f++);
1522         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1523             if (*f
1524                 && (PerlIOBase(f)->
1525                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1526                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1527                 PerlIO_flush(f);
1528             f++;
1529         }
1530     }
1531 }
1532
1533 int
1534 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1535 {
1536     if (PerlIOValid(f))
1537         return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
1538     else {
1539         SETERRNO(EBADF, SS$_IVCHAN);
1540         return -1;
1541     }
1542 }
1543
1544 int
1545 PerlIO_isutf8(PerlIO *f)
1546 {
1547     if (PerlIOValid(f))
1548         return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1549     else {
1550         SETERRNO(EBADF, SS$_IVCHAN);
1551         return -1;
1552     }
1553 }
1554
1555 int
1556 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1557 {
1558     if (PerlIOValid(f))
1559         return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
1560     else {
1561         SETERRNO(EBADF, SS$_IVCHAN);
1562         return -1;
1563     }
1564 }
1565
1566 int
1567 Perl_PerlIO_error(pTHX_ PerlIO *f)
1568 {
1569     if (PerlIOValid(f))
1570         return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
1571     else {
1572         SETERRNO(EBADF, SS$_IVCHAN);
1573         return -1;
1574     }
1575 }
1576
1577 void
1578 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1579 {
1580     if (PerlIOValid(f))
1581         (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
1582     else
1583         SETERRNO(EBADF, SS$_IVCHAN);
1584 }
1585
1586 void
1587 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1588 {
1589     if (PerlIOValid(f))
1590         (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
1591     else
1592         SETERRNO(EBADF, SS$_IVCHAN);
1593 }
1594
1595 int
1596 PerlIO_has_base(PerlIO *f)
1597 {
1598     if (PerlIOValid(f)) {
1599         return (PerlIOBase(f)->tab->Get_base != NULL);
1600     }
1601     return 0;
1602 }
1603
1604 int
1605 PerlIO_fast_gets(PerlIO *f)
1606 {
1607     if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1608         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1609         return (tab->Set_ptrcnt != NULL);
1610     }
1611     return 0;
1612 }
1613
1614 int
1615 PerlIO_has_cntptr(PerlIO *f)
1616 {
1617     if (PerlIOValid(f)) {
1618         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1619         return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1620     }
1621     return 0;
1622 }
1623
1624 int
1625 PerlIO_canset_cnt(PerlIO *f)
1626 {
1627     if (PerlIOValid(f)) {
1628         PerlIOl *l = PerlIOBase(f);
1629         return (l->tab->Set_ptrcnt != NULL);
1630     }
1631     return 0;
1632 }
1633
1634 STDCHAR *
1635 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1636 {
1637     if (PerlIOValid(f))
1638         return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
1639     return NULL;
1640 }
1641
1642 int
1643 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1644 {
1645     if (PerlIOValid(f))
1646         return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
1647     return 0;
1648 }
1649
1650 STDCHAR *
1651 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1652 {
1653     if (PerlIOValid(f)) {
1654         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1655         if (tab->Get_ptr == NULL)
1656             return NULL;
1657         return (*tab->Get_ptr) (aTHX_ f);
1658     }
1659     return NULL;
1660 }
1661
1662 int
1663 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1664 {
1665     if (PerlIOValid(f)) {
1666         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1667         if (tab->Get_cnt == NULL)
1668            return 0;
1669         return (*tab->Get_cnt) (aTHX_ f);
1670     }
1671     return 0;
1672 }
1673
1674 void
1675 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1676 {
1677     if (PerlIOValid(f)) {
1678         (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
1679     }
1680 }
1681
1682 void
1683 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1684 {
1685     if (PerlIOValid(f)) {
1686         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1687         if (tab->Set_ptrcnt == NULL) {
1688             Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1689         }
1690         (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
1691     }
1692 }
1693
1694 /*--------------------------------------------------------------------------------------*/
1695 /*
1696  * utf8 and raw dummy layers
1697  */
1698
1699 IV
1700 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1701 {
1702     if (PerlIOValid(f)) {
1703         if (tab->kind & PERLIO_K_UTF8)
1704             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1705         else
1706             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1707         return 0;
1708     }
1709     return -1;
1710 }
1711
1712 PerlIO_funcs PerlIO_utf8 = {
1713     sizeof(PerlIO_funcs),
1714     "utf8",
1715     0,
1716     PERLIO_K_DUMMY | PERLIO_K_UTF8,
1717     PerlIOUtf8_pushed,
1718     NULL,
1719     NULL,
1720     NULL,
1721     NULL,
1722     NULL,
1723     NULL,
1724     NULL,
1725     NULL,
1726     NULL,
1727     NULL,
1728     NULL,                       /* flush */
1729     NULL,                       /* fill */
1730     NULL,
1731     NULL,
1732     NULL,
1733     NULL,
1734     NULL,                       /* get_base */
1735     NULL,                       /* get_bufsiz */
1736     NULL,                       /* get_ptr */
1737     NULL,                       /* get_cnt */
1738     NULL,                       /* set_ptrcnt */
1739 };
1740
1741 PerlIO_funcs PerlIO_byte = {
1742     sizeof(PerlIO_funcs),
1743     "bytes",
1744     0,
1745     PERLIO_K_DUMMY,
1746     PerlIOUtf8_pushed,
1747     NULL,
1748     NULL,
1749     NULL,
1750     NULL,
1751     NULL,
1752     NULL,
1753     NULL,
1754     NULL,
1755     NULL,
1756     NULL,
1757     NULL,                       /* flush */
1758     NULL,                       /* fill */
1759     NULL,
1760     NULL,
1761     NULL,
1762     NULL,
1763     NULL,                       /* get_base */
1764     NULL,                       /* get_bufsiz */
1765     NULL,                       /* get_ptr */
1766     NULL,                       /* get_cnt */
1767     NULL,                       /* set_ptrcnt */
1768 };
1769
1770 PerlIO *
1771 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1772                IV n, const char *mode, int fd, int imode, int perm,
1773                PerlIO *old, int narg, SV **args)
1774 {
1775     PerlIO_funcs *tab = PerlIO_default_btm();
1776     return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1777                          old, narg, args);
1778 }
1779
1780 PerlIO_funcs PerlIO_raw = {
1781     sizeof(PerlIO_funcs),
1782     "raw",
1783     0,
1784     PERLIO_K_DUMMY,
1785     PerlIORaw_pushed,
1786     PerlIOBase_popped,
1787     PerlIORaw_open,
1788     NULL,
1789     NULL,
1790     NULL,
1791     NULL,
1792     NULL,
1793     NULL,
1794     NULL,
1795     NULL,
1796     NULL,                       /* flush */
1797     NULL,                       /* fill */
1798     NULL,
1799     NULL,
1800     NULL,
1801     NULL,
1802     NULL,                       /* get_base */
1803     NULL,                       /* get_bufsiz */
1804     NULL,                       /* get_ptr */
1805     NULL,                       /* get_cnt */
1806     NULL,                       /* set_ptrcnt */
1807 };
1808 /*--------------------------------------------------------------------------------------*/
1809 /*--------------------------------------------------------------------------------------*/
1810 /*
1811  * "Methods" of the "base class"
1812  */
1813
1814 IV
1815 PerlIOBase_fileno(pTHX_ PerlIO *f)
1816 {
1817     return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1818 }
1819
1820 char *
1821 PerlIO_modestr(PerlIO * f, char *buf)
1822 {
1823     char *s = buf;
1824     if (PerlIOValid(f)) {
1825         IV flags = PerlIOBase(f)->flags;
1826         if (flags & PERLIO_F_APPEND) {
1827             *s++ = 'a';
1828             if (flags & PERLIO_F_CANREAD) {
1829                 *s++ = '+';
1830             }
1831         }
1832         else if (flags & PERLIO_F_CANREAD) {
1833             *s++ = 'r';
1834             if (flags & PERLIO_F_CANWRITE)
1835                 *s++ = '+';
1836         }
1837         else if (flags & PERLIO_F_CANWRITE) {
1838             *s++ = 'w';
1839             if (flags & PERLIO_F_CANREAD) {
1840                 *s++ = '+';
1841             }
1842         }
1843 #ifdef PERLIO_USING_CRLF
1844         if (!(flags & PERLIO_F_CRLF))
1845             *s++ = 'b';
1846 #endif
1847     }
1848     *s = '\0';
1849     return buf;
1850 }
1851
1852
1853 IV
1854 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1855 {
1856     PerlIOl *l = PerlIOBase(f);
1857 #if 0
1858     const char *omode = mode;
1859     char temp[8];
1860 #endif
1861     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1862                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1863     if (tab->Set_ptrcnt != NULL)
1864         l->flags |= PERLIO_F_FASTGETS;
1865     if (mode) {
1866         if (*mode == '#' || *mode == 'I')
1867             mode++;
1868         switch (*mode++) {
1869         case 'r':
1870             l->flags |= PERLIO_F_CANREAD;
1871             break;
1872         case 'a':
1873             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1874             break;
1875         case 'w':
1876             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1877             break;
1878         default:
1879             SETERRNO(EINVAL, LIB$_INVARG);
1880             return -1;
1881         }
1882         while (*mode) {
1883             switch (*mode++) {
1884             case '+':
1885                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1886                 break;
1887             case 'b':
1888                 l->flags &= ~PERLIO_F_CRLF;
1889                 break;
1890             case 't':
1891                 l->flags |= PERLIO_F_CRLF;
1892                 break;
1893             default:
1894                 SETERRNO(EINVAL, LIB$_INVARG);
1895                 return -1;
1896             }
1897         }
1898     }
1899     else {
1900         if (l->next) {
1901             l->flags |= l->next->flags &
1902                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1903                  PERLIO_F_APPEND);
1904         }
1905     }
1906 #if 0
1907     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1908                  f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1909                  l->flags, PerlIO_modestr(f, temp));
1910 #endif
1911     return 0;
1912 }
1913
1914 IV
1915 PerlIOBase_popped(pTHX_ PerlIO *f)
1916 {
1917     return 0;
1918 }
1919
1920 SSize_t
1921 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1922 {
1923     /*
1924      * Save the position as current head considers it
1925      */
1926     Off_t old = PerlIO_tell(f);
1927     SSize_t done;
1928     PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1929     PerlIOSelf(f, PerlIOBuf)->posn = old;
1930     done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
1931     return done;
1932 }
1933
1934 SSize_t
1935 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1936 {
1937     STDCHAR *buf = (STDCHAR *) vbuf;
1938     if (f) {
1939         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1940             return 0;
1941         while (count > 0) {
1942             SSize_t avail = PerlIO_get_cnt(f);
1943             SSize_t take = 0;
1944             if (avail > 0)
1945                 take = ((SSize_t)count < avail) ? count : avail;
1946             if (take > 0) {
1947                 STDCHAR *ptr = PerlIO_get_ptr(f);
1948                 Copy(ptr, buf, take, STDCHAR);
1949                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1950                 count -= take;
1951                 buf += take;
1952             }
1953             if (count > 0 && avail <= 0) {
1954                 if (PerlIO_fill(f) != 0)
1955                     break;
1956             }
1957         }
1958         return (buf - (STDCHAR *) vbuf);
1959     }
1960     return 0;
1961 }
1962
1963 IV
1964 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
1965 {
1966     return 0;
1967 }
1968
1969 IV
1970 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
1971 {
1972     return -1;
1973 }
1974
1975 IV
1976 PerlIOBase_close(pTHX_ PerlIO *f)
1977 {
1978     IV code = 0;
1979     PerlIO *n = PerlIONext(f);
1980     if (PerlIO_flush(f) != 0)
1981         code = -1;
1982     if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0)
1983         code = -1;
1984     PerlIOBase(f)->flags &=
1985         ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1986     return code;
1987 }
1988
1989 IV
1990 PerlIOBase_eof(pTHX_ PerlIO *f)
1991 {
1992     if (PerlIOValid(f)) {
1993         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1994     }
1995     return 1;
1996 }
1997
1998 IV
1999 PerlIOBase_error(pTHX_ PerlIO *f)
2000 {
2001     if (PerlIOValid(f)) {
2002         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2003     }
2004     return 1;
2005 }
2006
2007 void
2008 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2009 {
2010     if (PerlIOValid(f)) {
2011         PerlIO *n = PerlIONext(f);
2012         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2013         if (PerlIOValid(n))
2014             PerlIO_clearerr(n);
2015     }
2016 }
2017
2018 void
2019 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2020 {
2021     if (PerlIOValid(f)) {
2022         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2023     }
2024 }
2025
2026 SV *
2027 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2028 {
2029     if (!arg)
2030         return Nullsv;
2031 #ifdef sv_dup
2032     if (param) {
2033         return sv_dup(arg, param);
2034     }
2035     else {
2036         return newSVsv(arg);
2037     }
2038 #else
2039     return newSVsv(arg);
2040 #endif
2041 }
2042
2043 PerlIO *
2044 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2045 {
2046     PerlIO *nexto = PerlIONext(o);
2047     if (PerlIOValid(nexto)) {
2048         PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
2049         f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2050     }
2051     if (f) {
2052         PerlIO_funcs *self = PerlIOBase(o)->tab;
2053         SV *arg = Nullsv;
2054         char buf[8];
2055         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2056                      self->name, (void*)f, (void*)o, (void*)param);
2057         if (self->Getarg) {
2058             arg = (*self->Getarg)(aTHX_ o,param,flags);
2059         }
2060         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2061         if (arg) {
2062             SvREFCNT_dec(arg);
2063         }
2064     }
2065     return f;
2066 }
2067
2068 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2069 #ifdef USE_THREADS
2070 perl_mutex PerlIO_mutex;
2071 #endif
2072 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2073
2074 void
2075 PerlIO_init(pTHX)
2076 {
2077  /* Place holder for stdstreams call ??? */
2078 #ifdef USE_THREADS
2079  MUTEX_INIT(&PerlIO_mutex);
2080 #endif
2081 }
2082
2083 void
2084 PerlIOUnix_refcnt_inc(int fd)
2085 {
2086     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2087 #ifdef USE_THREADS
2088         MUTEX_LOCK(&PerlIO_mutex);
2089 #endif
2090         PerlIO_fd_refcnt[fd]++;
2091         PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2092 #ifdef USE_THREADS
2093         MUTEX_UNLOCK(&PerlIO_mutex);
2094 #endif
2095     }
2096 }
2097
2098 int
2099 PerlIOUnix_refcnt_dec(int fd)
2100 {
2101     int cnt = 0;
2102     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2103 #ifdef USE_THREADS
2104         MUTEX_LOCK(&PerlIO_mutex);
2105 #endif
2106         cnt = --PerlIO_fd_refcnt[fd];
2107         PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2108 #ifdef USE_THREADS
2109         MUTEX_UNLOCK(&PerlIO_mutex);
2110 #endif
2111     }
2112     return cnt;
2113 }
2114
2115 void
2116 PerlIO_cleanup(pTHX)
2117 {
2118     int i;
2119 #ifdef USE_ITHREADS
2120     PerlIO_debug("Cleanup layers for %p\n",aTHX);
2121 #else
2122     PerlIO_debug("Cleanup layers\n");
2123 #endif
2124     /* Raise STDIN..STDERR refcount so we don't close them */
2125     for (i=0; i < 3; i++)
2126         PerlIOUnix_refcnt_inc(i);
2127     PerlIO_cleantable(aTHX_ &PL_perlio);
2128     /* Restore STDIN..STDERR refcount */
2129     for (i=0; i < 3; i++)
2130         PerlIOUnix_refcnt_dec(i);
2131
2132     if (PL_known_layers) {
2133         PerlIO_list_free(aTHX_ PL_known_layers);
2134         PL_known_layers = NULL;
2135     }
2136     if(PL_def_layerlist) {
2137         PerlIO_list_free(aTHX_ PL_def_layerlist);
2138         PL_def_layerlist = NULL;
2139     }
2140 }
2141
2142
2143
2144 /*--------------------------------------------------------------------------------------*/
2145 /*
2146  * Bottom-most level for UNIX-like case
2147  */
2148
2149 typedef struct {
2150     struct _PerlIO base;        /* The generic part */
2151     int fd;                     /* UNIX like file descriptor */
2152     int oflags;                 /* open/fcntl flags */
2153 } PerlIOUnix;
2154
2155 int
2156 PerlIOUnix_oflags(const char *mode)
2157 {
2158     int oflags = -1;
2159     if (*mode == 'I' || *mode == '#')
2160         mode++;
2161     switch (*mode) {
2162     case 'r':
2163         oflags = O_RDONLY;
2164         if (*++mode == '+') {
2165             oflags = O_RDWR;
2166             mode++;
2167         }
2168         break;
2169
2170     case 'w':
2171         oflags = O_CREAT | O_TRUNC;
2172         if (*++mode == '+') {
2173             oflags |= O_RDWR;
2174             mode++;
2175         }
2176         else
2177             oflags |= O_WRONLY;
2178         break;
2179
2180     case 'a':
2181         oflags = O_CREAT | O_APPEND;
2182         if (*++mode == '+') {
2183             oflags |= O_RDWR;
2184             mode++;
2185         }
2186         else
2187             oflags |= O_WRONLY;
2188         break;
2189     }
2190     if (*mode == 'b') {
2191         oflags |= O_BINARY;
2192         oflags &= ~O_TEXT;
2193         mode++;
2194     }
2195     else if (*mode == 't') {
2196         oflags |= O_TEXT;
2197         oflags &= ~O_BINARY;
2198         mode++;
2199     }
2200     /*
2201      * Always open in binary mode
2202      */
2203     oflags |= O_BINARY;
2204     if (*mode || oflags == -1) {
2205         SETERRNO(EINVAL, LIB$_INVARG);
2206         oflags = -1;
2207     }
2208     return oflags;
2209 }
2210
2211 IV
2212 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2213 {
2214     return PerlIOSelf(f, PerlIOUnix)->fd;
2215 }
2216
2217 IV
2218 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2219 {
2220     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2221     PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2222     if (*PerlIONext(f)) {
2223         /* We never call down so do any pending stuff now */
2224         PerlIO_flush(PerlIONext(f));
2225         s->fd = PerlIO_fileno(PerlIONext(f));
2226         /*
2227          * XXX could (or should) we retrieve the oflags from the open file
2228          * handle rather than believing the "mode" we are passed in? XXX
2229          * Should the value on NULL mode be 0 or -1?
2230          */
2231         s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2232     }
2233     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2234     return code;
2235 }
2236
2237 PerlIO *
2238 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2239                 IV n, const char *mode, int fd, int imode,
2240                 int perm, PerlIO *f, int narg, SV **args)
2241 {
2242     if (PerlIOValid(f)) {
2243         if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2244             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2245     }
2246     if (narg > 0) {
2247         char *path = SvPV_nolen(*args);
2248         if (*mode == '#')
2249             mode++;
2250         else {
2251             imode = PerlIOUnix_oflags(mode);
2252             perm = 0666;
2253         }
2254         if (imode != -1) {
2255             fd = PerlLIO_open3(path, imode, perm);
2256         }
2257     }
2258     if (fd >= 0) {
2259         PerlIOUnix *s;
2260         if (*mode == 'I')
2261             mode++;
2262         if (!f) {
2263             f = PerlIO_allocate(aTHX);
2264         }
2265         if (!PerlIOValid(f)) {
2266             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2267                 return NULL;
2268             }
2269         }
2270         s = PerlIOSelf(f, PerlIOUnix);
2271         s->fd = fd;
2272         s->oflags = imode;
2273         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2274         PerlIOUnix_refcnt_inc(fd);
2275         return f;
2276     }
2277     else {
2278         if (f) {
2279             /*
2280              * FIXME: pop layers ???
2281              */
2282         }
2283         return NULL;
2284     }
2285 }
2286
2287 PerlIO *
2288 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2289 {
2290     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2291     int fd = os->fd;
2292     if (flags & PERLIO_DUP_FD) {
2293         fd = PerlLIO_dup(fd);
2294     }
2295     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2296         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2297         if (f) {
2298             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2299             PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2300             s->fd = fd;
2301             PerlIOUnix_refcnt_inc(fd);
2302             return f;
2303         }
2304     }
2305     return NULL;
2306 }
2307
2308
2309 SSize_t
2310 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2311 {
2312     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2313     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2314          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2315         return 0;
2316     }
2317     while (1) {
2318         SSize_t len = PerlLIO_read(fd, vbuf, count);
2319         if (len >= 0 || errno != EINTR) {
2320             if (len < 0)
2321                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2322             else if (len == 0 && count != 0)
2323                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2324             return len;
2325         }
2326         PERL_ASYNC_CHECK();
2327     }
2328 }
2329
2330 SSize_t
2331 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2332 {
2333     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2334     while (1) {
2335         SSize_t len = PerlLIO_write(fd, vbuf, count);
2336         if (len >= 0 || errno != EINTR) {
2337             if (len < 0)
2338                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2339             return len;
2340         }
2341         PERL_ASYNC_CHECK();
2342     }
2343 }
2344
2345 IV
2346 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2347 {
2348     Off_t new =
2349         PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2350     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2351     return (new == (Off_t) - 1) ? -1 : 0;
2352 }
2353
2354 Off_t
2355 PerlIOUnix_tell(pTHX_ PerlIO *f)
2356 {
2357     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2358 }
2359
2360
2361 IV
2362 PerlIOUnix_close(pTHX_ PerlIO *f)
2363 {
2364     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2365     int code = 0;
2366     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2367         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2368             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2369             return 0;
2370         }
2371     }
2372     else {
2373         SETERRNO(EBADF,SS$_IVCHAN);
2374         return -1;
2375     }
2376     while (PerlLIO_close(fd) != 0) {
2377         if (errno != EINTR) {
2378             code = -1;
2379             break;
2380         }
2381         PERL_ASYNC_CHECK();
2382     }
2383     if (code == 0) {
2384         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2385     }
2386     return code;
2387 }
2388
2389 PerlIO_funcs PerlIO_unix = {
2390     sizeof(PerlIO_funcs),
2391     "unix",
2392     sizeof(PerlIOUnix),
2393     PERLIO_K_RAW,
2394     PerlIOUnix_pushed,
2395     PerlIOBase_popped,
2396     PerlIOUnix_open,
2397     PerlIOBase_binmode,         /* binmode */
2398     NULL,
2399     PerlIOUnix_fileno,
2400     PerlIOUnix_dup,
2401     PerlIOUnix_read,
2402     PerlIOBase_unread,
2403     PerlIOUnix_write,
2404     PerlIOUnix_seek,
2405     PerlIOUnix_tell,
2406     PerlIOUnix_close,
2407     PerlIOBase_noop_ok,         /* flush */
2408     PerlIOBase_noop_fail,       /* fill */
2409     PerlIOBase_eof,
2410     PerlIOBase_error,
2411     PerlIOBase_clearerr,
2412     PerlIOBase_setlinebuf,
2413     NULL,                       /* get_base */
2414     NULL,                       /* get_bufsiz */
2415     NULL,                       /* get_ptr */
2416     NULL,                       /* get_cnt */
2417     NULL,                       /* set_ptrcnt */
2418 };
2419
2420 /*--------------------------------------------------------------------------------------*/
2421 /*
2422  * stdio as a layer
2423  */
2424
2425 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2426 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2427    broken by the last second glibc 2.3 fix
2428  */
2429 #define STDIO_BUFFER_WRITABLE
2430 #endif
2431
2432
2433 typedef struct {
2434     struct _PerlIO base;
2435     FILE *stdio;                /* The stream */
2436 } PerlIOStdio;
2437
2438 IV
2439 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2440 {
2441     FILE *s;
2442     if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) {
2443         return PerlSIO_fileno(s);
2444     }
2445     errno = EBADF;
2446     return -1;
2447 }
2448
2449 char *
2450 PerlIOStdio_mode(const char *mode, char *tmode)
2451 {
2452     char *ret = tmode;
2453     while (*mode) {
2454         *tmode++ = *mode++;
2455     }
2456 #ifdef PERLIO_USING_CRLF
2457     *tmode++ = 'b';
2458 #endif
2459     *tmode = '\0';
2460     return ret;
2461 }
2462
2463 IV
2464 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2465 {
2466     PerlIO *n;
2467     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2468         PerlIO_funcs *toptab = PerlIOBase(n)->tab;
2469         if (toptab == tab) {
2470             /* Top is already stdio - pop self (duplicate) and use original */
2471             PerlIO_pop(aTHX_ f);
2472             return 0;
2473         } else {
2474             int fd = PerlIO_fileno(n);
2475             char tmode[8];
2476             FILE *stdio;
2477             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
2478                             mode = PerlIOStdio_mode(mode, tmode)))) {
2479                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2480                 /* We never call down so do any pending stuff now */
2481                 PerlIO_flush(PerlIONext(f));
2482             }
2483             else {
2484                 return -1;
2485             }
2486         }
2487     }
2488     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2489 }
2490
2491
2492 PerlIO *
2493 PerlIO_importFILE(FILE *stdio, const char *mode)
2494 {
2495     dTHX;
2496     PerlIO *f = NULL;
2497     if (stdio) {
2498         PerlIOStdio *s;
2499         if (!mode || !*mode) {
2500             /* We need to probe to see how we can open the stream
2501                so start with read/write and then try write and read
2502                we dup() so that we can fclose without loosing the fd.
2503
2504                Note that the errno value set by a failing fdopen
2505                varies between stdio implementations.
2506              */
2507             int fd = PerlLIO_dup(fileno(stdio));
2508             FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2509             if (!f2) {
2510                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2511             }
2512             if (!f2) {
2513                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2514             }
2515             if (!f2) {
2516                 /* Don't seem to be able to open */
2517                 PerlLIO_close(fd);
2518                 return f;
2519             }
2520             fclose(f2);
2521         }
2522         if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio, mode, Nullsv))) {
2523             s = PerlIOSelf(f, PerlIOStdio);
2524             s->stdio = stdio;
2525         }
2526     }
2527     return f;
2528 }
2529
2530 PerlIO *
2531 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2532                  IV n, const char *mode, int fd, int imode,
2533                  int perm, PerlIO *f, int narg, SV **args)
2534 {
2535     char tmode[8];
2536     if (PerlIOValid(f)) {
2537         char *path = SvPV_nolen(*args);
2538         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2539         FILE *stdio;
2540         PerlIOUnix_refcnt_dec(fileno(s->stdio));
2541         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2542                             s->stdio);
2543         if (!s->stdio)
2544             return NULL;
2545         s->stdio = stdio;
2546         PerlIOUnix_refcnt_inc(fileno(s->stdio));
2547         return f;
2548     }
2549     else {
2550         if (narg > 0) {
2551             char *path = SvPV_nolen(*args);
2552             if (*mode == '#') {
2553                 mode++;
2554                 fd = PerlLIO_open3(path, imode, perm);
2555             }
2556             else {
2557                 FILE *stdio = PerlSIO_fopen(path, mode);
2558                 if (stdio) {
2559                     PerlIOStdio *s;
2560                     if (!f) {
2561                         f = PerlIO_allocate(aTHX);
2562                     }
2563                     if ((f = PerlIO_push(aTHX_ f, self,
2564                                     (mode = PerlIOStdio_mode(mode, tmode)),
2565                                     PerlIOArg))) {
2566                         s = PerlIOSelf(f, PerlIOStdio);
2567                         s->stdio = stdio;
2568                         PerlIOUnix_refcnt_inc(fileno(s->stdio));
2569                     }
2570                     return f;
2571                 }
2572                 else {
2573                     return NULL;
2574                 }
2575             }
2576         }
2577         if (fd >= 0) {
2578             FILE *stdio = NULL;
2579             int init = 0;
2580             if (*mode == 'I') {
2581                 init = 1;
2582                 mode++;
2583             }
2584             if (init) {
2585                 switch (fd) {
2586                 case 0:
2587                     stdio = PerlSIO_stdin;
2588                     break;
2589                 case 1:
2590                     stdio = PerlSIO_stdout;
2591                     break;
2592                 case 2:
2593                     stdio = PerlSIO_stderr;
2594                     break;
2595                 }
2596             }
2597             else {
2598                 stdio = PerlSIO_fdopen(fd, mode =
2599                                        PerlIOStdio_mode(mode, tmode));
2600             }
2601             if (stdio) {
2602                 PerlIOStdio *s;
2603                 if (!f) {
2604                     f = PerlIO_allocate(aTHX);
2605                 }
2606                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2607                     s = PerlIOSelf(f, PerlIOStdio);
2608                     s->stdio = stdio;
2609                     PerlIOUnix_refcnt_inc(fileno(s->stdio));
2610                 }
2611                 return f;
2612             }
2613         }
2614     }
2615     return NULL;
2616 }
2617
2618 PerlIO *
2619 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2620 {
2621     /* This assumes no layers underneath - which is what
2622        happens, but is not how I remember it. NI-S 2001/10/16
2623      */
2624     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2625         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2626         if (flags & PERLIO_DUP_FD) {
2627             int fd = PerlLIO_dup(fileno(stdio));
2628             if (fd >= 0) {
2629                 char mode[8];
2630                 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
2631             }
2632             else {
2633                 /* FIXME: To avoid messy error recovery if dup fails
2634                    re-use the existing stdio as though flag was not set
2635                  */
2636             }
2637         }
2638         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2639         PerlIOUnix_refcnt_inc(fileno(stdio));
2640     }
2641     return f;
2642 }
2643
2644 IV
2645 PerlIOStdio_close(pTHX_ PerlIO *f)
2646 {
2647 #ifdef SOCKS5_VERSION_NAME
2648     int optval;
2649     Sock_size_t optlen = sizeof(int);
2650 #endif
2651     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2652     if (!stdio) {
2653         errno = EBADF;
2654         return -1;
2655     }
2656     if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2657         /* Do not close it but do flush any buffers */
2658         return PerlIO_flush(f);
2659     }
2660     return (
2661 #ifdef SOCKS5_VERSION_NAME
2662                (getsockopt
2663                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2664                  &optlen) <
2665                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2666 #else
2667                PerlSIO_fclose(stdio)
2668 #endif
2669         );
2670
2671 }
2672
2673
2674
2675 SSize_t
2676 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2677 {
2678     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2679     SSize_t got = 0;
2680     if (count == 1) {
2681         STDCHAR *buf = (STDCHAR *) vbuf;
2682         /*
2683          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2684          * stdio does not do that for fread()
2685          */
2686         int ch = PerlSIO_fgetc(s);
2687         if (ch != EOF) {
2688             *buf = ch;
2689             got = 1;
2690         }
2691     }
2692     else
2693         got = PerlSIO_fread(vbuf, 1, count, s);
2694     return got;
2695 }
2696
2697 SSize_t
2698 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2699 {
2700     SSize_t unread = 0;
2701     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2702
2703 #ifdef STDIO_BUFFER_WRITABLE
2704     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2705         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2706         STDCHAR *base = PerlIO_get_base(f);
2707         SSize_t cnt   = PerlIO_get_cnt(f);
2708         STDCHAR *ptr  = PerlIO_get_ptr(f);
2709         SSize_t avail = ptr - base;
2710         if (avail > 0) {
2711             if (avail > count) {
2712                 avail = count;
2713             }
2714             ptr -= avail;
2715             Move(buf-avail,ptr,avail,STDCHAR);
2716             count -= avail;
2717             unread += avail;
2718             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
2719             if (PerlSIO_feof(s) && unread >= 0)
2720                 PerlSIO_clearerr(s);
2721         }
2722     }
2723     else
2724 #endif
2725     if (PerlIO_has_cntptr(f)) {
2726         /* We can get pointer to buffer but not its base
2727            Do ungetc() but check chars are ending up in the
2728            buffer
2729          */
2730         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
2731         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2732         while (count > 0) {
2733             int ch = *--buf & 0xFF;
2734             if (ungetc(ch,s) != ch) {
2735                 /* ungetc did not work */
2736                 break;
2737             }
2738             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
2739                 /* Did not change pointer as expected */
2740                 fgetc(s);  /* get char back again */
2741                 break;
2742             }
2743             /* It worked ! */
2744             count--;
2745             unread++;
2746         }
2747     }
2748
2749     if (count > 0) {
2750         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
2751     }
2752     return unread;
2753 }
2754
2755 SSize_t
2756 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2757 {
2758     return PerlSIO_fwrite(vbuf, 1, count,
2759                           PerlIOSelf(f, PerlIOStdio)->stdio);
2760 }
2761
2762 IV
2763 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2764 {
2765     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2766     return PerlSIO_fseek(stdio, offset, whence);
2767 }
2768
2769 Off_t
2770 PerlIOStdio_tell(pTHX_ PerlIO *f)
2771 {
2772     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2773     return PerlSIO_ftell(stdio);
2774 }
2775
2776 IV
2777 PerlIOStdio_flush(pTHX_ PerlIO *f)
2778 {
2779     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2780     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2781         return PerlSIO_fflush(stdio);
2782     }
2783     else {
2784 #if 0
2785         /*
2786          * FIXME: This discards ungetc() and pre-read stuff which is not
2787          * right if this is just a "sync" from a layer above Suspect right
2788          * design is to do _this_ but not have layer above flush this
2789          * layer read-to-read
2790          */
2791         /*
2792          * Not writeable - sync by attempting a seek
2793          */
2794         int err = errno;
2795         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2796             errno = err;
2797 #endif
2798     }
2799     return 0;
2800 }
2801
2802 IV
2803 PerlIOStdio_eof(pTHX_ PerlIO *f)
2804 {
2805     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2806 }
2807
2808 IV
2809 PerlIOStdio_error(pTHX_ PerlIO *f)
2810 {
2811     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2812 }
2813
2814 void
2815 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2816 {
2817     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2818 }
2819
2820 void
2821 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2822 {
2823 #ifdef HAS_SETLINEBUF
2824     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2825 #else
2826     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2827 #endif
2828 }
2829
2830 #ifdef FILE_base
2831 STDCHAR *
2832 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2833 {
2834     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2835     return (STDCHAR*)PerlSIO_get_base(stdio);
2836 }
2837
2838 Size_t
2839 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2840 {
2841     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2842     return PerlSIO_get_bufsiz(stdio);
2843 }
2844 #endif
2845
2846 #ifdef USE_STDIO_PTR
2847 STDCHAR *
2848 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2849 {
2850     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2851     return (STDCHAR*)PerlSIO_get_ptr(stdio);
2852 }
2853
2854 SSize_t
2855 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2856 {
2857     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2858     return PerlSIO_get_cnt(stdio);
2859 }
2860
2861 void
2862 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2863 {
2864     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2865     if (ptr != NULL) {
2866 #ifdef STDIO_PTR_LVALUE
2867         PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2868 #ifdef STDIO_PTR_LVAL_SETS_CNT
2869         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2870             assert(PerlSIO_get_cnt(stdio) == (cnt));
2871         }
2872 #endif
2873 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2874         /*
2875          * Setting ptr _does_ change cnt - we are done
2876          */
2877         return;
2878 #endif
2879 #else                           /* STDIO_PTR_LVALUE */
2880         PerlProc_abort();
2881 #endif                          /* STDIO_PTR_LVALUE */
2882     }
2883     /*
2884      * Now (or only) set cnt
2885      */
2886 #ifdef STDIO_CNT_LVALUE
2887     PerlSIO_set_cnt(stdio, cnt);
2888 #else                           /* STDIO_CNT_LVALUE */
2889 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2890     PerlSIO_set_ptr(stdio,
2891                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2892                                               cnt));
2893 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2894     PerlProc_abort();
2895 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2896 #endif                          /* STDIO_CNT_LVALUE */
2897 }
2898
2899
2900 #endif
2901
2902 IV
2903 PerlIOStdio_fill(pTHX_ PerlIO *f)
2904 {
2905     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2906     int c;
2907     /*
2908      * fflush()ing read-only streams can cause trouble on some stdio-s
2909      */
2910     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2911         if (PerlSIO_fflush(stdio) != 0)
2912             return EOF;
2913     }
2914     c = PerlSIO_fgetc(stdio);
2915     if (c == EOF)
2916         return EOF;
2917
2918 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2919
2920 #ifdef STDIO_BUFFER_WRITABLE
2921     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2922         /* Fake ungetc() to the real buffer in case system's ungetc
2923            goes elsewhere
2924          */
2925         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
2926         SSize_t cnt   = PerlSIO_get_cnt(stdio);
2927         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
2928         if (ptr == base+1) {
2929             *--ptr = (STDCHAR) c;
2930             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
2931             if (PerlSIO_feof(stdio))
2932                 PerlSIO_clearerr(stdio);
2933             return 0;
2934         }
2935     }
2936     else
2937 #endif
2938     if (PerlIO_has_cntptr(f)) {
2939         STDCHAR ch = c;
2940         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
2941             return 0;
2942         }
2943     }
2944 #endif
2945
2946 #if defined(VMS)
2947     /* An ungetc()d char is handled separately from the regular
2948      * buffer, so we stuff it in the buffer ourselves.
2949      * Should never get called as should hit code above
2950      */
2951     *(--((*stdio)->_ptr)) = (unsigned char) c;
2952     (*stdio)->_cnt++;
2953 #else
2954     /* If buffer snoop scheme above fails fall back to
2955        using ungetc().
2956      */
2957     if (PerlSIO_ungetc(c, stdio) != c)
2958         return EOF;
2959 #endif
2960     return 0;
2961 }
2962
2963
2964
2965 PerlIO_funcs PerlIO_stdio = {
2966     sizeof(PerlIO_funcs),
2967     "stdio",
2968     sizeof(PerlIOStdio),
2969     PERLIO_K_BUFFERED|PERLIO_K_RAW,
2970     PerlIOStdio_pushed,
2971     PerlIOBase_popped,
2972     PerlIOStdio_open,
2973     PerlIOBase_binmode,         /* binmode */
2974     NULL,
2975     PerlIOStdio_fileno,
2976     PerlIOStdio_dup,
2977     PerlIOStdio_read,
2978     PerlIOStdio_unread,
2979     PerlIOStdio_write,
2980     PerlIOStdio_seek,
2981     PerlIOStdio_tell,
2982     PerlIOStdio_close,
2983     PerlIOStdio_flush,
2984     PerlIOStdio_fill,
2985     PerlIOStdio_eof,
2986     PerlIOStdio_error,
2987     PerlIOStdio_clearerr,
2988     PerlIOStdio_setlinebuf,
2989 #ifdef FILE_base
2990     PerlIOStdio_get_base,
2991     PerlIOStdio_get_bufsiz,
2992 #else
2993     NULL,
2994     NULL,
2995 #endif
2996 #ifdef USE_STDIO_PTR
2997     PerlIOStdio_get_ptr,
2998     PerlIOStdio_get_cnt,
2999 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3000     PerlIOStdio_set_ptrcnt
3001 #else                           /* STDIO_PTR_LVALUE */
3002     NULL
3003 #endif                          /* STDIO_PTR_LVALUE */
3004 #else                           /* USE_STDIO_PTR */
3005     NULL,
3006     NULL,
3007     NULL
3008 #endif                          /* USE_STDIO_PTR */
3009 };
3010
3011 FILE *
3012 PerlIO_exportFILE(PerlIO * f, const char *mode)
3013 {
3014     dTHX;
3015     FILE *stdio = NULL;
3016     if (PerlIOValid(f)) {
3017         char buf[8];
3018         PerlIO_flush(f);
3019         if (!mode || !*mode) {
3020             mode = PerlIO_modestr(f, buf);
3021         }
3022         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3023         if (stdio) {
3024             PerlIOl *l = *f;
3025             /* De-link any lower layers so new :stdio sticks */
3026             *f = NULL;
3027             if ((f = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) {
3028                 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
3029                 s->stdio = stdio;
3030                 /* Link previous lower layers under new one */
3031                 *PerlIONext(f) = l;
3032             }
3033             else {
3034                 /* restore layers list */
3035                 *f = l;
3036             }
3037         }
3038     }
3039     return stdio;
3040 }
3041
3042
3043 FILE *
3044 PerlIO_findFILE(PerlIO *f)
3045 {
3046     PerlIOl *l = *f;
3047     while (l) {
3048         if (l->tab == &PerlIO_stdio) {
3049             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3050             return s->stdio;
3051         }
3052         l = *PerlIONext(&l);
3053     }
3054     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3055     return PerlIO_exportFILE(f, Nullch);
3056 }
3057
3058 void
3059 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3060 {
3061     PerlIOl *l;
3062     while ((l = *p)) {
3063         if (l->tab == &PerlIO_stdio) {
3064             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3065             if (s->stdio == f) {
3066                 dTHX;
3067                 PerlIO_pop(aTHX_ p);
3068                 return;
3069             }
3070         }
3071         p = PerlIONext(p);
3072     }
3073     return;
3074 }
3075
3076 /*--------------------------------------------------------------------------------------*/
3077 /*
3078  * perlio buffer layer
3079  */
3080
3081 IV
3082 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3083 {
3084     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3085     int fd = PerlIO_fileno(f);
3086     if (fd >= 0 && PerlLIO_isatty(fd)) {
3087         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3088     }
3089     if (*PerlIONext(f)) {
3090         Off_t posn = PerlIO_tell(PerlIONext(f));
3091         if (posn != (Off_t) - 1) {
3092             b->posn = posn;
3093         }
3094     }
3095     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3096 }
3097
3098 PerlIO *
3099 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3100                IV n, const char *mode, int fd, int imode, int perm,
3101                PerlIO *f, int narg, SV **args)
3102 {
3103     if (PerlIOValid(f)) {
3104         PerlIO *next = PerlIONext(f);
3105         PerlIO_funcs *tab =  PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3106         next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3107                           next, narg, args);
3108         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3109             return NULL;
3110         }
3111     }
3112     else {
3113         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3114         int init = 0;
3115         if (*mode == 'I') {
3116             init = 1;
3117             /*
3118              * mode++;
3119              */
3120         }
3121         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3122                           f, narg, args);
3123         if (f) {
3124             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3125                 /*
3126                  * if push fails during open, open fails. close will pop us.
3127                  */
3128                 PerlIO_close (f);
3129                 return NULL;
3130             } else {
3131                 fd = PerlIO_fileno(f);
3132                 if (init && fd == 2) {
3133                     /*
3134                      * Initial stderr is unbuffered
3135                      */
3136                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3137                 }
3138 #ifdef PERLIO_USING_CRLF
3139 #  ifdef PERLIO_IS_BINMODE_FD
3140                 if (PERLIO_IS_BINMODE_FD(fd))
3141                     PerlIO_binmode(f,  '<'/*not used*/, O_BINARY, Nullch);
3142                 else
3143 #  endif
3144                 /*
3145                  * do something about failing setmode()? --jhi
3146                  */
3147                 PerlLIO_setmode(fd, O_BINARY);
3148 #endif
3149             }
3150         }
3151     }
3152     return f;
3153 }
3154
3155 /*
3156  * This "flush" is akin to sfio's sync in that it handles files in either
3157  * read or write state
3158  */
3159 IV
3160 PerlIOBuf_flush(pTHX_ PerlIO *f)
3161 {
3162     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3163     int code = 0;
3164     PerlIO *n = PerlIONext(f);
3165     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3166         /*
3167          * write() the buffer
3168          */
3169         STDCHAR *buf = b->buf;
3170         STDCHAR *p = buf;
3171         while (p < b->ptr) {
3172             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3173             if (count > 0) {
3174                 p += count;
3175             }
3176             else if (count < 0 || PerlIO_error(n)) {
3177                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3178                 code = -1;
3179                 break;
3180             }
3181         }
3182         b->posn += (p - buf);
3183     }
3184     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3185         STDCHAR *buf = PerlIO_get_base(f);
3186         /*
3187          * Note position change
3188          */
3189         b->posn += (b->ptr - buf);
3190         if (b->ptr < b->end) {
3191             /* We did not consume all of it - try and seek downstream to
3192                our logical position
3193              */
3194             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3195                 /* Reload n as some layers may pop themselves on seek */
3196                 b->posn = PerlIO_tell(n = PerlIONext(f));
3197             }
3198             else {
3199                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3200                    data is lost for good - so return saying "ok" having undone
3201                    the position adjust
3202                  */
3203                 b->posn -= (b->ptr - buf);
3204                 return code;
3205             }
3206         }
3207     }
3208     b->ptr = b->end = b->buf;
3209     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3210     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3211     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3212         code = -1;
3213     return code;
3214 }
3215
3216 IV
3217 PerlIOBuf_fill(pTHX_ PerlIO *f)
3218 {
3219     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3220     PerlIO *n = PerlIONext(f);
3221     SSize_t avail;
3222     /*
3223      * Down-stream flush is defined not to loose read data so is harmless.
3224      * we would not normally be fill'ing if there was data left in anycase.
3225      */
3226     if (PerlIO_flush(f) != 0)
3227         return -1;
3228     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3229         PerlIOBase_flush_linebuf(aTHX);
3230
3231     if (!b->buf)
3232         PerlIO_get_base(f);     /* allocate via vtable */
3233
3234     b->ptr = b->end = b->buf;
3235
3236     if (!PerlIOValid(n)) {
3237         PerlIOBase(f)->flags |= PERLIO_F_EOF;
3238         return -1;
3239     }
3240
3241     if (PerlIO_fast_gets(n)) {
3242         /*
3243          * Layer below is also buffered. We do _NOT_ want to call its
3244          * ->Read() because that will loop till it gets what we asked for
3245          * which may hang on a pipe etc. Instead take anything it has to
3246          * hand, or ask it to fill _once_.
3247          */
3248         avail = PerlIO_get_cnt(n);
3249         if (avail <= 0) {
3250             avail = PerlIO_fill(n);
3251             if (avail == 0)
3252                 avail = PerlIO_get_cnt(n);
3253             else {
3254                 if (!PerlIO_error(n) && PerlIO_eof(n))
3255                     avail = 0;
3256             }
3257         }
3258         if (avail > 0) {
3259             STDCHAR *ptr = PerlIO_get_ptr(n);
3260             SSize_t cnt = avail;
3261             if (avail > (SSize_t)b->bufsiz)
3262                 avail = b->bufsiz;
3263             Copy(ptr, b->buf, avail, STDCHAR);
3264             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3265         }
3266     }
3267     else {
3268         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3269     }
3270     if (avail <= 0) {
3271         if (avail == 0)
3272             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3273         else
3274             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3275         return -1;
3276     }
3277     b->end = b->buf + avail;
3278     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3279     return 0;
3280 }
3281
3282 SSize_t
3283 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3284 {
3285     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3286     if (PerlIOValid(f)) {
3287         if (!b->ptr)
3288             PerlIO_get_base(f);
3289         return PerlIOBase_read(aTHX_ f, vbuf, count);
3290     }
3291     return 0;
3292 }
3293
3294 SSize_t
3295 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3296 {
3297     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3298     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3299     SSize_t unread = 0;
3300     SSize_t avail;
3301     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3302         PerlIO_flush(f);
3303     if (!b->buf)
3304         PerlIO_get_base(f);
3305     if (b->buf) {
3306         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3307             /*
3308              * Buffer is already a read buffer, we can overwrite any chars
3309              * which have been read back to buffer start
3310              */
3311             avail = (b->ptr - b->buf);
3312         }
3313         else {
3314             /*
3315              * Buffer is idle, set it up so whole buffer is available for
3316              * unread
3317              */
3318             avail = b->bufsiz;
3319             b->end = b->buf + avail;
3320             b->ptr = b->end;
3321             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3322             /*
3323              * Buffer extends _back_ from where we are now
3324              */
3325             b->posn -= b->bufsiz;
3326         }
3327         if (avail > (SSize_t) count) {
3328             /*
3329              * If we have space for more than count, just move count
3330              */
3331             avail = count;
3332         }
3333         if (avail > 0) {
3334             b->ptr -= avail;
3335             buf -= avail;
3336             /*
3337              * In simple stdio-like ungetc() case chars will be already
3338              * there
3339              */
3340             if (buf != b->ptr) {
3341                 Copy(buf, b->ptr, avail, STDCHAR);
3342             }
3343             count -= avail;
3344             unread += avail;
3345             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3346         }
3347     }
3348     if (count > 0) {
3349         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3350     }
3351     return unread;
3352 }
3353
3354 SSize_t
3355 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3356 {
3357     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3358     const STDCHAR *buf = (const STDCHAR *) vbuf;
3359     Size_t written = 0;
3360     if (!b->buf)
3361         PerlIO_get_base(f);
3362     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3363         return 0;
3364     while (count > 0) {
3365         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3366         if ((SSize_t) count < avail)
3367             avail = count;
3368         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3369         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3370             while (avail > 0) {
3371                 int ch = *buf++;
3372                 *(b->ptr)++ = ch;
3373                 count--;
3374                 avail--;
3375                 written++;
3376                 if (ch == '\n') {
3377                     PerlIO_flush(f);
3378                     break;
3379                 }
3380             }
3381         }
3382         else {
3383             if (avail) {
3384                 Copy(buf, b->ptr, avail, STDCHAR);
3385                 count -= avail;
3386                 buf += avail;
3387                 written += avail;
3388                 b->ptr += avail;
3389             }
3390         }
3391         if (b->ptr >= (b->buf + b->bufsiz))
3392             PerlIO_flush(f);
3393     }
3394     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3395         PerlIO_flush(f);
3396     return written;
3397 }
3398
3399 IV
3400 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3401 {
3402     IV code;
3403     if ((code = PerlIO_flush(f)) == 0) {
3404         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3405         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3406         code = PerlIO_seek(PerlIONext(f), offset, whence);
3407         if (code == 0) {
3408             b->posn = PerlIO_tell(PerlIONext(f));
3409         }
3410     }
3411     return code;
3412 }
3413
3414 Off_t
3415 PerlIOBuf_tell(pTHX_ PerlIO *f)
3416 {
3417     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3418     /*
3419      * b->posn is file position where b->buf was read, or will be written
3420      */
3421     Off_t posn = b->posn;
3422     if (b->buf) {
3423         /*
3424          * If buffer is valid adjust position by amount in buffer
3425          */
3426         posn += (b->ptr - b->buf);
3427     }
3428     return posn;
3429 }
3430
3431 IV
3432 PerlIOBuf_popped(pTHX_ PerlIO *f)
3433 {
3434     IV code = PerlIOBase_popped(aTHX_ f);
3435     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3436     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3437         Safefree(b->buf);
3438     }
3439     b->buf = NULL;
3440     b->ptr = b->end = b->buf;
3441     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3442     return code;
3443 }
3444
3445 IV
3446 PerlIOBuf_close(pTHX_ PerlIO *f)
3447 {
3448     IV code = PerlIOBase_close(aTHX_ f);
3449     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3450     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3451         Safefree(b->buf);
3452     }
3453     b->buf = NULL;
3454     b->ptr = b->end = b->buf;
3455     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3456     return code;
3457 }
3458
3459 STDCHAR *
3460 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3461 {
3462     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3463     if (!b->buf)
3464         PerlIO_get_base(f);
3465     return b->ptr;
3466 }
3467
3468 SSize_t
3469 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3470 {
3471     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3472     if (!b->buf)
3473         PerlIO_get_base(f);
3474     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3475         return (b->end - b->ptr);
3476     return 0;
3477 }
3478
3479 STDCHAR *
3480 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3481 {
3482     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3483     if (!b->buf) {
3484         if (!b->bufsiz)
3485             b->bufsiz = 4096;
3486         b->buf =
3487         Newz('B',b->buf,b->bufsiz, STDCHAR);
3488         if (!b->buf) {
3489             b->buf = (STDCHAR *) & b->oneword;
3490             b->bufsiz = sizeof(b->oneword);
3491         }
3492         b->ptr = b->buf;
3493         b->end = b->ptr;
3494     }
3495     return b->buf;
3496 }
3497
3498 Size_t
3499 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3500 {
3501     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3502     if (!b->buf)
3503         PerlIO_get_base(f);
3504     return (b->end - b->buf);
3505 }
3506
3507 void
3508 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3509 {
3510     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3511     if (!b->buf)
3512         PerlIO_get_base(f);
3513     b->ptr = ptr;
3514     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3515         assert(PerlIO_get_cnt(f) == cnt);
3516         assert(b->ptr >= b->buf);
3517     }
3518     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3519 }
3520
3521 PerlIO *
3522 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3523 {
3524  return PerlIOBase_dup(aTHX_ f, o, param, flags);
3525 }
3526
3527
3528
3529 PerlIO_funcs PerlIO_perlio = {
3530     sizeof(PerlIO_funcs),
3531     "perlio",
3532     sizeof(PerlIOBuf),
3533     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3534     PerlIOBuf_pushed,
3535     PerlIOBuf_popped,
3536     PerlIOBuf_open,
3537     PerlIOBase_binmode,         /* binmode */
3538     NULL,
3539     PerlIOBase_fileno,
3540     PerlIOBuf_dup,
3541     PerlIOBuf_read,
3542     PerlIOBuf_unread,
3543     PerlIOBuf_write,
3544     PerlIOBuf_seek,
3545     PerlIOBuf_tell,
3546     PerlIOBuf_close,
3547     PerlIOBuf_flush,
3548     PerlIOBuf_fill,
3549     PerlIOBase_eof,
3550     PerlIOBase_error,
3551     PerlIOBase_clearerr,
3552     PerlIOBase_setlinebuf,
3553     PerlIOBuf_get_base,
3554     PerlIOBuf_bufsiz,
3555     PerlIOBuf_get_ptr,
3556     PerlIOBuf_get_cnt,
3557     PerlIOBuf_set_ptrcnt,
3558 };
3559
3560 /*--------------------------------------------------------------------------------------*/
3561 /*
3562  * Temp layer to hold unread chars when cannot do it any other way
3563  */
3564
3565 IV
3566 PerlIOPending_fill(pTHX_ PerlIO *f)
3567 {
3568     /*
3569      * Should never happen
3570      */
3571     PerlIO_flush(f);
3572     return 0;
3573 }
3574
3575 IV
3576 PerlIOPending_close(pTHX_ PerlIO *f)
3577 {
3578     /*
3579      * A tad tricky - flush pops us, then we close new top
3580      */
3581     PerlIO_flush(f);
3582     return PerlIO_close(f);
3583 }
3584
3585 IV
3586 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3587 {
3588     /*
3589      * A tad tricky - flush pops us, then we seek new top
3590      */
3591     PerlIO_flush(f);
3592     return PerlIO_seek(f, offset, whence);
3593 }
3594
3595
3596 IV
3597 PerlIOPending_flush(pTHX_ PerlIO *f)
3598 {
3599     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3600     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3601         Safefree(b->buf);
3602         b->buf = NULL;
3603     }
3604     PerlIO_pop(aTHX_ f);
3605     return 0;
3606 }
3607
3608 void
3609 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3610 {
3611     if (cnt <= 0) {
3612         PerlIO_flush(f);
3613     }
3614     else {
3615         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3616     }
3617 }
3618
3619 IV
3620 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3621 {
3622     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3623     PerlIOl *l = PerlIOBase(f);
3624     /*
3625      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3626      * etc. get muddled when it changes mid-string when we auto-pop.
3627      */
3628     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3629         (PerlIOBase(PerlIONext(f))->
3630          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3631     return code;
3632 }
3633
3634 SSize_t
3635 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3636 {
3637     SSize_t avail = PerlIO_get_cnt(f);
3638     SSize_t got = 0;
3639     if ((SSize_t)count < avail)
3640         avail = count;
3641     if (avail > 0)
3642         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3643     if (got >= 0 && got < (SSize_t)count) {
3644         SSize_t more =
3645             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3646         if (more >= 0 || got == 0)
3647             got += more;
3648     }
3649     return got;
3650 }
3651
3652 PerlIO_funcs PerlIO_pending = {
3653     sizeof(PerlIO_funcs),
3654     "pending",
3655     sizeof(PerlIOBuf),
3656     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
3657     PerlIOPending_pushed,
3658     PerlIOBuf_popped,
3659     NULL,
3660     PerlIOBase_binmode,         /* binmode */
3661     NULL,
3662     PerlIOBase_fileno,
3663     PerlIOBuf_dup,
3664     PerlIOPending_read,
3665     PerlIOBuf_unread,
3666     PerlIOBuf_write,
3667     PerlIOPending_seek,
3668     PerlIOBuf_tell,
3669     PerlIOPending_close,
3670     PerlIOPending_flush,
3671     PerlIOPending_fill,
3672     PerlIOBase_eof,
3673     PerlIOBase_error,
3674     PerlIOBase_clearerr,
3675     PerlIOBase_setlinebuf,
3676     PerlIOBuf_get_base,
3677     PerlIOBuf_bufsiz,
3678     PerlIOBuf_get_ptr,
3679     PerlIOBuf_get_cnt,
3680     PerlIOPending_set_ptrcnt,
3681 };
3682
3683
3684
3685 /*--------------------------------------------------------------------------------------*/
3686 /*
3687  * crlf - translation On read translate CR,LF to "\n" we do this by
3688  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3689  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3690  */
3691
3692 typedef struct {
3693     PerlIOBuf base;             /* PerlIOBuf stuff */
3694     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3695                                  * buffer */
3696 } PerlIOCrlf;
3697
3698 IV
3699 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3700 {
3701     IV code;
3702     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3703     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
3704 #if 0
3705     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3706                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3707                  PerlIOBase(f)->flags);
3708 #endif
3709     return code;
3710 }
3711
3712
3713 SSize_t
3714 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3715 {
3716     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3717     if (c->nl) {
3718         *(c->nl) = 0xd;
3719         c->nl = NULL;
3720     }
3721     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3722         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3723     else {
3724         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3725         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3726         SSize_t unread = 0;
3727         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3728             PerlIO_flush(f);
3729         if (!b->buf)
3730             PerlIO_get_base(f);
3731         if (b->buf) {
3732             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3733                 b->end = b->ptr = b->buf + b->bufsiz;
3734                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3735                 b->posn -= b->bufsiz;
3736             }
3737             while (count > 0 && b->ptr > b->buf) {
3738                 int ch = *--buf;
3739                 if (ch == '\n') {
3740                     if (b->ptr - 2 >= b->buf) {
3741                         *--(b->ptr) = 0xa;
3742                         *--(b->ptr) = 0xd;
3743                         unread++;
3744                         count--;
3745                     }
3746                     else {
3747                         buf++;
3748                         break;
3749                     }
3750                 }
3751                 else {
3752                     *--(b->ptr) = ch;
3753                     unread++;
3754                     count--;
3755                 }
3756             }
3757         }
3758         return unread;
3759     }
3760 }
3761
3762 SSize_t
3763 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3764 {
3765     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3766     if (!b->buf)
3767         PerlIO_get_base(f);
3768     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3769         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3770         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3771             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3772           scan:
3773             while (nl < b->end && *nl != 0xd)
3774                 nl++;
3775             if (nl < b->end && *nl == 0xd) {
3776               test:
3777                 if (nl + 1 < b->end) {
3778                     if (nl[1] == 0xa) {
3779                         *nl = '\n';
3780                         c->nl = nl;
3781                     }
3782                     else {
3783                         /*
3784                          * Not CR,LF but just CR
3785                          */
3786                         nl++;
3787                         goto scan;
3788                     }
3789                 }
3790                 else {
3791                     /*
3792                      * Blast - found CR as last char in buffer
3793                      */
3794
3795                     if (b->ptr < nl) {
3796                         /*
3797                          * They may not care, defer work as long as
3798                          * possible
3799                          */
3800                         c->nl = nl;
3801                         return (nl - b->ptr);
3802                     }
3803                     else {
3804                         int code;
3805                         b->ptr++;       /* say we have read it as far as
3806                                          * flush() is concerned */
3807                         b->buf++;       /* Leave space in front of buffer */
3808                         b->bufsiz--;    /* Buffer is thus smaller */
3809                         code = PerlIO_fill(f);  /* Fetch some more */
3810                         b->bufsiz++;    /* Restore size for next time */
3811                         b->buf--;       /* Point at space */
3812                         b->ptr = nl = b->buf;   /* Which is what we hand
3813                                                  * off */
3814                         b->posn--;      /* Buffer starts here */
3815                         *nl = 0xd;      /* Fill in the CR */
3816                         if (code == 0)
3817                             goto test;  /* fill() call worked */
3818                         /*
3819                          * CR at EOF - just fall through
3820                          */
3821                         /* Should we clear EOF though ??? */
3822                     }
3823                 }
3824             }
3825         }
3826         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3827     }
3828     return 0;
3829 }
3830
3831 void
3832 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3833 {
3834     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3835     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3836     if (!b->buf)
3837         PerlIO_get_base(f);
3838     if (!ptr) {
3839         if (c->nl) {
3840             ptr = c->nl + 1;
3841             if (ptr == b->end && *c->nl == 0xd) {
3842                 /* Defered CR at end of buffer case - we lied about count */
3843                 ptr--;
3844             }
3845         }
3846         else {
3847             ptr = b->end;
3848         }
3849         ptr -= cnt;
3850     }
3851     else {
3852 #if 0
3853         /*
3854          * Test code - delete when it works ...
3855          */
3856         IV flags = PerlIOBase(f)->flags;
3857         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3858         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3859           /* Defered CR at end of buffer case - we lied about count */
3860           chk--;
3861         }
3862         chk -= cnt;
3863
3864         if (ptr != chk ) {
3865             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3866                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3867                        b->end, cnt);
3868         }
3869 #endif
3870     }
3871     if (c->nl) {
3872         if (ptr > c->nl) {
3873             /*
3874              * They have taken what we lied about
3875              */
3876             *(c->nl) = 0xd;
3877             c->nl = NULL;
3878             ptr++;
3879         }
3880     }
3881     b->ptr = ptr;
3882     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3883 }
3884
3885 SSize_t
3886 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3887 {
3888     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3889         return PerlIOBuf_write(aTHX_ f, vbuf, count);
3890     else {
3891         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3892         const STDCHAR *buf = (const STDCHAR *) vbuf;
3893         const STDCHAR *ebuf = buf + count;
3894         if (!b->buf)
3895             PerlIO_get_base(f);
3896         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3897             return 0;
3898         while (buf < ebuf) {
3899             STDCHAR *eptr = b->buf + b->bufsiz;
3900             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3901             while (buf < ebuf && b->ptr < eptr) {
3902                 if (*buf == '\n') {
3903                     if ((b->ptr + 2) > eptr) {
3904                         /*
3905                          * Not room for both
3906                          */
3907                         PerlIO_flush(f);
3908                         break;
3909                     }
3910                     else {
3911                         *(b->ptr)++ = 0xd;      /* CR */
3912                         *(b->ptr)++ = 0xa;      /* LF */
3913                         buf++;
3914                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3915                             PerlIO_flush(f);
3916                             break;
3917                         }
3918                     }
3919                 }
3920                 else {
3921                     int ch = *buf++;
3922                     *(b->ptr)++ = ch;
3923                 }
3924                 if (b->ptr >= eptr) {
3925                     PerlIO_flush(f);
3926                     break;
3927                 }
3928             }
3929         }
3930         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3931             PerlIO_flush(f);
3932         return (buf - (STDCHAR *) vbuf);
3933     }
3934 }
3935
3936 IV
3937 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3938 {
3939     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3940     if (c->nl) {
3941         *(c->nl) = 0xd;
3942         c->nl = NULL;
3943     }
3944     return PerlIOBuf_flush(aTHX_ f);
3945 }
3946
3947 IV
3948 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
3949 {
3950     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
3951         /* In text mode - flush any pending stuff and flip it */
3952         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
3953 #ifndef PERLIO_USING_CRLF
3954         /* CRLF is unusual case - if this is just the :crlf layer pop it */
3955         if (PerlIOBase(f)->tab == &PerlIO_crlf) {
3956                 PerlIO_pop(aTHX_ f);
3957         }
3958 #endif
3959     }
3960     return 0;
3961 }
3962
3963 PerlIO_funcs PerlIO_crlf = {
3964     sizeof(PerlIO_funcs),
3965     "crlf",
3966     sizeof(PerlIOCrlf),
3967     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
3968     PerlIOCrlf_pushed,
3969     PerlIOBuf_popped,         /* popped */
3970     PerlIOBuf_open,
3971     PerlIOCrlf_binmode,       /* binmode */
3972     NULL,
3973     PerlIOBase_fileno,
3974     PerlIOBuf_dup,
3975     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3976                                  * ... */
3977     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3978     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3979     PerlIOBuf_seek,
3980     PerlIOBuf_tell,
3981     PerlIOBuf_close,
3982     PerlIOCrlf_flush,
3983     PerlIOBuf_fill,
3984     PerlIOBase_eof,
3985     PerlIOBase_error,
3986     PerlIOBase_clearerr,
3987     PerlIOBase_setlinebuf,
3988     PerlIOBuf_get_base,
3989     PerlIOBuf_bufsiz,
3990     PerlIOBuf_get_ptr,
3991     PerlIOCrlf_get_cnt,
3992     PerlIOCrlf_set_ptrcnt,
3993 };
3994
3995 #ifdef HAS_MMAP
3996 /*--------------------------------------------------------------------------------------*/
3997 /*
3998  * mmap as "buffer" layer
3999  */
4000
4001 typedef struct {
4002     PerlIOBuf base;             /* PerlIOBuf stuff */
4003     Mmap_t mptr;                /* Mapped address */
4004     Size_t len;                 /* mapped length */
4005     STDCHAR *bbuf;              /* malloced buffer if map fails */
4006 } PerlIOMmap;
4007
4008 static size_t page_size = 0;
4009
4010 IV
4011 PerlIOMmap_map(pTHX_ PerlIO *f)
4012 {
4013     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4014     IV flags = PerlIOBase(f)->flags;
4015     IV code = 0;
4016     if (m->len)
4017         abort();
4018     if (flags & PERLIO_F_CANREAD) {
4019         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4020         int fd = PerlIO_fileno(f);
4021         Stat_t st;
4022         code = Fstat(fd, &st);
4023         if (code == 0 && S_ISREG(st.st_mode)) {
4024             SSize_t len = st.st_size - b->posn;
4025             if (len > 0) {
4026                 Off_t posn;
4027                 if (!page_size) {
4028 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
4029                     {
4030                         SETERRNO(0, SS$_NORMAL);
4031 #   ifdef _SC_PAGESIZE
4032                         page_size = sysconf(_SC_PAGESIZE);
4033 #   else
4034                         page_size = sysconf(_SC_PAGE_SIZE);
4035 #   endif
4036                         if ((long) page_size < 0) {
4037                             if (errno) {
4038                                 SV *error = ERRSV;
4039                                 char *msg;
4040                                 STRLEN n_a;
4041                                 (void) SvUPGRADE(error, SVt_PV);
4042                                 msg = SvPVx(error, n_a);
4043                                 Perl_croak(aTHX_ "panic: sysconf: %s",
4044                                            msg);
4045                             }
4046                             else
4047                                 Perl_croak(aTHX_
4048                                            "panic: sysconf: pagesize unknown");
4049                         }
4050                     }
4051 #else
4052 #   ifdef HAS_GETPAGESIZE
4053                     page_size = getpagesize();
4054 #   else
4055 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
4056                     page_size = PAGESIZE;       /* compiletime, bad */
4057 #       endif
4058 #   endif
4059 #endif
4060                     if ((IV) page_size <= 0)
4061                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4062                                    (IV) page_size);
4063                 }
4064                 if (b->posn < 0) {
4065                     /*
4066                      * This is a hack - should never happen - open should
4067                      * have set it !
4068                      */
4069                     b->posn = PerlIO_tell(PerlIONext(f));
4070                 }
4071                 posn = (b->posn / page_size) * page_size;
4072                 len = st.st_size - posn;
4073                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4074                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4075 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4076                     madvise(m->mptr, len, MADV_SEQUENTIAL);
4077 #endif
4078 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4079                     madvise(m->mptr, len, MADV_WILLNEED);
4080 #endif
4081                     PerlIOBase(f)->flags =
4082                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4083                     b->end = ((STDCHAR *) m->mptr) + len;
4084                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4085                     b->ptr = b->buf;
4086                     m->len = len;
4087                 }
4088                 else {
4089                     b->buf = NULL;
4090                 }
4091             }
4092             else {
4093                 PerlIOBase(f)->flags =
4094                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4095                 b->buf = NULL;
4096                 b->ptr = b->end = b->ptr;
4097                 code = -1;
4098             }
4099         }
4100     }
4101     return code;
4102 }
4103
4104 IV
4105 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4106 {
4107     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4108     PerlIOBuf *b = &m->base;
4109     IV code = 0;
4110     if (m->len) {
4111         if (b->buf) {
4112             code = munmap(m->mptr, m->len);
4113             b->buf = NULL;
4114             m->len = 0;
4115             m->mptr = NULL;
4116             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4117                 code = -1;
4118         }
4119         b->ptr = b->end = b->buf;
4120         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4121     }
4122     return code;
4123 }
4124
4125 STDCHAR *
4126 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4127 {
4128     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4129     PerlIOBuf *b = &m->base;
4130     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4131         /*
4132          * Already have a readbuffer in progress
4133          */
4134         return b->buf;
4135     }
4136     if (b->buf) {
4137         /*
4138          * We have a write buffer or flushed PerlIOBuf read buffer
4139          */
4140         m->bbuf = b->buf;       /* save it in case we need it again */
4141         b->buf = NULL;          /* Clear to trigger below */
4142     }
4143     if (!b->buf) {
4144         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
4145         if (!b->buf) {
4146             /*
4147              * Map did not work - recover PerlIOBuf buffer if we have one
4148              */
4149             b->buf = m->bbuf;
4150         }
4151     }
4152     b->ptr = b->end = b->buf;
4153     if (b->buf)
4154         return b->buf;
4155     return PerlIOBuf_get_base(aTHX_ f);
4156 }
4157
4158 SSize_t
4159 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4160 {
4161     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4162     PerlIOBuf *b = &m->base;
4163     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4164         PerlIO_flush(f);
4165     if (b->ptr && (b->ptr - count) >= b->buf
4166         && memEQ(b->ptr - count, vbuf, count)) {
4167         b->ptr -= count;
4168         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4169         return count;
4170     }
4171     if (m->len) {
4172         /*
4173          * Loose the unwritable mapped buffer
4174          */
4175         PerlIO_flush(f);
4176         /*
4177          * If flush took the "buffer" see if we have one from before
4178          */
4179         if (!b->buf && m->bbuf)
4180             b->buf = m->bbuf;
4181         if (!b->buf) {
4182             PerlIOBuf_get_base(aTHX_ f);
4183             m->bbuf = b->buf;
4184         }
4185     }
4186     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4187 }
4188
4189 SSize_t
4190 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4191 {
4192     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4193     PerlIOBuf *b = &m->base;
4194     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4195         /*
4196          * No, or wrong sort of, buffer
4197          */
4198         if (m->len) {
4199             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4200                 return 0;
4201         }
4202         /*
4203          * If unmap took the "buffer" see if we have one from before
4204          */
4205         if (!b->buf && m->bbuf)
4206             b->buf = m->bbuf;
4207         if (!b->buf) {
4208             PerlIOBuf_get_base(aTHX_ f);
4209             m->bbuf = b->buf;
4210         }
4211     }
4212     return PerlIOBuf_write(aTHX_ f, vbuf, count);
4213 }
4214
4215 IV
4216 PerlIOMmap_flush(pTHX_ PerlIO *f)
4217 {
4218     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4219     PerlIOBuf *b = &m->base;
4220     IV code = PerlIOBuf_flush(aTHX_ f);
4221     /*
4222      * Now we are "synced" at PerlIOBuf level
4223      */
4224     if (b->buf) {
4225         if (m->len) {
4226             /*
4227              * Unmap the buffer
4228              */
4229             if (PerlIOMmap_unmap(aTHX_ f) != 0)
4230                 code = -1;
4231         }
4232         else {
4233             /*
4234              * We seem to have a PerlIOBuf buffer which was not mapped
4235              * remember it in case we need one later
4236              */
4237             m->bbuf = b->buf;
4238         }
4239     }
4240     return code;
4241 }
4242
4243 IV
4244 PerlIOMmap_fill(pTHX_ PerlIO *f)
4245 {
4246     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4247     IV code = PerlIO_flush(f);
4248     if (code == 0 && !b->buf) {
4249         code = PerlIOMmap_map(aTHX_ f);
4250     }
4251     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4252         code = PerlIOBuf_fill(aTHX_ f);
4253     }
4254     return code;
4255 }
4256
4257 IV
4258 PerlIOMmap_close(pTHX_ PerlIO *f)
4259 {
4260     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4261     PerlIOBuf *b = &m->base;
4262     IV code = PerlIO_flush(f);
4263     if (m->bbuf) {
4264         b->buf = m->bbuf;
4265         m->bbuf = NULL;
4266         b->ptr = b->end = b->buf;
4267     }
4268     if (PerlIOBuf_close(aTHX_ f) != 0)
4269         code = -1;
4270     return code;
4271 }
4272
4273 PerlIO *
4274 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4275 {
4276  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4277 }
4278
4279
4280 PerlIO_funcs PerlIO_mmap = {
4281     sizeof(PerlIO_funcs),
4282     "mmap",
4283     sizeof(PerlIOMmap),
4284     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4285     PerlIOBuf_pushed,
4286     PerlIOBuf_popped,
4287     PerlIOBuf_open,
4288     PerlIOBase_binmode,         /* binmode */
4289     NULL,
4290     PerlIOBase_fileno,
4291     PerlIOMmap_dup,
4292     PerlIOBuf_read,
4293     PerlIOMmap_unread,
4294     PerlIOMmap_write,
4295     PerlIOBuf_seek,
4296     PerlIOBuf_tell,
4297     PerlIOBuf_close,
4298     PerlIOMmap_flush,
4299     PerlIOMmap_fill,
4300     PerlIOBase_eof,
4301     PerlIOBase_error,
4302     PerlIOBase_clearerr,
4303     PerlIOBase_setlinebuf,
4304     PerlIOMmap_get_base,
4305     PerlIOBuf_bufsiz,
4306     PerlIOBuf_get_ptr,
4307     PerlIOBuf_get_cnt,
4308     PerlIOBuf_set_ptrcnt,
4309 };
4310
4311 #endif                          /* HAS_MMAP */
4312
4313 PerlIO *
4314 Perl_PerlIO_stdin(pTHX)
4315 {
4316     if (!PL_perlio) {
4317         PerlIO_stdstreams(aTHX);
4318     }
4319     return &PL_perlio[1];
4320 }
4321
4322 PerlIO *
4323 Perl_PerlIO_stdout(pTHX)
4324 {
4325     if (!PL_perlio) {
4326         PerlIO_stdstreams(aTHX);
4327     }
4328     return &PL_perlio[2];
4329 }
4330
4331 PerlIO *
4332 Perl_PerlIO_stderr(pTHX)
4333 {
4334     if (!PL_perlio) {
4335         PerlIO_stdstreams(aTHX);
4336     }
4337     return &PL_perlio[3];
4338 }
4339
4340 /*--------------------------------------------------------------------------------------*/
4341
4342 char *
4343 PerlIO_getname(PerlIO *f, char *buf)
4344 {
4345     dTHX;
4346     char *name = NULL;
4347 #ifdef VMS
4348     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4349     if (stdio)
4350         name = fgetname(stdio, buf);
4351 #else
4352     Perl_croak(aTHX_ "Don't know how to get file name");
4353 #endif
4354     return name;
4355 }
4356
4357
4358 /*--------------------------------------------------------------------------------------*/
4359 /*
4360  * Functions which can be called on any kind of PerlIO implemented in
4361  * terms of above
4362  */
4363
4364 #undef PerlIO_fdopen
4365 PerlIO *
4366 PerlIO_fdopen(int fd, const char *mode)
4367 {
4368     dTHX;
4369     return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4370 }
4371
4372 #undef PerlIO_open
4373 PerlIO *
4374 PerlIO_open(const char *path, const char *mode)
4375 {
4376     dTHX;
4377     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4378     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4379 }
4380
4381 #undef Perlio_reopen
4382 PerlIO *
4383 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4384 {
4385     dTHX;
4386     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4387     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4388 }
4389
4390 #undef PerlIO_getc
4391 int
4392 PerlIO_getc(PerlIO *f)
4393 {
4394     dTHX;
4395     STDCHAR buf[1];
4396     SSize_t count = PerlIO_read(f, buf, 1);
4397     if (count == 1) {
4398         return (unsigned char) buf[0];
4399     }
4400     return EOF;
4401 }
4402
4403 #undef PerlIO_ungetc
4404 int
4405 PerlIO_ungetc(PerlIO *f, int ch)
4406 {
4407     dTHX;
4408     if (ch != EOF) {
4409         STDCHAR buf = ch;
4410         if (PerlIO_unread(f, &buf, 1) == 1)
4411             return ch;
4412     }
4413     return EOF;
4414 }
4415
4416 #undef PerlIO_putc
4417 int
4418 PerlIO_putc(PerlIO *f, int ch)
4419 {
4420     dTHX;
4421     STDCHAR buf = ch;
4422     return PerlIO_write(f, &buf, 1);
4423 }
4424
4425 #undef PerlIO_puts
4426 int
4427 PerlIO_puts(PerlIO *f, const char *s)
4428 {
4429     dTHX;
4430     STRLEN len = strlen(s);
4431     return PerlIO_write(f, s, len);
4432 }
4433
4434 #undef PerlIO_rewind
4435 void
4436 PerlIO_rewind(PerlIO *f)
4437 {
4438     dTHX;
4439     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4440     PerlIO_clearerr(f);
4441 }
4442
4443 #undef PerlIO_vprintf
4444 int
4445 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4446 {
4447     dTHX;
4448     SV *sv = newSVpvn("", 0);
4449     char *s;
4450     STRLEN len;
4451     SSize_t wrote;
4452 #ifdef NEED_VA_COPY
4453     va_list apc;
4454     Perl_va_copy(ap, apc);
4455     sv_vcatpvf(sv, fmt, &apc);
4456 #else
4457     sv_vcatpvf(sv, fmt, &ap);
4458 #endif
4459     s = SvPV(sv, len);
4460     wrote = PerlIO_write(f, s, len);
4461     SvREFCNT_dec(sv);
4462     return wrote;
4463 }
4464
4465 #undef PerlIO_printf
4466 int
4467 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4468 {
4469     va_list ap;
4470     int result;
4471     va_start(ap, fmt);
4472     result = PerlIO_vprintf(f, fmt, ap);
4473     va_end(ap);
4474     return result;
4475 }
4476
4477 #undef PerlIO_stdoutf
4478 int
4479 PerlIO_stdoutf(const char *fmt, ...)
4480 {
4481     dTHX;
4482     va_list ap;
4483     int result;
4484     va_start(ap, fmt);
4485     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4486     va_end(ap);
4487     return result;
4488 }
4489
4490 #undef PerlIO_tmpfile
4491 PerlIO *
4492 PerlIO_tmpfile(void)
4493 {
4494     /*
4495      * I have no idea how portable mkstemp() is ...
4496      */
4497 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4498     dTHX;
4499     PerlIO *f = NULL;
4500     FILE *stdio = PerlSIO_tmpfile();
4501     if (stdio) {
4502         if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), &PerlIO_stdio, "w+", Nullsv))) {
4503             PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
4504             s->stdio = stdio;
4505         }
4506     }
4507     return f;
4508 #else
4509     dTHX;
4510     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4511     int fd = mkstemp(SvPVX(sv));
4512     PerlIO *f = NULL;
4513     if (fd >= 0) {
4514         f = PerlIO_fdopen(fd, "w+");
4515         if (f) {
4516             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4517         }
4518         PerlLIO_unlink(SvPVX(sv));
4519         SvREFCNT_dec(sv);
4520     }
4521     return f;
4522 #endif
4523 }
4524
4525 #undef HAS_FSETPOS
4526 #undef HAS_FGETPOS
4527
4528 #endif                          /* USE_SFIO */
4529 #endif                          /* PERLIO_IS_STDIO */
4530
4531 /*======================================================================================*/
4532 /*
4533  * Now some functions in terms of above which may be needed even if we are
4534  * not in true PerlIO mode
4535  */
4536
4537 #ifndef HAS_FSETPOS
4538 #undef PerlIO_setpos
4539 int
4540 PerlIO_setpos(PerlIO *f, SV *pos)
4541 {
4542     dTHX;
4543     if (SvOK(pos)) {
4544         STRLEN len;
4545         Off_t *posn = (Off_t *) SvPV(pos, len);
4546         if (f && len == sizeof(Off_t))
4547             return PerlIO_seek(f, *posn, SEEK_SET);
4548     }
4549     SETERRNO(EINVAL, SS$_IVCHAN);
4550     return -1;
4551 }
4552 #else
4553 #undef PerlIO_setpos
4554 int
4555 PerlIO_setpos(PerlIO *f, SV *pos)
4556 {
4557     dTHX;
4558     if (SvOK(pos)) {
4559         STRLEN len;
4560         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4561         if (f && len == sizeof(Fpos_t)) {
4562 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4563             return fsetpos64(f, fpos);
4564 #else
4565             return fsetpos(f, fpos);
4566 #endif
4567         }
4568     }
4569     SETERRNO(EINVAL, SS$_IVCHAN);
4570     return -1;
4571 }
4572 #endif
4573
4574 #ifndef HAS_FGETPOS
4575 #undef PerlIO_getpos
4576 int
4577 PerlIO_getpos(PerlIO *f, SV *pos)
4578 {
4579     dTHX;
4580     Off_t posn = PerlIO_tell(f);
4581     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4582     return (posn == (Off_t) - 1) ? -1 : 0;
4583 }
4584 #else
4585 #undef PerlIO_getpos
4586 int
4587 PerlIO_getpos(PerlIO *f, SV *pos)
4588 {
4589     dTHX;
4590     Fpos_t fpos;
4591     int code;
4592 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4593     code = fgetpos64(f, &fpos);
4594 #else
4595     code = fgetpos(f, &fpos);
4596 #endif
4597     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4598     return code;
4599 }
4600 #endif
4601
4602 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4603
4604 int
4605 vprintf(char *pat, char *args)
4606 {
4607     _doprnt(pat, args, stdout);
4608     return 0;                   /* wrong, but perl doesn't use the return
4609                                  * value */
4610 }
4611
4612 int
4613 vfprintf(FILE *fd, char *pat, char *args)
4614 {
4615     _doprnt(pat, args, fd);
4616     return 0;                   /* wrong, but perl doesn't use the return
4617                                  * value */
4618 }
4619
4620 #endif
4621
4622 #ifndef PerlIO_vsprintf
4623 int
4624 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4625 {
4626     int val = vsprintf(s, fmt, ap);
4627     if (n >= 0) {
4628         if (strlen(s) >= (STRLEN) n) {
4629             dTHX;
4630             (void) PerlIO_puts(Perl_error_log,
4631                                "panic: sprintf overflow - memory corrupted!\n");
4632             my_exit(1);
4633         }
4634     }
4635     return val;
4636 }
4637 #endif
4638
4639 #ifndef PerlIO_sprintf
4640 int
4641 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4642 {
4643     va_list ap;
4644     int result;
4645     va_start(ap, fmt);
4646     result = PerlIO_vsprintf(s, n, fmt, ap);
4647     va_end(ap);
4648     return result;
4649 }
4650 #endif
4651
4652
4653
4654
4655
4656
4657
4658