perlio.c

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