perlio.c

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