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