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