perlio.c

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