perlio.c

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