perlio.c

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