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