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