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