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