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