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