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