perlio.c

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