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