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     int fd = PerlIO_fileno(o);
2484     if (fd >= 0) {
2485         char buf[8];
2486         FILE *stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o, buf));
2487         if (stdio) {
2488             if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
2489                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2490                 PerlIOUnix_refcnt_inc(fd);
2491             }
2492             else {
2493                 PerlSIO_fclose(stdio);
2494             }
2495         }
2496         else {
2497             PerlLIO_close(fd);
2498             f = NULL;
2499         }
2500     }
2501     return f;
2502 }
2503
2504 IV
2505 PerlIOStdio_close(PerlIO *f)
2506 {
2507     dSYS;
2508 #ifdef SOCKS5_VERSION_NAME
2509     int optval;
2510     Sock_size_t optlen = sizeof(int);
2511 #endif
2512     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2513     if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2514         /* Do not close it but do flush any buffers */
2515         PerlIO_flush(f);
2516         return 0;
2517     }
2518     return (
2519 #ifdef SOCKS5_VERSION_NAME
2520                (getsockopt
2521                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2522                  &optlen) <
2523                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2524 #else
2525                PerlSIO_fclose(stdio)
2526 #endif
2527         );
2528
2529 }
2530
2531
2532
2533 SSize_t
2534 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2535 {
2536     dSYS;
2537     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2538     SSize_t got = 0;
2539     if (count == 1) {
2540         STDCHAR *buf = (STDCHAR *) vbuf;
2541         /*
2542          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2543          * stdio does not do that for fread()
2544          */
2545         int ch = PerlSIO_fgetc(s);
2546         if (ch != EOF) {
2547             *buf = ch;
2548             got = 1;
2549         }
2550     }
2551     else
2552         got = PerlSIO_fread(vbuf, 1, count, s);
2553     return got;
2554 }
2555
2556 SSize_t
2557 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2558 {
2559     dSYS;
2560     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2561     STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2562     SSize_t unread = 0;
2563     while (count > 0) {
2564         int ch = *buf-- & 0xff;
2565         if (PerlSIO_ungetc(ch, s) != ch)
2566             break;
2567         unread++;
2568         count--;
2569     }
2570     return unread;
2571 }
2572
2573 SSize_t
2574 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2575 {
2576     dSYS;
2577     return PerlSIO_fwrite(vbuf, 1, count,
2578                           PerlIOSelf(f, PerlIOStdio)->stdio);
2579 }
2580
2581 IV
2582 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2583 {
2584     dSYS;
2585     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2586     return PerlSIO_fseek(stdio, offset, whence);
2587 }
2588
2589 Off_t
2590 PerlIOStdio_tell(PerlIO *f)
2591 {
2592     dSYS;
2593     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2594     return PerlSIO_ftell(stdio);
2595 }
2596
2597 IV
2598 PerlIOStdio_flush(PerlIO *f)
2599 {
2600     dSYS;
2601     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2602     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2603         return PerlSIO_fflush(stdio);
2604     }
2605     else {
2606 #if 0
2607         /*
2608          * FIXME: This discards ungetc() and pre-read stuff which is not
2609          * right if this is just a "sync" from a layer above Suspect right
2610          * design is to do _this_ but not have layer above flush this
2611          * layer read-to-read
2612          */
2613         /*
2614          * Not writeable - sync by attempting a seek
2615          */
2616         int err = errno;
2617         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2618             errno = err;
2619 #endif
2620     }
2621     return 0;
2622 }
2623
2624 IV
2625 PerlIOStdio_fill(PerlIO *f)
2626 {
2627     dSYS;
2628     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2629     int c;
2630     /*
2631      * fflush()ing read-only streams can cause trouble on some stdio-s
2632      */
2633     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2634         if (PerlSIO_fflush(stdio) != 0)
2635             return EOF;
2636     }
2637     c = PerlSIO_fgetc(stdio);
2638     if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2639         return EOF;
2640     return 0;
2641 }
2642
2643 IV
2644 PerlIOStdio_eof(PerlIO *f)
2645 {
2646     dSYS;
2647     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2648 }
2649
2650 IV
2651 PerlIOStdio_error(PerlIO *f)
2652 {
2653     dSYS;
2654     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2655 }
2656
2657 void
2658 PerlIOStdio_clearerr(PerlIO *f)
2659 {
2660     dSYS;
2661     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2662 }
2663
2664 void
2665 PerlIOStdio_setlinebuf(PerlIO *f)
2666 {
2667     dSYS;
2668 #ifdef HAS_SETLINEBUF
2669     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2670 #else
2671     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2672 #endif
2673 }
2674
2675 #ifdef FILE_base
2676 STDCHAR *
2677 PerlIOStdio_get_base(PerlIO *f)
2678 {
2679     dSYS;
2680     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2681     return PerlSIO_get_base(stdio);
2682 }
2683
2684 Size_t
2685 PerlIOStdio_get_bufsiz(PerlIO *f)
2686 {
2687     dSYS;
2688     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2689     return PerlSIO_get_bufsiz(stdio);
2690 }
2691 #endif
2692
2693 #ifdef USE_STDIO_PTR
2694 STDCHAR *
2695 PerlIOStdio_get_ptr(PerlIO *f)
2696 {
2697     dSYS;
2698     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2699     return PerlSIO_get_ptr(stdio);
2700 }
2701
2702 SSize_t
2703 PerlIOStdio_get_cnt(PerlIO *f)
2704 {
2705     dSYS;
2706     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2707     return PerlSIO_get_cnt(stdio);
2708 }
2709
2710 void
2711 PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2712 {
2713     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2714     dSYS;
2715     if (ptr != NULL) {
2716 #ifdef STDIO_PTR_LVALUE
2717         PerlSIO_set_ptr(stdio, ptr);
2718 #ifdef STDIO_PTR_LVAL_SETS_CNT
2719         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2720             dTHX;
2721             assert(PerlSIO_get_cnt(stdio) == (cnt));
2722         }
2723 #endif
2724 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2725         /*
2726          * Setting ptr _does_ change cnt - we are done
2727          */
2728         return;
2729 #endif
2730 #else                           /* STDIO_PTR_LVALUE */
2731         PerlProc_abort();
2732 #endif                          /* STDIO_PTR_LVALUE */
2733     }
2734     /*
2735      * Now (or only) set cnt
2736      */
2737 #ifdef STDIO_CNT_LVALUE
2738     PerlSIO_set_cnt(stdio, cnt);
2739 #else                           /* STDIO_CNT_LVALUE */
2740 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2741     PerlSIO_set_ptr(stdio,
2742                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2743                                               cnt));
2744 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2745     PerlProc_abort();
2746 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2747 #endif                          /* STDIO_CNT_LVALUE */
2748 }
2749
2750 #endif
2751
2752 PerlIO_funcs PerlIO_stdio = {
2753     "stdio",
2754     sizeof(PerlIOStdio),
2755     PERLIO_K_BUFFERED,
2756     PerlIOBase_pushed,
2757     PerlIOBase_noop_ok,
2758     PerlIOStdio_open,
2759     NULL,
2760     PerlIOStdio_fileno,
2761     PerlIOStdio_dup,
2762     PerlIOStdio_read,
2763     PerlIOStdio_unread,
2764     PerlIOStdio_write,
2765     PerlIOStdio_seek,
2766     PerlIOStdio_tell,
2767     PerlIOStdio_close,
2768     PerlIOStdio_flush,
2769     PerlIOStdio_fill,
2770     PerlIOStdio_eof,
2771     PerlIOStdio_error,
2772     PerlIOStdio_clearerr,
2773     PerlIOStdio_setlinebuf,
2774 #ifdef FILE_base
2775     PerlIOStdio_get_base,
2776     PerlIOStdio_get_bufsiz,
2777 #else
2778     NULL,
2779     NULL,
2780 #endif
2781 #ifdef USE_STDIO_PTR
2782     PerlIOStdio_get_ptr,
2783     PerlIOStdio_get_cnt,
2784 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2785     PerlIOStdio_set_ptrcnt
2786 #else                           /* STDIO_PTR_LVALUE */
2787     NULL
2788 #endif                          /* STDIO_PTR_LVALUE */
2789 #else                           /* USE_STDIO_PTR */
2790     NULL,
2791     NULL,
2792     NULL
2793 #endif                          /* USE_STDIO_PTR */
2794 };
2795
2796 #undef PerlIO_exportFILE
2797 FILE *
2798 PerlIO_exportFILE(PerlIO *f, int fl)
2799 {
2800     FILE *stdio;
2801     PerlIO_flush(f);
2802     stdio = fdopen(PerlIO_fileno(f), "r+");
2803     if (stdio) {
2804         dTHX;
2805         PerlIOStdio *s =
2806             PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2807                        PerlIOStdio);
2808         s->stdio = stdio;
2809     }
2810     return stdio;
2811 }
2812
2813 #undef PerlIO_findFILE
2814 FILE *
2815 PerlIO_findFILE(PerlIO *f)
2816 {
2817     PerlIOl *l = *f;
2818     while (l) {
2819         if (l->tab == &PerlIO_stdio) {
2820             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2821             return s->stdio;
2822         }
2823         l = *PerlIONext(&l);
2824     }
2825     return PerlIO_exportFILE(f, 0);
2826 }
2827
2828 #undef PerlIO_releaseFILE
2829 void
2830 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2831 {
2832 }
2833
2834 /*--------------------------------------------------------------------------------------*/
2835 /*
2836  * perlio buffer layer
2837  */
2838
2839 IV
2840 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2841 {
2842     dSYS;
2843     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2844     int fd = PerlIO_fileno(f);
2845     Off_t posn;
2846     if (fd >= 0 && PerlLIO_isatty(fd)) {
2847         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2848     }
2849     posn = PerlIO_tell(PerlIONext(f));
2850     if (posn != (Off_t) - 1) {
2851         b->posn = posn;
2852     }
2853     return PerlIOBase_pushed(f, mode, arg);
2854 }
2855
2856 PerlIO *
2857 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2858                IV n, const char *mode, int fd, int imode, int perm,
2859                PerlIO *f, int narg, SV **args)
2860 {
2861     if (f) {
2862         PerlIO *next = PerlIONext(f);
2863         PerlIO_funcs *tab =
2864             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2865         next =
2866             (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2867                           next, narg, args);
2868         if (!next
2869             || (*PerlIOBase(f)->tab->Pushed) (f, mode, PerlIOArg) != 0) {
2870             return NULL;
2871         }
2872     }
2873     else {
2874         PerlIO_funcs *tab =
2875             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2876         int init = 0;
2877         if (*mode == 'I') {
2878             init = 1;
2879             /*
2880              * mode++;
2881              */
2882         }
2883         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2884                           NULL, narg, args);
2885         if (f) {
2886             PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2887             fd = PerlIO_fileno(f);
2888 #if (O_BINARY != O_TEXT) && !defined(__BEOS__)
2889             /*
2890              * do something about failing setmode()? --jhi
2891              */
2892             PerlLIO_setmode(fd, O_BINARY);
2893 #endif
2894             if (init && fd == 2) {
2895                 /*
2896                  * Initial stderr is unbuffered
2897                  */
2898                 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2899             }
2900         }
2901     }
2902     return f;
2903 }
2904
2905 /*
2906  * This "flush" is akin to sfio's sync in that it handles files in either
2907  * read or write state
2908  */
2909 IV
2910 PerlIOBuf_flush(PerlIO *f)
2911 {
2912     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2913     int code = 0;
2914     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2915         /*
2916          * write() the buffer
2917          */
2918         STDCHAR *buf = b->buf;
2919         STDCHAR *p = buf;
2920         PerlIO *n = PerlIONext(f);
2921         while (p < b->ptr) {
2922             SSize_t count = PerlIO_write(n, p, b->ptr - p);
2923             if (count > 0) {
2924                 p += count;
2925             }
2926             else if (count < 0 || PerlIO_error(n)) {
2927                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2928                 code = -1;
2929                 break;
2930             }
2931         }
2932         b->posn += (p - buf);
2933     }
2934     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2935         STDCHAR *buf = PerlIO_get_base(f);
2936         /*
2937          * Note position change
2938          */
2939         b->posn += (b->ptr - buf);
2940         if (b->ptr < b->end) {
2941             /*
2942              * We did not consume all of it
2943              */
2944             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
2945                 b->posn = PerlIO_tell(PerlIONext(f));
2946             }
2947         }
2948     }
2949     b->ptr = b->end = b->buf;
2950     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2951     /*
2952      * FIXME: Is this right for read case ?
2953      */
2954     if (PerlIO_flush(PerlIONext(f)) != 0)
2955         code = -1;
2956     return code;
2957 }
2958
2959 IV
2960 PerlIOBuf_fill(PerlIO *f)
2961 {
2962     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2963     PerlIO *n = PerlIONext(f);
2964     SSize_t avail;
2965     /*
2966      * FIXME: doing the down-stream flush is a bad idea if it causes
2967      * pre-read data in stdio buffer to be discarded but this is too
2968      * simplistic - as it skips _our_ hosekeeping and breaks tell tests.
2969      * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
2970      */
2971     if (PerlIO_flush(f) != 0)
2972         return -1;
2973     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2974         PerlIOBase_flush_linebuf();
2975
2976     if (!b->buf)
2977         PerlIO_get_base(f);     /* allocate via vtable */
2978
2979     b->ptr = b->end = b->buf;
2980     if (PerlIO_fast_gets(n)) {
2981         /*
2982          * Layer below is also buffered We do _NOT_ want to call its
2983          * ->Read() because that will loop till it gets what we asked for
2984          * which may hang on a pipe etc. Instead take anything it has to
2985          * hand, or ask it to fill _once_.
2986          */
2987         avail = PerlIO_get_cnt(n);
2988         if (avail <= 0) {
2989             avail = PerlIO_fill(n);
2990             if (avail == 0)
2991                 avail = PerlIO_get_cnt(n);
2992             else {
2993                 if (!PerlIO_error(n) && PerlIO_eof(n))
2994                     avail = 0;
2995             }
2996         }
2997         if (avail > 0) {
2998             STDCHAR *ptr = PerlIO_get_ptr(n);
2999             SSize_t cnt = avail;
3000             if (avail > b->bufsiz)
3001                 avail = b->bufsiz;
3002             Copy(ptr, b->buf, avail, STDCHAR);
3003             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3004         }
3005     }
3006     else {
3007         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3008     }
3009     if (avail <= 0) {
3010         if (avail == 0)
3011             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3012         else
3013             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3014         return -1;
3015     }
3016     b->end = b->buf + avail;
3017     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3018     return 0;
3019 }
3020
3021 SSize_t
3022 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
3023 {
3024     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3025     if (f) {
3026         if (!b->ptr)
3027             PerlIO_get_base(f);
3028         return PerlIOBase_read(f, vbuf, count);
3029     }
3030     return 0;
3031 }
3032
3033 SSize_t
3034 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
3035 {
3036     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3037     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3038     SSize_t unread = 0;
3039     SSize_t avail;
3040     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3041         PerlIO_flush(f);
3042     if (!b->buf)
3043         PerlIO_get_base(f);
3044     if (b->buf) {
3045         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3046             /*
3047              * Buffer is already a read buffer, we can overwrite any chars
3048              * which have been read back to buffer start
3049              */
3050             avail = (b->ptr - b->buf);
3051         }
3052         else {
3053             /*
3054              * Buffer is idle, set it up so whole buffer is available for
3055              * unread
3056              */
3057             avail = b->bufsiz;
3058             b->end = b->buf + avail;
3059             b->ptr = b->end;
3060             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3061             /*
3062              * Buffer extends _back_ from where we are now
3063              */
3064             b->posn -= b->bufsiz;
3065         }
3066         if (avail > (SSize_t) count) {
3067             /*
3068              * If we have space for more than count, just move count
3069              */
3070             avail = count;
3071         }
3072         if (avail > 0) {
3073             b->ptr -= avail;
3074             buf -= avail;
3075             /*
3076              * In simple stdio-like ungetc() case chars will be already
3077              * there
3078              */
3079             if (buf != b->ptr) {
3080                 Copy(buf, b->ptr, avail, STDCHAR);
3081             }
3082             count -= avail;
3083             unread += avail;
3084             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3085         }
3086     }
3087     return unread;
3088 }
3089
3090 SSize_t
3091 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
3092 {
3093     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3094     const STDCHAR *buf = (const STDCHAR *) vbuf;
3095     Size_t written = 0;
3096     if (!b->buf)
3097         PerlIO_get_base(f);
3098     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3099         return 0;
3100     while (count > 0) {
3101         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3102         if ((SSize_t) count < avail)
3103             avail = count;
3104         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3105         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3106             while (avail > 0) {
3107                 int ch = *buf++;
3108                 *(b->ptr)++ = ch;
3109                 count--;
3110                 avail--;
3111                 written++;
3112                 if (ch == '\n') {
3113                     PerlIO_flush(f);
3114                     break;
3115                 }
3116             }
3117         }
3118         else {
3119             if (avail) {
3120                 Copy(buf, b->ptr, avail, STDCHAR);
3121                 count -= avail;
3122                 buf += avail;
3123                 written += avail;
3124                 b->ptr += avail;
3125             }
3126         }
3127         if (b->ptr >= (b->buf + b->bufsiz))
3128             PerlIO_flush(f);
3129     }
3130     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3131         PerlIO_flush(f);
3132     return written;
3133 }
3134
3135 IV
3136 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
3137 {
3138     IV code;
3139     if ((code = PerlIO_flush(f)) == 0) {
3140         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3141         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3142         code = PerlIO_seek(PerlIONext(f), offset, whence);
3143         if (code == 0) {
3144             b->posn = PerlIO_tell(PerlIONext(f));
3145         }
3146     }
3147     return code;
3148 }
3149
3150 Off_t
3151 PerlIOBuf_tell(PerlIO *f)
3152 {
3153     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3154     /*
3155      * b->posn is file position where b->buf was read, or will be written
3156      */
3157     Off_t posn = b->posn;
3158     if (b->buf) {
3159         /*
3160          * If buffer is valid adjust position by amount in buffer
3161          */
3162         posn += (b->ptr - b->buf);
3163     }
3164     return posn;
3165 }
3166
3167 IV
3168 PerlIOBuf_close(PerlIO *f)
3169 {
3170     IV code = PerlIOBase_close(f);
3171     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3172     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3173         Safefree(b->buf);
3174     }
3175     b->buf = NULL;
3176     b->ptr = b->end = b->buf;
3177     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3178     return code;
3179 }
3180
3181 STDCHAR *
3182 PerlIOBuf_get_ptr(PerlIO *f)
3183 {
3184     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3185     if (!b->buf)
3186         PerlIO_get_base(f);
3187     return b->ptr;
3188 }
3189
3190 SSize_t
3191 PerlIOBuf_get_cnt(PerlIO *f)
3192 {
3193     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3194     if (!b->buf)
3195         PerlIO_get_base(f);
3196     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3197         return (b->end - b->ptr);
3198     return 0;
3199 }
3200
3201 STDCHAR *
3202 PerlIOBuf_get_base(PerlIO *f)
3203 {
3204     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3205     if (!b->buf) {
3206         if (!b->bufsiz)
3207             b->bufsiz = 4096;
3208         b->buf =
3209         Newz('B',b->buf,b->bufsiz, STDCHAR);
3210         if (!b->buf) {
3211             b->buf = (STDCHAR *) & b->oneword;
3212             b->bufsiz = sizeof(b->oneword);
3213         }
3214         b->ptr = b->buf;
3215         b->end = b->ptr;
3216     }
3217     return b->buf;
3218 }
3219
3220 Size_t
3221 PerlIOBuf_bufsiz(PerlIO *f)
3222 {
3223     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3224     if (!b->buf)
3225         PerlIO_get_base(f);
3226     return (b->end - b->buf);
3227 }
3228
3229 void
3230 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3231 {
3232     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3233     if (!b->buf)
3234         PerlIO_get_base(f);
3235     b->ptr = ptr;
3236     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3237         dTHX;
3238         assert(PerlIO_get_cnt(f) == cnt);
3239         assert(b->ptr >= b->buf);
3240     }
3241     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3242 }
3243
3244 PerlIO *
3245 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
3246 {
3247  return PerlIOBase_dup(aTHX_ f, o, param);
3248 }
3249
3250
3251
3252 PerlIO_funcs PerlIO_perlio = {
3253     "perlio",
3254     sizeof(PerlIOBuf),
3255     PERLIO_K_BUFFERED,
3256     PerlIOBuf_pushed,
3257     PerlIOBase_noop_ok,
3258     PerlIOBuf_open,
3259     NULL,
3260     PerlIOBase_fileno,
3261     PerlIOBuf_dup,
3262     PerlIOBuf_read,
3263     PerlIOBuf_unread,
3264     PerlIOBuf_write,
3265     PerlIOBuf_seek,
3266     PerlIOBuf_tell,
3267     PerlIOBuf_close,
3268     PerlIOBuf_flush,
3269     PerlIOBuf_fill,
3270     PerlIOBase_eof,
3271     PerlIOBase_error,
3272     PerlIOBase_clearerr,
3273     PerlIOBase_setlinebuf,
3274     PerlIOBuf_get_base,
3275     PerlIOBuf_bufsiz,
3276     PerlIOBuf_get_ptr,
3277     PerlIOBuf_get_cnt,
3278     PerlIOBuf_set_ptrcnt,
3279 };
3280
3281 /*--------------------------------------------------------------------------------------*/
3282 /*
3283  * Temp layer to hold unread chars when cannot do it any other way
3284  */
3285
3286 IV
3287 PerlIOPending_fill(PerlIO *f)
3288 {
3289     /*
3290      * Should never happen
3291      */
3292     PerlIO_flush(f);
3293     return 0;
3294 }
3295
3296 IV
3297 PerlIOPending_close(PerlIO *f)
3298 {
3299     /*
3300      * A tad tricky - flush pops us, then we close new top
3301      */
3302     PerlIO_flush(f);
3303     return PerlIO_close(f);
3304 }
3305
3306 IV
3307 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3308 {
3309     /*
3310      * A tad tricky - flush pops us, then we seek new top
3311      */
3312     PerlIO_flush(f);
3313     return PerlIO_seek(f, offset, whence);
3314 }
3315
3316
3317 IV
3318 PerlIOPending_flush(PerlIO *f)
3319 {
3320     dTHX;
3321     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3322     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3323         Safefree(b->buf);
3324         b->buf = NULL;
3325     }
3326     PerlIO_pop(aTHX_ f);
3327     return 0;
3328 }
3329
3330 void
3331 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3332 {
3333     if (cnt <= 0) {
3334         PerlIO_flush(f);
3335     }
3336     else {
3337         PerlIOBuf_set_ptrcnt(f, ptr, cnt);
3338     }
3339 }
3340
3341 IV
3342 PerlIOPending_pushed(PerlIO *f, const char *mode, SV *arg)
3343 {
3344     IV code = PerlIOBase_pushed(f, mode, arg);
3345     PerlIOl *l = PerlIOBase(f);
3346     /*
3347      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3348      * etc. get muddled when it changes mid-string when we auto-pop.
3349      */
3350     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3351         (PerlIOBase(PerlIONext(f))->
3352          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3353     return code;
3354 }
3355
3356 SSize_t
3357 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3358 {
3359     SSize_t avail = PerlIO_get_cnt(f);
3360     SSize_t got = 0;
3361     if (count < avail)
3362         avail = count;
3363     if (avail > 0)
3364         got = PerlIOBuf_read(f, vbuf, avail);
3365     if (got >= 0 && got < count) {
3366         SSize_t more =
3367             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3368         if (more >= 0 || got == 0)
3369             got += more;
3370     }
3371     return got;
3372 }
3373
3374 PerlIO_funcs PerlIO_pending = {
3375     "pending",
3376     sizeof(PerlIOBuf),
3377     PERLIO_K_BUFFERED,
3378     PerlIOPending_pushed,
3379     PerlIOBase_noop_ok,
3380     NULL,
3381     NULL,
3382     PerlIOBase_fileno,
3383     PerlIOBuf_dup,
3384     PerlIOPending_read,
3385     PerlIOBuf_unread,
3386     PerlIOBuf_write,
3387     PerlIOPending_seek,
3388     PerlIOBuf_tell,
3389     PerlIOPending_close,
3390     PerlIOPending_flush,
3391     PerlIOPending_fill,
3392     PerlIOBase_eof,
3393     PerlIOBase_error,
3394     PerlIOBase_clearerr,
3395     PerlIOBase_setlinebuf,
3396     PerlIOBuf_get_base,
3397     PerlIOBuf_bufsiz,
3398     PerlIOBuf_get_ptr,
3399     PerlIOBuf_get_cnt,
3400     PerlIOPending_set_ptrcnt,
3401 };
3402
3403
3404
3405 /*--------------------------------------------------------------------------------------*/
3406 /*
3407  * crlf - translation On read translate CR,LF to "\n" we do this by
3408  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3409  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3410  */
3411
3412 typedef struct {
3413     PerlIOBuf base;             /* PerlIOBuf stuff */
3414     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3415                                  * buffer */
3416 } PerlIOCrlf;
3417
3418 IV
3419 PerlIOCrlf_pushed(PerlIO *f, const char *mode, SV *arg)
3420 {
3421     IV code;
3422     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3423     code = PerlIOBuf_pushed(f, mode, arg);
3424 #if 0
3425     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3426                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3427                  PerlIOBase(f)->flags);
3428 #endif
3429     return code;
3430 }
3431
3432
3433 SSize_t
3434 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3435 {
3436     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3437     if (c->nl) {
3438         *(c->nl) = 0xd;
3439         c->nl = NULL;
3440     }
3441     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3442         return PerlIOBuf_unread(f, vbuf, count);
3443     else {
3444         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3445         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3446         SSize_t unread = 0;
3447         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3448             PerlIO_flush(f);
3449         if (!b->buf)
3450             PerlIO_get_base(f);
3451         if (b->buf) {
3452             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3453                 b->end = b->ptr = b->buf + b->bufsiz;
3454                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3455                 b->posn -= b->bufsiz;
3456             }
3457             while (count > 0 && b->ptr > b->buf) {
3458                 int ch = *--buf;
3459                 if (ch == '\n') {
3460                     if (b->ptr - 2 >= b->buf) {
3461                         *--(b->ptr) = 0xa;
3462                         *--(b->ptr) = 0xd;
3463                         unread++;
3464                         count--;
3465                     }
3466                     else {
3467                         buf++;
3468                         break;
3469                     }
3470                 }
3471                 else {
3472                     *--(b->ptr) = ch;
3473                     unread++;
3474                     count--;
3475                 }
3476             }
3477         }
3478         return unread;
3479     }
3480 }
3481
3482 SSize_t
3483 PerlIOCrlf_get_cnt(PerlIO *f)
3484 {
3485     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3486     if (!b->buf)
3487         PerlIO_get_base(f);
3488     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3489         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3490         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) {
3491             STDCHAR *nl = b->ptr;
3492           scan:
3493             while (nl < b->end && *nl != 0xd)
3494                 nl++;
3495             if (nl < b->end && *nl == 0xd) {
3496               test:
3497                 if (nl + 1 < b->end) {
3498                     if (nl[1] == 0xa) {
3499                         *nl = '\n';
3500                         c->nl = nl;
3501                     }
3502                     else {
3503                         /*
3504                          * Not CR,LF but just CR
3505                          */
3506                         nl++;
3507                         goto scan;
3508                     }
3509                 }
3510                 else {
3511                     /*
3512                      * Blast - found CR as last char in buffer
3513                      */
3514                     if (b->ptr < nl) {
3515                         /*
3516                          * They may not care, defer work as long as
3517                          * possible
3518                          */
3519                         return (nl - b->ptr);
3520                     }
3521                     else {
3522                         int code;
3523                         b->ptr++;       /* say we have read it as far as
3524                                          * flush() is concerned */
3525                         b->buf++;       /* Leave space an front of buffer */
3526                         b->bufsiz--;    /* Buffer is thus smaller */
3527                         code = PerlIO_fill(f);  /* Fetch some more */
3528                         b->bufsiz++;    /* Restore size for next time */
3529                         b->buf--;       /* Point at space */
3530                         b->ptr = nl = b->buf;   /* Which is what we hand
3531                                                  * off */
3532                         b->posn--;      /* Buffer starts here */
3533                         *nl = 0xd;      /* Fill in the CR */
3534                         if (code == 0)
3535                             goto test;  /* fill() call worked */
3536                         /*
3537                          * CR at EOF - just fall through
3538                          */
3539                     }
3540                 }
3541             }
3542         }
3543         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3544     }
3545     return 0;
3546 }
3547
3548 void
3549 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3550 {
3551     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3552     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3553     IV flags = PerlIOBase(f)->flags;
3554     if (!b->buf)
3555         PerlIO_get_base(f);
3556     if (!ptr) {
3557         if (c->nl)
3558             ptr = c->nl + 1;
3559         else {
3560             ptr = b->end;
3561             if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3562                 ptr--;
3563         }
3564         ptr -= cnt;
3565     }
3566     else {
3567         /*
3568          * Test code - delete when it works ...
3569          */
3570         STDCHAR *chk;
3571         if (c->nl)
3572             chk = c->nl + 1;
3573         else {
3574             chk = b->end;
3575             if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3576                 chk--;
3577         }
3578         chk -= cnt;
3579
3580         if (ptr != chk) {
3581             dTHX;
3582             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3583                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3584                        b->end, cnt);
3585         }
3586     }
3587     if (c->nl) {
3588         if (ptr > c->nl) {
3589             /*
3590              * They have taken what we lied about
3591              */
3592             *(c->nl) = 0xd;
3593             c->nl = NULL;
3594             ptr++;
3595         }
3596     }
3597     b->ptr = ptr;
3598     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3599 }
3600
3601 SSize_t
3602 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3603 {
3604     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3605         return PerlIOBuf_write(f, vbuf, count);
3606     else {
3607         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3608         const STDCHAR *buf = (const STDCHAR *) vbuf;
3609         const STDCHAR *ebuf = buf + count;
3610         if (!b->buf)
3611             PerlIO_get_base(f);
3612         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3613             return 0;
3614         while (buf < ebuf) {
3615             STDCHAR *eptr = b->buf + b->bufsiz;
3616             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3617             while (buf < ebuf && b->ptr < eptr) {
3618                 if (*buf == '\n') {
3619                     if ((b->ptr + 2) > eptr) {
3620                         /*
3621                          * Not room for both
3622                          */
3623                         PerlIO_flush(f);
3624                         break;
3625                     }
3626                     else {
3627                         *(b->ptr)++ = 0xd;      /* CR */
3628                         *(b->ptr)++ = 0xa;      /* LF */
3629                         buf++;
3630                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3631                             PerlIO_flush(f);
3632                             break;
3633                         }
3634                     }
3635                 }
3636                 else {
3637                     int ch = *buf++;
3638                     *(b->ptr)++ = ch;
3639                 }
3640                 if (b->ptr >= eptr) {
3641                     PerlIO_flush(f);
3642                     break;
3643                 }
3644             }
3645         }
3646         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3647             PerlIO_flush(f);
3648         return (buf - (STDCHAR *) vbuf);
3649     }
3650 }
3651
3652 IV
3653 PerlIOCrlf_flush(PerlIO *f)
3654 {
3655     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3656     if (c->nl) {
3657         *(c->nl) = 0xd;
3658         c->nl = NULL;
3659     }
3660     return PerlIOBuf_flush(f);
3661 }
3662
3663 PerlIO_funcs PerlIO_crlf = {
3664     "crlf",
3665     sizeof(PerlIOCrlf),
3666     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3667     PerlIOCrlf_pushed,
3668     PerlIOBase_noop_ok,         /* popped */
3669     PerlIOBuf_open,
3670     NULL,
3671     PerlIOBase_fileno,
3672     PerlIOBuf_dup,
3673     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3674                                  * ... */
3675     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3676     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3677     PerlIOBuf_seek,
3678     PerlIOBuf_tell,
3679     PerlIOBuf_close,
3680     PerlIOCrlf_flush,
3681     PerlIOBuf_fill,
3682     PerlIOBase_eof,
3683     PerlIOBase_error,
3684     PerlIOBase_clearerr,
3685     PerlIOBase_setlinebuf,
3686     PerlIOBuf_get_base,
3687     PerlIOBuf_bufsiz,
3688     PerlIOBuf_get_ptr,
3689     PerlIOCrlf_get_cnt,
3690     PerlIOCrlf_set_ptrcnt,
3691 };
3692
3693 #ifdef HAS_MMAP
3694 /*--------------------------------------------------------------------------------------*/
3695 /*
3696  * mmap as "buffer" layer
3697  */
3698
3699 typedef struct {
3700     PerlIOBuf base;             /* PerlIOBuf stuff */
3701     Mmap_t mptr;                /* Mapped address */
3702     Size_t len;                 /* mapped length */
3703     STDCHAR *bbuf;              /* malloced buffer if map fails */
3704 } PerlIOMmap;
3705
3706 static size_t page_size = 0;
3707
3708 IV
3709 PerlIOMmap_map(PerlIO *f)
3710 {
3711     dTHX;
3712     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3713     IV flags = PerlIOBase(f)->flags;
3714     IV code = 0;
3715     if (m->len)
3716         abort();
3717     if (flags & PERLIO_F_CANREAD) {
3718         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3719         int fd = PerlIO_fileno(f);
3720         Stat_t st;
3721         code = Fstat(fd, &st);
3722         if (code == 0 && S_ISREG(st.st_mode)) {
3723             SSize_t len = st.st_size - b->posn;
3724             if (len > 0) {
3725                 Off_t posn;
3726                 if (!page_size) {
3727 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3728                     {
3729                         SETERRNO(0, SS$_NORMAL);
3730 #   ifdef _SC_PAGESIZE
3731                         page_size = sysconf(_SC_PAGESIZE);
3732 #   else
3733                         page_size = sysconf(_SC_PAGE_SIZE);
3734 #   endif
3735                         if ((long) page_size < 0) {
3736                             if (errno) {
3737                                 SV *error = ERRSV;
3738                                 char *msg;
3739                                 STRLEN n_a;
3740                                 (void) SvUPGRADE(error, SVt_PV);
3741                                 msg = SvPVx(error, n_a);
3742                                 Perl_croak(aTHX_ "panic: sysconf: %s",
3743                                            msg);
3744                             }
3745                             else
3746                                 Perl_croak(aTHX_
3747                                            "panic: sysconf: pagesize unknown");
3748                         }
3749                     }
3750 #else
3751 #   ifdef HAS_GETPAGESIZE
3752                     page_size = getpagesize();
3753 #   else
3754 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3755                     page_size = PAGESIZE;       /* compiletime, bad */
3756 #       endif
3757 #   endif
3758 #endif
3759                     if ((IV) page_size <= 0)
3760                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3761                                    (IV) page_size);
3762                 }
3763                 if (b->posn < 0) {
3764                     /*
3765                      * This is a hack - should never happen - open should
3766                      * have set it !
3767                      */
3768                     b->posn = PerlIO_tell(PerlIONext(f));
3769                 }
3770                 posn = (b->posn / page_size) * page_size;
3771                 len = st.st_size - posn;
3772                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3773                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3774 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3775                     madvise(m->mptr, len, MADV_SEQUENTIAL);
3776 #endif
3777 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3778                     madvise(m->mptr, len, MADV_WILLNEED);
3779 #endif
3780                     PerlIOBase(f)->flags =
3781                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3782                     b->end = ((STDCHAR *) m->mptr) + len;
3783                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3784                     b->ptr = b->buf;
3785                     m->len = len;
3786                 }
3787                 else {
3788                     b->buf = NULL;
3789                 }
3790             }
3791             else {
3792                 PerlIOBase(f)->flags =
3793                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3794                 b->buf = NULL;
3795                 b->ptr = b->end = b->ptr;
3796                 code = -1;
3797             }
3798         }
3799     }
3800     return code;
3801 }
3802
3803 IV
3804 PerlIOMmap_unmap(PerlIO *f)
3805 {
3806     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3807     PerlIOBuf *b = &m->base;
3808     IV code = 0;
3809     if (m->len) {
3810         if (b->buf) {
3811             code = munmap(m->mptr, m->len);
3812             b->buf = NULL;
3813             m->len = 0;
3814             m->mptr = NULL;
3815             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3816                 code = -1;
3817         }
3818         b->ptr = b->end = b->buf;
3819         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3820     }
3821     return code;
3822 }
3823
3824 STDCHAR *
3825 PerlIOMmap_get_base(PerlIO *f)
3826 {
3827     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3828     PerlIOBuf *b = &m->base;
3829     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3830         /*
3831          * Already have a readbuffer in progress
3832          */
3833         return b->buf;
3834     }
3835     if (b->buf) {
3836         /*
3837          * We have a write buffer or flushed PerlIOBuf read buffer
3838          */
3839         m->bbuf = b->buf;       /* save it in case we need it again */
3840         b->buf = NULL;          /* Clear to trigger below */
3841     }
3842     if (!b->buf) {
3843         PerlIOMmap_map(f);      /* Try and map it */
3844         if (!b->buf) {
3845             /*
3846              * Map did not work - recover PerlIOBuf buffer if we have one
3847              */
3848             b->buf = m->bbuf;
3849         }
3850     }
3851     b->ptr = b->end = b->buf;
3852     if (b->buf)
3853         return b->buf;
3854     return PerlIOBuf_get_base(f);
3855 }
3856
3857 SSize_t
3858 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3859 {
3860     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3861     PerlIOBuf *b = &m->base;
3862     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3863         PerlIO_flush(f);
3864     if (b->ptr && (b->ptr - count) >= b->buf
3865         && memEQ(b->ptr - count, vbuf, count)) {
3866         b->ptr -= count;
3867         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3868         return count;
3869     }
3870     if (m->len) {
3871         /*
3872          * Loose the unwritable mapped buffer
3873          */
3874         PerlIO_flush(f);
3875         /*
3876          * If flush took the "buffer" see if we have one from before
3877          */
3878         if (!b->buf && m->bbuf)
3879             b->buf = m->bbuf;
3880         if (!b->buf) {
3881             PerlIOBuf_get_base(f);
3882             m->bbuf = b->buf;
3883         }
3884     }
3885     return PerlIOBuf_unread(f, vbuf, count);
3886 }
3887
3888 SSize_t
3889 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3890 {
3891     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3892     PerlIOBuf *b = &m->base;
3893     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3894         /*
3895          * No, or wrong sort of, buffer
3896          */
3897         if (m->len) {
3898             if (PerlIOMmap_unmap(f) != 0)
3899                 return 0;
3900         }
3901         /*
3902          * If unmap took the "buffer" see if we have one from before
3903          */
3904         if (!b->buf && m->bbuf)
3905             b->buf = m->bbuf;
3906         if (!b->buf) {
3907             PerlIOBuf_get_base(f);
3908             m->bbuf = b->buf;
3909         }
3910     }
3911     return PerlIOBuf_write(f, vbuf, count);
3912 }
3913
3914 IV
3915 PerlIOMmap_flush(PerlIO *f)
3916 {
3917     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3918     PerlIOBuf *b = &m->base;
3919     IV code = PerlIOBuf_flush(f);
3920     /*
3921      * Now we are "synced" at PerlIOBuf level
3922      */
3923     if (b->buf) {
3924         if (m->len) {
3925             /*
3926              * Unmap the buffer
3927              */
3928             if (PerlIOMmap_unmap(f) != 0)
3929                 code = -1;
3930         }
3931         else {
3932             /*
3933              * We seem to have a PerlIOBuf buffer which was not mapped
3934              * remember it in case we need one later
3935              */
3936             m->bbuf = b->buf;
3937         }
3938     }
3939     return code;
3940 }
3941
3942 IV
3943 PerlIOMmap_fill(PerlIO *f)
3944 {
3945     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3946     IV code = PerlIO_flush(f);
3947     if (code == 0 && !b->buf) {
3948         code = PerlIOMmap_map(f);
3949     }
3950     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3951         code = PerlIOBuf_fill(f);
3952     }
3953     return code;
3954 }
3955
3956 IV
3957 PerlIOMmap_close(PerlIO *f)
3958 {
3959     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3960     PerlIOBuf *b = &m->base;
3961     IV code = PerlIO_flush(f);
3962     if (m->bbuf) {
3963         b->buf = m->bbuf;
3964         m->bbuf = NULL;
3965         b->ptr = b->end = b->buf;
3966     }
3967     if (PerlIOBuf_close(f) != 0)
3968         code = -1;
3969     return code;
3970 }
3971
3972 PerlIO *
3973 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
3974 {
3975  return PerlIOBase_dup(aTHX_ f, o, param);
3976 }
3977
3978
3979 PerlIO_funcs PerlIO_mmap = {
3980     "mmap",
3981     sizeof(PerlIOMmap),
3982     PERLIO_K_BUFFERED,
3983     PerlIOBuf_pushed,
3984     PerlIOBase_noop_ok,
3985     PerlIOBuf_open,
3986     NULL,
3987     PerlIOBase_fileno,
3988     PerlIOMmap_dup,
3989     PerlIOBuf_read,
3990     PerlIOMmap_unread,
3991     PerlIOMmap_write,
3992     PerlIOBuf_seek,
3993     PerlIOBuf_tell,
3994     PerlIOBuf_close,
3995     PerlIOMmap_flush,
3996     PerlIOMmap_fill,
3997     PerlIOBase_eof,
3998     PerlIOBase_error,
3999     PerlIOBase_clearerr,
4000     PerlIOBase_setlinebuf,
4001     PerlIOMmap_get_base,
4002     PerlIOBuf_bufsiz,
4003     PerlIOBuf_get_ptr,
4004     PerlIOBuf_get_cnt,
4005     PerlIOBuf_set_ptrcnt,
4006 };
4007
4008 #endif                          /* HAS_MMAP */
4009
4010 #undef PerlIO_stdin
4011 PerlIO *
4012 PerlIO_stdin(void)
4013 {
4014     dTHX;
4015     if (!PL_perlio) {
4016         PerlIO_stdstreams(aTHX);
4017     }
4018     return &PL_perlio[1];
4019 }
4020
4021 #undef PerlIO_stdout
4022 PerlIO *
4023 PerlIO_stdout(void)
4024 {
4025     dTHX;
4026     if (!PL_perlio) {
4027         PerlIO_stdstreams(aTHX);
4028     }
4029     return &PL_perlio[2];
4030 }
4031
4032 #undef PerlIO_stderr
4033 PerlIO *
4034 PerlIO_stderr(void)
4035 {
4036     dTHX;
4037     if (!PL_perlio) {
4038         PerlIO_stdstreams(aTHX);
4039     }
4040     return &PL_perlio[3];
4041 }
4042
4043 /*--------------------------------------------------------------------------------------*/
4044
4045 #undef PerlIO_getname
4046 char *
4047 PerlIO_getname(PerlIO *f, char *buf)
4048 {
4049     dTHX;
4050     char *name = NULL;
4051 #ifdef VMS
4052     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4053     if (stdio)
4054         name = fgetname(stdio, buf);
4055 #else
4056     Perl_croak(aTHX_ "Don't know how to get file name");
4057 #endif
4058     return name;
4059 }
4060
4061
4062 /*--------------------------------------------------------------------------------------*/
4063 /*
4064  * Functions which can be called on any kind of PerlIO implemented in
4065  * terms of above
4066  */
4067
4068 #undef PerlIO_getc
4069 int
4070 PerlIO_getc(PerlIO *f)
4071 {
4072     STDCHAR buf[1];
4073     SSize_t count = PerlIO_read(f, buf, 1);
4074     if (count == 1) {
4075         return (unsigned char) buf[0];
4076     }
4077     return EOF;
4078 }
4079
4080 #undef PerlIO_ungetc
4081 int
4082 PerlIO_ungetc(PerlIO *f, int ch)
4083 {
4084     if (ch != EOF) {
4085         STDCHAR buf = ch;
4086         if (PerlIO_unread(f, &buf, 1) == 1)
4087             return ch;
4088     }
4089     return EOF;
4090 }
4091
4092 #undef PerlIO_putc
4093 int
4094 PerlIO_putc(PerlIO *f, int ch)
4095 {
4096     STDCHAR buf = ch;
4097     return PerlIO_write(f, &buf, 1);
4098 }
4099
4100 #undef PerlIO_puts
4101 int
4102 PerlIO_puts(PerlIO *f, const char *s)
4103 {
4104     STRLEN len = strlen(s);
4105     return PerlIO_write(f, s, len);
4106 }
4107
4108 #undef PerlIO_rewind
4109 void
4110 PerlIO_rewind(PerlIO *f)
4111 {
4112     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4113     PerlIO_clearerr(f);
4114 }
4115
4116 #undef PerlIO_vprintf
4117 int
4118 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4119 {
4120     dTHX;
4121     SV *sv = newSVpvn("", 0);
4122     char *s;
4123     STRLEN len;
4124     SSize_t wrote;
4125 #ifdef NEED_VA_COPY
4126     va_list apc;
4127     Perl_va_copy(ap, apc);
4128     sv_vcatpvf(sv, fmt, &apc);
4129 #else
4130     sv_vcatpvf(sv, fmt, &ap);
4131 #endif
4132     s = SvPV(sv, len);
4133     wrote = PerlIO_write(f, s, len);
4134     SvREFCNT_dec(sv);
4135     return wrote;
4136 }
4137
4138 #undef PerlIO_printf
4139 int
4140 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4141 {
4142     va_list ap;
4143     int result;
4144     va_start(ap, fmt);
4145     result = PerlIO_vprintf(f, fmt, ap);
4146     va_end(ap);
4147     return result;
4148 }
4149
4150 #undef PerlIO_stdoutf
4151 int
4152 PerlIO_stdoutf(const char *fmt, ...)
4153 {
4154     va_list ap;
4155     int result;
4156     va_start(ap, fmt);
4157     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4158     va_end(ap);
4159     return result;
4160 }
4161
4162 #undef PerlIO_tmpfile
4163 PerlIO *
4164 PerlIO_tmpfile(void)
4165 {
4166     /*
4167      * I have no idea how portable mkstemp() is ...
4168      */
4169 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4170     dTHX;
4171     PerlIO *f = NULL;
4172     FILE *stdio = PerlSIO_tmpfile();
4173     if (stdio) {
4174         PerlIOStdio *s =
4175             PerlIOSelf(PerlIO_push
4176                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4177                         "w+", Nullsv), PerlIOStdio);
4178         s->stdio = stdio;
4179     }
4180     return f;
4181 #else
4182     dTHX;
4183     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4184     int fd = mkstemp(SvPVX(sv));
4185     PerlIO *f = NULL;
4186     if (fd >= 0) {
4187         f = PerlIO_fdopen(fd, "w+");
4188         if (f) {
4189             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4190         }
4191         PerlLIO_unlink(SvPVX(sv));
4192         SvREFCNT_dec(sv);
4193     }
4194     return f;
4195 #endif
4196 }
4197
4198 #undef HAS_FSETPOS
4199 #undef HAS_FGETPOS
4200
4201 #endif                          /* USE_SFIO */
4202 #endif                          /* PERLIO_IS_STDIO */
4203
4204 /*======================================================================================*/
4205 /*
4206  * Now some functions in terms of above which may be needed even if we are
4207  * not in true PerlIO mode
4208  */
4209
4210 #ifndef HAS_FSETPOS
4211 #undef PerlIO_setpos
4212 int
4213 PerlIO_setpos(PerlIO *f, SV *pos)
4214 {
4215     dTHX;
4216     if (SvOK(pos)) {
4217         STRLEN len;
4218         Off_t *posn = (Off_t *) SvPV(pos, len);
4219         if (f && len == sizeof(Off_t))
4220             return PerlIO_seek(f, *posn, SEEK_SET);
4221     }
4222     SETERRNO(EINVAL, SS$_IVCHAN);
4223     return -1;
4224 }
4225 #else
4226 #undef PerlIO_setpos
4227 int
4228 PerlIO_setpos(PerlIO *f, SV *pos)
4229 {
4230     dTHX;
4231     if (SvOK(pos)) {
4232         STRLEN len;
4233         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4234         if (f && len == sizeof(Fpos_t)) {
4235 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4236             return fsetpos64(f, fpos);
4237 #else
4238             return fsetpos(f, fpos);
4239 #endif
4240         }
4241     }
4242     SETERRNO(EINVAL, SS$_IVCHAN);
4243     return -1;
4244 }
4245 #endif
4246
4247 #ifndef HAS_FGETPOS
4248 #undef PerlIO_getpos
4249 int
4250 PerlIO_getpos(PerlIO *f, SV *pos)
4251 {
4252     dTHX;
4253     Off_t posn = PerlIO_tell(f);
4254     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4255     return (posn == (Off_t) - 1) ? -1 : 0;
4256 }
4257 #else
4258 #undef PerlIO_getpos
4259 int
4260 PerlIO_getpos(PerlIO *f, SV *pos)
4261 {
4262     dTHX;
4263     Fpos_t fpos;
4264     int code;
4265 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4266     code = fgetpos64(f, &fpos);
4267 #else
4268     code = fgetpos(f, &fpos);
4269 #endif
4270     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4271     return code;
4272 }
4273 #endif
4274
4275 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4276
4277 int
4278 vprintf(char *pat, char *args)
4279 {
4280     _doprnt(pat, args, stdout);
4281     return 0;                   /* wrong, but perl doesn't use the return
4282                                  * value */
4283 }
4284
4285 int
4286 vfprintf(FILE *fd, char *pat, char *args)
4287 {
4288     _doprnt(pat, args, fd);
4289     return 0;                   /* wrong, but perl doesn't use the return
4290                                  * value */
4291 }
4292
4293 #endif
4294
4295 #ifndef PerlIO_vsprintf
4296 int
4297 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4298 {
4299     int val = vsprintf(s, fmt, ap);
4300     if (n >= 0) {
4301         if (strlen(s) >= (STRLEN) n) {
4302             dTHX;
4303             (void) PerlIO_puts(Perl_error_log,
4304                                "panic: sprintf overflow - memory corrupted!\n");
4305             my_exit(1);
4306         }
4307     }
4308     return val;
4309 }
4310 #endif
4311
4312 #ifndef PerlIO_sprintf
4313 int
4314 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4315 {
4316     va_list ap;
4317     int result;
4318     va_start(ap, fmt);
4319     result = PerlIO_vsprintf(s, n, fmt, ap);
4320     va_end(ap);
4321     return result;
4322 }
4323 #endif
4324
4325
4326
4327
4328