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)
 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)
 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);
 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     PerlIO_flush(f);
1076     if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) {
1077         PerlIO *top = f;
1078         while (*top) {
1079             if (PerlIOBase(top)->tab == &PerlIO_crlf) {
1080                 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
1081                 break;
1082             }
1083             top = PerlIONext(top);
1084             PerlIO_flush(top);
1085         }
1086     }
1087     return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1088 }
1089
1090 #undef PerlIO__close
1091 int
1092 PerlIO__close(PerlIO *f)
1093 {
1094     if (f && *f)
1095         return (*PerlIOBase(f)->tab->Close) (f);
1096     else {
1097         SETERRNO(EBADF, SS$_IVCHAN);
1098         return -1;
1099     }
1100 }
1101
1102 #undef PerlIO_close
1103 int
1104 PerlIO_close(PerlIO *f)
1105 {
1106     dTHX;
1107     int code = -1;
1108     if (f && *f) {
1109         code = (*PerlIOBase(f)->tab->Close) (f);
1110         while (*f) {
1111             PerlIO_pop(aTHX_ f);
1112         }
1113     }
1114     return code;
1115 }
1116
1117 #undef PerlIO_fileno
1118 int
1119 PerlIO_fileno(PerlIO *f)
1120 {
1121     if (f && *f)
1122         return (*PerlIOBase(f)->tab->Fileno) (f);
1123     else {
1124         SETERRNO(EBADF, SS$_IVCHAN);
1125         return -1;
1126     }
1127 }
1128
1129 static const char *
1130 PerlIO_context_layers(pTHX_ const char *mode)
1131 {
1132     const char *type = NULL;
1133     /*
1134      * Need to supply default layer info from open.pm
1135      */
1136     if (PL_curcop) {
1137         SV *layers = PL_curcop->cop_io;
1138         if (layers) {
1139             STRLEN len;
1140             type = SvPV(layers, len);
1141             if (type && mode[0] != 'r') {
1142                 /*
1143                  * Skip to write part
1144                  */
1145                 const char *s = strchr(type, 0);
1146                 if (s && (s - type) < len) {
1147                     type = s + 1;
1148                 }
1149             }
1150         }
1151     }
1152     return type;
1153 }
1154
1155 static PerlIO_funcs *
1156 PerlIO_layer_from_ref(pTHX_ SV *sv)
1157 {
1158     /*
1159      * For any scalar type load the handler which is bundled with perl
1160      */
1161     if (SvTYPE(sv) < SVt_PVAV)
1162         return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1163
1164     /*
1165      * For other types allow if layer is known but don't try and load it
1166      */
1167     switch (SvTYPE(sv)) {
1168     case SVt_PVAV:
1169         return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1170     case SVt_PVHV:
1171         return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1172     case SVt_PVCV:
1173         return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1174     case SVt_PVGV:
1175         return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1176     }
1177     return NULL;
1178 }
1179
1180 PerlIO_list_t *
1181 PerlIO_resolve_layers(pTHX_ const char *layers,
1182                       const char *mode, int narg, SV **args)
1183 {
1184     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1185     int incdef = 1;
1186     if (!PL_perlio)
1187         PerlIO_stdstreams(aTHX);
1188     if (narg) {
1189         SV *arg = *args;
1190         /*
1191          * If it is a reference but not an object see if we have a handler
1192          * for it
1193          */
1194         if (SvROK(arg) && !sv_isobject(arg)) {
1195             PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1196             if (handler) {
1197                 def = PerlIO_list_alloc(aTHX);
1198                 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1199                 incdef = 0;
1200             }
1201             /*
1202              * Don't fail if handler cannot be found :Via(...) etc. may do
1203              * something sensible else we will just stringfy and open
1204              * resulting string.
1205              */
1206         }
1207     }
1208     if (!layers)
1209         layers = PerlIO_context_layers(aTHX_ mode);
1210     if (layers && *layers) {
1211         PerlIO_list_t *av;
1212         if (incdef) {
1213             IV i = def->cur;
1214             av = PerlIO_list_alloc(aTHX);
1215             for (i = 0; i < def->cur; i++) {
1216                 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1217                                  def->array[i].arg);
1218             }
1219         }
1220         else {
1221             av = def;
1222         }
1223         PerlIO_parse_layers(aTHX_ av, layers);
1224         return av;
1225     }
1226     else {
1227         if (incdef)
1228             def->refcnt++;
1229         return def;
1230     }
1231 }
1232
1233 PerlIO *
1234 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1235              int imode, int perm, PerlIO *f, int narg, SV **args)
1236 {
1237     if (!f && narg == 1 && *args == &PL_sv_undef) {
1238         if ((f = PerlIO_tmpfile())) {
1239             if (!layers)
1240                 layers = PerlIO_context_layers(aTHX_ mode);
1241             if (layers && *layers)
1242                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1243         }
1244     }
1245     else {
1246         PerlIO_list_t *layera = NULL;
1247         IV n;
1248         PerlIO_funcs *tab = NULL;
1249         if (f && *f) {
1250             /*
1251              * This is "reopen" - it is not tested as perl does not use it
1252              * yet
1253              */
1254             PerlIOl *l = *f;
1255             layera = PerlIO_list_alloc(aTHX);
1256             while (l) {
1257                 SV *arg =
1258                     (l->tab->Getarg) ? (*l->tab->
1259                                         Getarg) (&l) : &PL_sv_undef;
1260                 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1261                 l = *PerlIONext(&l);
1262             }
1263         }
1264         else {
1265             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1266         }
1267         /*
1268          * Start at "top" of layer stack
1269          */
1270         n = layera->cur - 1;
1271         while (n >= 0) {
1272             PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1273             if (t && t->Open) {
1274                 tab = t;
1275                 break;
1276             }
1277             n--;
1278         }
1279         if (tab) {
1280             /*
1281              * Found that layer 'n' can do opens - call it
1282              */
1283             PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1284                          tab->name, layers, mode, fd, imode, perm, f, narg,
1285                          args);
1286             f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1287                               f, narg, args);
1288             if (f) {
1289                 if (n + 1 < layera->cur) {
1290                     /*
1291                      * More layers above the one that we used to open -
1292                      * apply them now
1293                      */
1294                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1)
1295                         != 0) {
1296                         f = NULL;
1297                     }
1298                 }
1299             }
1300         }
1301         PerlIO_list_free(aTHX_ layera);
1302     }
1303     return f;
1304 }
1305
1306
1307 #undef PerlIO_fdopen
1308 PerlIO *
1309 PerlIO_fdopen(int fd, const char *mode)
1310 {
1311     dTHX;
1312     return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
1313 }
1314
1315 #undef PerlIO_open
1316 PerlIO *
1317 PerlIO_open(const char *path, const char *mode)
1318 {
1319     dTHX;
1320     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
1321     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
1322 }
1323
1324 #undef PerlIO_reopen
1325 PerlIO *
1326 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1327 {
1328     dTHX;
1329     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
1330     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
1331 }
1332
1333 #undef PerlIO_read
1334 SSize_t
1335 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1336 {
1337     if (f && *f)
1338         return (*PerlIOBase(f)->tab->Read) (f, vbuf, count);
1339     else {
1340         SETERRNO(EBADF, SS$_IVCHAN);
1341         return -1;
1342     }
1343 }
1344
1345 #undef PerlIO_unread
1346 SSize_t
1347 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1348 {
1349     if (f && *f)
1350         return (*PerlIOBase(f)->tab->Unread) (f, vbuf, count);
1351     else {
1352         SETERRNO(EBADF, SS$_IVCHAN);
1353         return -1;
1354     }
1355 }
1356
1357 #undef PerlIO_write
1358 SSize_t
1359 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1360 {
1361     if (f && *f)
1362         return (*PerlIOBase(f)->tab->Write) (f, vbuf, count);
1363     else {
1364         SETERRNO(EBADF, SS$_IVCHAN);
1365         return -1;
1366     }
1367 }
1368
1369 #undef PerlIO_seek
1370 int
1371 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1372 {
1373     if (f && *f)
1374         return (*PerlIOBase(f)->tab->Seek) (f, offset, whence);
1375     else {
1376         SETERRNO(EBADF, SS$_IVCHAN);
1377         return -1;
1378     }
1379 }
1380
1381 #undef PerlIO_tell
1382 Off_t
1383 PerlIO_tell(PerlIO *f)
1384 {
1385     if (f && *f)
1386         return (*PerlIOBase(f)->tab->Tell) (f);
1387     else {
1388         SETERRNO(EBADF, SS$_IVCHAN);
1389         return -1;
1390     }
1391 }
1392
1393 #undef PerlIO_flush
1394 int
1395 PerlIO_flush(PerlIO *f)
1396 {
1397     if (f) {
1398         if (*f) {
1399             PerlIO_funcs *tab = PerlIOBase(f)->tab;
1400             if (tab && tab->Flush) {
1401                 return (*tab->Flush) (f);
1402             }
1403             else {
1404                 PerlIO_debug("Cannot flush f=%p :%s\n", f, tab->name);
1405                 SETERRNO(EBADF, SS$_IVCHAN);
1406                 return -1;
1407             }
1408         }
1409         else {
1410             PerlIO_debug("Cannot flush f=%p\n", f);
1411             SETERRNO(EBADF, SS$_IVCHAN);
1412             return -1;
1413         }
1414     }
1415     else {
1416         /*
1417          * Is it good API design to do flush-all on NULL, a potentially
1418          * errorneous input? Maybe some magical value (PerlIO*
1419          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1420          * things on fflush(NULL), but should we be bound by their design
1421          * decisions? --jhi
1422          */
1423         dTHX;
1424         PerlIO **table = &PL_perlio;
1425         int code = 0;
1426         while ((f = *table)) {
1427             int i;
1428             table = (PerlIO **) (f++);
1429             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1430                 if (*f && PerlIO_flush(f) != 0)
1431                     code = -1;
1432                 f++;
1433             }
1434         }
1435         return code;
1436     }
1437 }
1438
1439 void
1440 PerlIOBase_flush_linebuf()
1441 {
1442     dTHX;
1443     PerlIO **table = &PL_perlio;
1444     PerlIO *f;
1445     while ((f = *table)) {
1446         int i;
1447         table = (PerlIO **) (f++);
1448         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1449             if (*f
1450                 && (PerlIOBase(f)->
1451                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1452                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1453                 PerlIO_flush(f);
1454             f++;
1455         }
1456     }
1457 }
1458
1459 #undef PerlIO_fill
1460 int
1461 PerlIO_fill(PerlIO *f)
1462 {
1463     if (f && *f)
1464         return (*PerlIOBase(f)->tab->Fill) (f);
1465     else {
1466         SETERRNO(EBADF, SS$_IVCHAN);
1467         return -1;
1468     }
1469 }
1470
1471 #undef PerlIO_isutf8
1472 int
1473 PerlIO_isutf8(PerlIO *f)
1474 {
1475     if (f && *f)
1476         return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1477     else {
1478         SETERRNO(EBADF, SS$_IVCHAN);
1479         return -1;
1480     }
1481 }
1482
1483 #undef PerlIO_eof
1484 int
1485 PerlIO_eof(PerlIO *f)
1486 {
1487     if (f && *f)
1488         return (*PerlIOBase(f)->tab->Eof) (f);
1489     else {
1490         SETERRNO(EBADF, SS$_IVCHAN);
1491         return -1;
1492     }
1493 }
1494
1495 #undef PerlIO_error
1496 int
1497 PerlIO_error(PerlIO *f)
1498 {
1499     if (f && *f)
1500         return (*PerlIOBase(f)->tab->Error) (f);
1501     else {
1502         SETERRNO(EBADF, SS$_IVCHAN);
1503         return -1;
1504     }
1505 }
1506
1507 #undef PerlIO_clearerr
1508 void
1509 PerlIO_clearerr(PerlIO *f)
1510 {
1511     if (f && *f)
1512         (*PerlIOBase(f)->tab->Clearerr) (f);
1513     else
1514         SETERRNO(EBADF, SS$_IVCHAN);
1515 }
1516
1517 #undef PerlIO_setlinebuf
1518 void
1519 PerlIO_setlinebuf(PerlIO *f)
1520 {
1521     if (f && *f)
1522         (*PerlIOBase(f)->tab->Setlinebuf) (f);
1523     else
1524         SETERRNO(EBADF, SS$_IVCHAN);
1525 }
1526
1527 #undef PerlIO_has_base
1528 int
1529 PerlIO_has_base(PerlIO *f)
1530 {
1531     if (f && *f) {
1532         return (PerlIOBase(f)->tab->Get_base != NULL);
1533     }
1534     return 0;
1535 }
1536
1537 #undef PerlIO_fast_gets
1538 int
1539 PerlIO_fast_gets(PerlIO *f)
1540 {
1541     if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1542         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1543         return (tab->Set_ptrcnt != NULL);
1544     }
1545     return 0;
1546 }
1547
1548 #undef PerlIO_has_cntptr
1549 int
1550 PerlIO_has_cntptr(PerlIO *f)
1551 {
1552     if (f && *f) {
1553         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1554         return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1555     }
1556     return 0;
1557 }
1558
1559 #undef PerlIO_canset_cnt
1560 int
1561 PerlIO_canset_cnt(PerlIO *f)
1562 {
1563     if (f && *f) {
1564         PerlIOl *l = PerlIOBase(f);
1565         return (l->tab->Set_ptrcnt != NULL);
1566     }
1567     return 0;
1568 }
1569
1570 #undef PerlIO_get_base
1571 STDCHAR *
1572 PerlIO_get_base(PerlIO *f)
1573 {
1574     if (f && *f)
1575         return (*PerlIOBase(f)->tab->Get_base) (f);
1576     return NULL;
1577 }
1578
1579 #undef PerlIO_get_bufsiz
1580 int
1581 PerlIO_get_bufsiz(PerlIO *f)
1582 {
1583     if (f && *f)
1584         return (*PerlIOBase(f)->tab->Get_bufsiz) (f);
1585     return 0;
1586 }
1587
1588 #undef PerlIO_get_ptr
1589 STDCHAR *
1590 PerlIO_get_ptr(PerlIO *f)
1591 {
1592     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1593     if (tab->Get_ptr == NULL)
1594         return NULL;
1595     return (*tab->Get_ptr) (f);
1596 }
1597
1598 #undef PerlIO_get_cnt
1599 int
1600 PerlIO_get_cnt(PerlIO *f)
1601 {
1602     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1603     if (tab->Get_cnt == NULL)
1604         return 0;
1605     return (*tab->Get_cnt) (f);
1606 }
1607
1608 #undef PerlIO_set_cnt
1609 void
1610 PerlIO_set_cnt(PerlIO *f, int cnt)
1611 {
1612     (*PerlIOBase(f)->tab->Set_ptrcnt) (f, NULL, cnt);
1613 }
1614
1615 #undef PerlIO_set_ptrcnt
1616 void
1617 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR * ptr, int cnt)
1618 {
1619     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1620     if (tab->Set_ptrcnt == NULL) {
1621         dTHX;
1622         Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1623     }
1624     (*PerlIOBase(f)->tab->Set_ptrcnt) (f, ptr, cnt);
1625 }
1626
1627 /*--------------------------------------------------------------------------------------*/
1628 /*
1629  * utf8 and raw dummy layers
1630  */
1631
1632 IV
1633 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1634 {
1635     if (PerlIONext(f)) {
1636         dTHX;
1637         PerlIO_funcs *tab = PerlIOBase(f)->tab;
1638         PerlIO_pop(aTHX_ f);
1639         if (tab->kind & PERLIO_K_UTF8)
1640             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1641         else
1642             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1643         return 0;
1644     }
1645     return -1;
1646 }
1647
1648 PerlIO_funcs PerlIO_utf8 = {
1649     "utf8",
1650     sizeof(PerlIOl),
1651     PERLIO_K_DUMMY | PERLIO_F_UTF8,
1652     PerlIOUtf8_pushed,
1653     NULL,
1654     NULL,
1655     NULL,
1656     NULL,
1657     NULL,
1658     NULL,
1659     NULL,
1660     NULL,
1661     NULL,
1662     NULL,
1663     NULL,                       /* flush */
1664     NULL,                       /* fill */
1665     NULL,
1666     NULL,
1667     NULL,
1668     NULL,
1669     NULL,                       /* get_base */
1670     NULL,                       /* get_bufsiz */
1671     NULL,                       /* get_ptr */
1672     NULL,                       /* get_cnt */
1673     NULL,                       /* set_ptrcnt */
1674 };
1675
1676 PerlIO_funcs PerlIO_byte = {
1677     "bytes",
1678     sizeof(PerlIOl),
1679     PERLIO_K_DUMMY,
1680     PerlIOUtf8_pushed,
1681     NULL,
1682     NULL,
1683     NULL,
1684     NULL,
1685     NULL,
1686     NULL,
1687     NULL,
1688     NULL,
1689     NULL,
1690     NULL,
1691     NULL,                       /* flush */
1692     NULL,                       /* fill */
1693     NULL,
1694     NULL,
1695     NULL,
1696     NULL,
1697     NULL,                       /* get_base */
1698     NULL,                       /* get_bufsiz */
1699     NULL,                       /* get_ptr */
1700     NULL,                       /* get_cnt */
1701     NULL,                       /* set_ptrcnt */
1702 };
1703
1704 PerlIO *
1705 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1706                IV n, const char *mode, int fd, int imode, int perm,
1707                PerlIO *old, int narg, SV **args)
1708 {
1709     PerlIO_funcs *tab = PerlIO_default_btm();
1710     return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1711                          old, narg, args);
1712 }
1713
1714 PerlIO_funcs PerlIO_raw = {
1715     "raw",
1716     sizeof(PerlIOl),
1717     PERLIO_K_DUMMY,
1718     PerlIORaw_pushed,
1719     PerlIOBase_popped,
1720     PerlIORaw_open,
1721     NULL,
1722     NULL,
1723     NULL,
1724     NULL,
1725     NULL,
1726     NULL,
1727     NULL,
1728     NULL,
1729     NULL,                       /* flush */
1730     NULL,                       /* fill */
1731     NULL,
1732     NULL,
1733     NULL,
1734     NULL,
1735     NULL,                       /* get_base */
1736     NULL,                       /* get_bufsiz */
1737     NULL,                       /* get_ptr */
1738     NULL,                       /* get_cnt */
1739     NULL,                       /* set_ptrcnt */
1740 };
1741 /*--------------------------------------------------------------------------------------*/
1742 /*--------------------------------------------------------------------------------------*/
1743 /*
1744  * "Methods" of the "base class"
1745  */
1746
1747 IV
1748 PerlIOBase_fileno(PerlIO *f)
1749 {
1750     return PerlIO_fileno(PerlIONext(f));
1751 }
1752
1753 char *
1754 PerlIO_modestr(PerlIO *f, char *buf)
1755 {
1756     char *s = buf;
1757     IV flags = PerlIOBase(f)->flags;
1758     if (flags & PERLIO_F_APPEND) {
1759         *s++ = 'a';
1760         if (flags & PERLIO_F_CANREAD) {
1761             *s++ = '+';
1762         }
1763     }
1764     else if (flags & PERLIO_F_CANREAD) {
1765         *s++ = 'r';
1766         if (flags & PERLIO_F_CANWRITE)
1767             *s++ = '+';
1768     }
1769     else if (flags & PERLIO_F_CANWRITE) {
1770         *s++ = 'w';
1771         if (flags & PERLIO_F_CANREAD) {
1772             *s++ = '+';
1773         }
1774     }
1775 #if O_TEXT != O_BINARY
1776     if (!(flags & PERLIO_F_CRLF))
1777         *s++ = 'b';
1778 #endif
1779     *s = '\0';
1780     return buf;
1781 }
1782
1783 IV
1784 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1785 {
1786     PerlIOl *l = PerlIOBase(f);
1787 #if 0
1788     const char *omode = mode;
1789     char temp[8];
1790 #endif
1791     PerlIO_funcs *tab = PerlIOBase(f)->tab;
1792     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1793                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1794     if (tab->Set_ptrcnt != NULL)
1795         l->flags |= PERLIO_F_FASTGETS;
1796     if (mode) {
1797         if (*mode == '#' || *mode == 'I')
1798             mode++;
1799         switch (*mode++) {
1800         case 'r':
1801             l->flags |= PERLIO_F_CANREAD;
1802             break;
1803         case 'a':
1804             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1805             break;
1806         case 'w':
1807             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1808             break;
1809         default:
1810             SETERRNO(EINVAL, LIB$_INVARG);
1811             return -1;
1812         }
1813         while (*mode) {
1814             switch (*mode++) {
1815             case '+':
1816                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1817                 break;
1818             case 'b':
1819                 l->flags &= ~PERLIO_F_CRLF;
1820                 break;
1821             case 't':
1822                 l->flags |= PERLIO_F_CRLF;
1823                 break;
1824             default:
1825                 SETERRNO(EINVAL, LIB$_INVARG);
1826                 return -1;
1827             }
1828         }
1829     }
1830     else {
1831         if (l->next) {
1832             l->flags |= l->next->flags &
1833                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1834                  PERLIO_F_APPEND);
1835         }
1836     }
1837 #if 0
1838     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1839                  f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1840                  l->flags, PerlIO_modestr(f, temp));
1841 #endif
1842     return 0;
1843 }
1844
1845 IV
1846 PerlIOBase_popped(PerlIO *f)
1847 {
1848     return 0;
1849 }
1850
1851 SSize_t
1852 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1853 {
1854     dTHX;
1855     /*
1856      * Save the position as current head considers it
1857      */
1858     Off_t old = PerlIO_tell(f);
1859     SSize_t done;
1860     PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1861     PerlIOSelf(f, PerlIOBuf)->posn = old;
1862     done = PerlIOBuf_unread(f, vbuf, count);
1863     return done;
1864 }
1865
1866 SSize_t
1867 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1868 {
1869     STDCHAR *buf = (STDCHAR *) vbuf;
1870     if (f) {
1871         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1872             return 0;
1873         while (count > 0) {
1874             SSize_t avail = PerlIO_get_cnt(f);
1875             SSize_t take = 0;
1876             if (avail > 0)
1877                 take = (count < avail) ? count : avail;
1878             if (take > 0) {
1879                 STDCHAR *ptr = PerlIO_get_ptr(f);
1880                 Copy(ptr, buf, take, STDCHAR);
1881                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1882                 count -= take;
1883                 buf += take;
1884             }
1885             if (count > 0 && avail <= 0) {
1886                 if (PerlIO_fill(f) != 0)
1887                     break;
1888             }
1889         }
1890         return (buf - (STDCHAR *) vbuf);
1891     }
1892     return 0;
1893 }
1894
1895 IV
1896 PerlIOBase_noop_ok(PerlIO *f)
1897 {
1898     return 0;
1899 }
1900
1901 IV
1902 PerlIOBase_noop_fail(PerlIO *f)
1903 {
1904     return -1;
1905 }
1906
1907 IV
1908 PerlIOBase_close(PerlIO *f)
1909 {
1910     IV code = 0;
1911     PerlIO *n = PerlIONext(f);
1912     if (PerlIO_flush(f) != 0)
1913         code = -1;
1914     if (n && *n && (*PerlIOBase(n)->tab->Close) (n) != 0)
1915         code = -1;
1916     PerlIOBase(f)->flags &=
1917         ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1918     return code;
1919 }
1920
1921 IV
1922 PerlIOBase_eof(PerlIO *f)
1923 {
1924     if (f && *f) {
1925         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1926     }
1927     return 1;
1928 }
1929
1930 IV
1931 PerlIOBase_error(PerlIO *f)
1932 {
1933     if (f && *f) {
1934         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1935     }
1936     return 1;
1937 }
1938
1939 void
1940 PerlIOBase_clearerr(PerlIO *f)
1941 {
1942     if (f && *f) {
1943         PerlIO *n = PerlIONext(f);
1944         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
1945         if (n)
1946             PerlIO_clearerr(n);
1947     }
1948 }
1949
1950 void
1951 PerlIOBase_setlinebuf(PerlIO *f)
1952 {
1953     if (f) {
1954         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1955     }
1956 }
1957
1958 SV *
1959 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
1960 {
1961     if (!arg)
1962         return Nullsv;
1963 #ifdef sv_dup
1964     if (param) {
1965         return sv_dup(arg, param);
1966     }
1967     else {
1968         return newSVsv(arg);
1969     }
1970 #else
1971     return newSVsv(arg);
1972 #endif
1973 }
1974
1975 PerlIO *
1976 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
1977 {
1978     PerlIO *nexto = PerlIONext(o);
1979     if (*nexto) {
1980         PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
1981         f = (*tab->Dup)(aTHX_ f, nexto, param);
1982     }
1983     if (f) {
1984         PerlIO_funcs *self = PerlIOBase(o)->tab;
1985         SV *arg = Nullsv;
1986         char buf[8];
1987         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
1988         if (self->Getarg) {
1989             arg = (*self->Getarg)(o);
1990             if (arg) {
1991                 arg = PerlIO_sv_dup(aTHX_ arg, param);
1992             }
1993         }
1994         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
1995         if (!f && 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)
2208 {
2209     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2210     int fd = os->fd;
2211     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2212         f = PerlIOBase_dup(aTHX_ f, o, param);
2213         if (f) {
2214             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2215             PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2216             s->fd = fd;
2217             PerlIOUnix_refcnt_inc(fd);
2218             return f;
2219         }
2220     }
2221     return NULL;
2222 }
2223
2224
2225 SSize_t
2226 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2227 {
2228     dTHX;
2229     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2230     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2231         return 0;
2232     while (1) {
2233         SSize_t len = PerlLIO_read(fd, vbuf, count);
2234         if (len >= 0 || errno != EINTR) {
2235             if (len < 0)
2236                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2237             else if (len == 0 && count != 0)
2238                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2239             return len;
2240         }
2241         PERL_ASYNC_CHECK();
2242     }
2243 }
2244
2245 SSize_t
2246 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2247 {
2248     dTHX;
2249     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2250     while (1) {
2251         SSize_t len = PerlLIO_write(fd, vbuf, count);
2252         if (len >= 0 || errno != EINTR) {
2253             if (len < 0)
2254                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2255             return len;
2256         }
2257         PERL_ASYNC_CHECK();
2258     }
2259 }
2260
2261 IV
2262 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2263 {
2264     dSYS;
2265     Off_t new =
2266         PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2267     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2268     return (new == (Off_t) - 1) ? -1 : 0;
2269 }
2270
2271 Off_t
2272 PerlIOUnix_tell(PerlIO *f)
2273 {
2274     dSYS;
2275     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2276 }
2277
2278
2279 IV
2280 PerlIOUnix_close(PerlIO *f)
2281 {
2282     dTHX;
2283     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2284     int code = 0;
2285     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2286         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2287             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2288             return 0;
2289         }
2290     }
2291     else {
2292         SETERRNO(EBADF,SS$_IVCHAN);
2293         return -1;
2294     }
2295     while (PerlLIO_close(fd) != 0) {
2296         if (errno != EINTR) {
2297             code = -1;
2298             break;
2299         }
2300         PERL_ASYNC_CHECK();
2301     }
2302     if (code == 0) {
2303         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2304     }
2305     return code;
2306 }
2307
2308 PerlIO_funcs PerlIO_unix = {
2309     "unix",
2310     sizeof(PerlIOUnix),
2311     PERLIO_K_RAW,
2312     PerlIOUnix_pushed,
2313     PerlIOBase_noop_ok,
2314     PerlIOUnix_open,
2315     NULL,
2316     PerlIOUnix_fileno,
2317     PerlIOUnix_dup,
2318     PerlIOUnix_read,
2319     PerlIOBase_unread,
2320     PerlIOUnix_write,
2321     PerlIOUnix_seek,
2322     PerlIOUnix_tell,
2323     PerlIOUnix_close,
2324     PerlIOBase_noop_ok,         /* flush */
2325     PerlIOBase_noop_fail,       /* fill */
2326     PerlIOBase_eof,
2327     PerlIOBase_error,
2328     PerlIOBase_clearerr,
2329     PerlIOBase_setlinebuf,
2330     NULL,                       /* get_base */
2331     NULL,                       /* get_bufsiz */
2332     NULL,                       /* get_ptr */
2333     NULL,                       /* get_cnt */
2334     NULL,                       /* set_ptrcnt */
2335 };
2336
2337 /*--------------------------------------------------------------------------------------*/
2338 /*
2339  * stdio as a layer
2340  */
2341
2342 typedef struct {
2343     struct _PerlIO base;
2344     FILE *stdio;                /* The stream */
2345 } PerlIOStdio;
2346
2347 IV
2348 PerlIOStdio_fileno(PerlIO *f)
2349 {
2350     dSYS;
2351     return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2352 }
2353
2354 char *
2355 PerlIOStdio_mode(const char *mode, char *tmode)
2356 {
2357     char *ret = tmode;
2358     while (*mode) {
2359         *tmode++ = *mode++;
2360     }
2361     if (O_BINARY != O_TEXT) {
2362         *tmode++ = 'b';
2363     }
2364     *tmode = '\0';
2365     return ret;
2366 }
2367
2368 /*
2369  * This isn't used yet ...
2370  */
2371 IV
2372 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2373 {
2374     if (*PerlIONext(f)) {
2375         dSYS;
2376         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2377         char tmode[8];
2378         FILE *stdio =
2379             PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2380                            PerlIOStdio_mode(mode, tmode));
2381         if (stdio)
2382             s->stdio = stdio;
2383         else
2384             return -1;
2385     }
2386     return PerlIOBase_pushed(f, mode, arg);
2387 }
2388
2389 #undef PerlIO_importFILE
2390 PerlIO *
2391 PerlIO_importFILE(FILE *stdio, int fl)
2392 {
2393     dTHX;
2394     PerlIO *f = NULL;
2395     if (stdio) {
2396         PerlIOStdio *s =
2397             PerlIOSelf(PerlIO_push
2398                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2399                         "r+", Nullsv), PerlIOStdio);
2400         s->stdio = stdio;
2401     }
2402     return f;
2403 }
2404
2405 PerlIO *
2406 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2407                  IV n, const char *mode, int fd, int imode,
2408                  int perm, PerlIO *f, int narg, SV **args)
2409 {
2410     char tmode[8];
2411     if (f) {
2412         char *path = SvPV_nolen(*args);
2413         PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2414         FILE *stdio;
2415         PerlIOUnix_refcnt_dec(fileno(s->stdio));
2416         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2417                             s->stdio);
2418         if (!s->stdio)
2419             return NULL;
2420         s->stdio = stdio;
2421         PerlIOUnix_refcnt_inc(fileno(s->stdio));
2422         return f;
2423     }
2424     else {
2425         if (narg > 0) {
2426             char *path = SvPV_nolen(*args);
2427             if (*mode == '#') {
2428                 mode++;
2429                 fd = PerlLIO_open3(path, imode, perm);
2430             }
2431             else {
2432                 FILE *stdio = PerlSIO_fopen(path, mode);
2433                 if (stdio) {
2434                     PerlIOStdio *s =
2435                         PerlIOSelf(PerlIO_push
2436                                    (aTHX_(f = PerlIO_allocate(aTHX)), self,
2437                                     (mode = PerlIOStdio_mode(mode, tmode)),
2438                                     PerlIOArg),
2439                                    PerlIOStdio);
2440                     s->stdio = stdio;
2441                     PerlIOUnix_refcnt_inc(fileno(s->stdio));
2442                 }
2443                 return f;
2444             }
2445         }
2446         if (fd >= 0) {
2447             FILE *stdio = NULL;
2448             int init = 0;
2449             if (*mode == 'I') {
2450                 init = 1;
2451                 mode++;
2452             }
2453             if (init) {
2454                 switch (fd) {
2455                 case 0:
2456                     stdio = PerlSIO_stdin;
2457                     break;
2458                 case 1:
2459                     stdio = PerlSIO_stdout;
2460                     break;
2461                 case 2:
2462                     stdio = PerlSIO_stderr;
2463                     break;
2464                 }
2465             }
2466             else {
2467                 stdio = PerlSIO_fdopen(fd, mode =
2468                                        PerlIOStdio_mode(mode, tmode));
2469             }
2470             if (stdio) {
2471                 PerlIOStdio *s =
2472                     PerlIOSelf(PerlIO_push
2473                                (aTHX_(f = PerlIO_allocate(aTHX)), self,
2474                                 mode, PerlIOArg), PerlIOStdio);
2475                 s->stdio = stdio;
2476                 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2477                 return f;
2478             }
2479         }
2480     }
2481     return NULL;
2482 }
2483
2484 PerlIO *
2485 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
2486 {
2487     /* This assumes no layers underneath - which is what
2488        happens, but is not how I remember it. NI-S 2001/10/16
2489      */
2490     if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
2491         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2492         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2493         PerlIOUnix_refcnt_inc(fileno(stdio));
2494     }
2495     return f;
2496 }
2497
2498 IV
2499 PerlIOStdio_close(PerlIO *f)
2500 {
2501     dSYS;
2502 #ifdef SOCKS5_VERSION_NAME
2503     int optval;
2504     Sock_size_t optlen = sizeof(int);
2505 #endif
2506     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2507     if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2508         /* Do not close it but do flush any buffers */
2509         PerlIO_flush(f);
2510         return 0;
2511     }
2512     return (
2513 #ifdef SOCKS5_VERSION_NAME
2514                (getsockopt
2515                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2516                  &optlen) <
2517                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2518 #else
2519                PerlSIO_fclose(stdio)
2520 #endif
2521         );
2522
2523 }
2524
2525
2526
2527 SSize_t
2528 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2529 {
2530     dSYS;
2531     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2532     SSize_t got = 0;
2533     if (count == 1) {
2534         STDCHAR *buf = (STDCHAR *) vbuf;
2535         /*
2536          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2537          * stdio does not do that for fread()
2538          */
2539         int ch = PerlSIO_fgetc(s);
2540         if (ch != EOF) {
2541             *buf = ch;
2542             got = 1;
2543         }
2544     }
2545     else
2546         got = PerlSIO_fread(vbuf, 1, count, s);
2547     return got;
2548 }
2549
2550 SSize_t
2551 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2552 {
2553     dSYS;
2554     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2555     STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2556     SSize_t unread = 0;
2557     while (count > 0) {
2558         int ch = *buf-- & 0xff;
2559         if (PerlSIO_ungetc(ch, s) != ch)
2560             break;
2561         unread++;
2562         count--;
2563     }
2564     return unread;
2565 }
2566
2567 SSize_t
2568 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2569 {
2570     dSYS;
2571     return PerlSIO_fwrite(vbuf, 1, count,
2572                           PerlIOSelf(f, PerlIOStdio)->stdio);
2573 }
2574
2575 IV
2576 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2577 {
2578     dSYS;
2579     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2580     return PerlSIO_fseek(stdio, offset, whence);
2581 }
2582
2583 Off_t
2584 PerlIOStdio_tell(PerlIO *f)
2585 {
2586     dSYS;
2587     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2588     return PerlSIO_ftell(stdio);
2589 }
2590
2591 IV
2592 PerlIOStdio_flush(PerlIO *f)
2593 {
2594     dSYS;
2595     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2596     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2597         return PerlSIO_fflush(stdio);
2598     }
2599     else {
2600 #if 0
2601         /*
2602          * FIXME: This discards ungetc() and pre-read stuff which is not
2603          * right if this is just a "sync" from a layer above Suspect right
2604          * design is to do _this_ but not have layer above flush this
2605          * layer read-to-read
2606          */
2607         /*
2608          * Not writeable - sync by attempting a seek
2609          */
2610         int err = errno;
2611         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2612             errno = err;
2613 #endif
2614     }
2615     return 0;
2616 }
2617
2618 IV
2619 PerlIOStdio_fill(PerlIO *f)
2620 {
2621     dSYS;
2622     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2623     int c;
2624     /*
2625      * fflush()ing read-only streams can cause trouble on some stdio-s
2626      */
2627     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2628         if (PerlSIO_fflush(stdio) != 0)
2629             return EOF;
2630     }
2631     c = PerlSIO_fgetc(stdio);
2632     if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2633         return EOF;
2634     return 0;
2635 }
2636
2637 IV
2638 PerlIOStdio_eof(PerlIO *f)
2639 {
2640     dSYS;
2641     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2642 }
2643
2644 IV
2645 PerlIOStdio_error(PerlIO *f)
2646 {
2647     dSYS;
2648     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2649 }
2650
2651 void
2652 PerlIOStdio_clearerr(PerlIO *f)
2653 {
2654     dSYS;
2655     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2656 }
2657
2658 void
2659 PerlIOStdio_setlinebuf(PerlIO *f)
2660 {
2661     dSYS;
2662 #ifdef HAS_SETLINEBUF
2663     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2664 #else
2665     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2666 #endif
2667 }
2668
2669 #ifdef FILE_base
2670 STDCHAR *
2671 PerlIOStdio_get_base(PerlIO *f)
2672 {
2673     dSYS;
2674     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2675     return PerlSIO_get_base(stdio);
2676 }
2677
2678 Size_t
2679 PerlIOStdio_get_bufsiz(PerlIO *f)
2680 {
2681     dSYS;
2682     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2683     return PerlSIO_get_bufsiz(stdio);
2684 }
2685 #endif
2686
2687 #ifdef USE_STDIO_PTR
2688 STDCHAR *
2689 PerlIOStdio_get_ptr(PerlIO *f)
2690 {
2691     dSYS;
2692     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2693     return PerlSIO_get_ptr(stdio);
2694 }
2695
2696 SSize_t
2697 PerlIOStdio_get_cnt(PerlIO *f)
2698 {
2699     dSYS;
2700     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2701     return PerlSIO_get_cnt(stdio);
2702 }
2703
2704 void
2705 PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2706 {
2707     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2708     dSYS;
2709     if (ptr != NULL) {
2710 #ifdef STDIO_PTR_LVALUE
2711         PerlSIO_set_ptr(stdio, ptr);
2712 #ifdef STDIO_PTR_LVAL_SETS_CNT
2713         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2714             dTHX;
2715             assert(PerlSIO_get_cnt(stdio) == (cnt));
2716         }
2717 #endif
2718 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2719         /*
2720          * Setting ptr _does_ change cnt - we are done
2721          */
2722         return;
2723 #endif
2724 #else                           /* STDIO_PTR_LVALUE */
2725         PerlProc_abort();
2726 #endif                          /* STDIO_PTR_LVALUE */
2727     }
2728     /*
2729      * Now (or only) set cnt
2730      */
2731 #ifdef STDIO_CNT_LVALUE
2732     PerlSIO_set_cnt(stdio, cnt);
2733 #else                           /* STDIO_CNT_LVALUE */
2734 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2735     PerlSIO_set_ptr(stdio,
2736                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2737                                               cnt));
2738 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2739     PerlProc_abort();
2740 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2741 #endif                          /* STDIO_CNT_LVALUE */
2742 }
2743
2744 #endif
2745
2746 PerlIO_funcs PerlIO_stdio = {
2747     "stdio",
2748     sizeof(PerlIOStdio),
2749     PERLIO_K_BUFFERED,
2750     PerlIOBase_pushed,
2751     PerlIOBase_noop_ok,
2752     PerlIOStdio_open,
2753     NULL,
2754     PerlIOStdio_fileno,
2755     PerlIOStdio_dup,
2756     PerlIOStdio_read,
2757     PerlIOStdio_unread,
2758     PerlIOStdio_write,
2759     PerlIOStdio_seek,
2760     PerlIOStdio_tell,
2761     PerlIOStdio_close,
2762     PerlIOStdio_flush,
2763     PerlIOStdio_fill,
2764     PerlIOStdio_eof,
2765     PerlIOStdio_error,
2766     PerlIOStdio_clearerr,
2767     PerlIOStdio_setlinebuf,
2768 #ifdef FILE_base
2769     PerlIOStdio_get_base,
2770     PerlIOStdio_get_bufsiz,
2771 #else
2772     NULL,
2773     NULL,
2774 #endif
2775 #ifdef USE_STDIO_PTR
2776     PerlIOStdio_get_ptr,
2777     PerlIOStdio_get_cnt,
2778 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2779     PerlIOStdio_set_ptrcnt
2780 #else                           /* STDIO_PTR_LVALUE */
2781     NULL
2782 #endif                          /* STDIO_PTR_LVALUE */
2783 #else                           /* USE_STDIO_PTR */
2784     NULL,
2785     NULL,
2786     NULL
2787 #endif                          /* USE_STDIO_PTR */
2788 };
2789
2790 #undef PerlIO_exportFILE
2791 FILE *
2792 PerlIO_exportFILE(PerlIO *f, int fl)
2793 {
2794     FILE *stdio;
2795     PerlIO_flush(f);
2796     stdio = fdopen(PerlIO_fileno(f), "r+");
2797     if (stdio) {
2798         dTHX;
2799         PerlIOStdio *s =
2800             PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2801                        PerlIOStdio);
2802         s->stdio = stdio;
2803     }
2804     return stdio;
2805 }
2806
2807 #undef PerlIO_findFILE
2808 FILE *
2809 PerlIO_findFILE(PerlIO *f)
2810 {
2811     PerlIOl *l = *f;
2812     while (l) {
2813         if (l->tab == &PerlIO_stdio) {
2814             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2815             return s->stdio;
2816         }
2817         l = *PerlIONext(&l);
2818     }
2819     return PerlIO_exportFILE(f, 0);
2820 }
2821
2822 #undef PerlIO_releaseFILE
2823 void
2824 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2825 {
2826 }
2827
2828 /*--------------------------------------------------------------------------------------*/
2829 /*
2830  * perlio buffer layer
2831  */
2832
2833 IV
2834 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2835 {
2836     dSYS;
2837     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2838     int fd = PerlIO_fileno(f);
2839     Off_t posn;
2840     if (fd >= 0 && PerlLIO_isatty(fd)) {
2841         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2842     }
2843     posn = PerlIO_tell(PerlIONext(f));
2844     if (posn != (Off_t) - 1) {
2845         b->posn = posn;
2846     }
2847     return PerlIOBase_pushed(f, mode, arg);
2848 }
2849
2850 PerlIO *
2851 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2852                IV n, const char *mode, int fd, int imode, int perm,
2853                PerlIO *f, int narg, SV **args)
2854 {
2855     if (f) {
2856         PerlIO *next = PerlIONext(f);
2857         PerlIO_funcs *tab =
2858             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2859         next =
2860             (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2861                           next, narg, args);
2862         if (!next
2863             || (*PerlIOBase(f)->tab->Pushed) (f, mode, PerlIOArg) != 0) {
2864             return NULL;
2865         }
2866     }
2867     else {
2868         PerlIO_funcs *tab =
2869             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2870         int init = 0;
2871         if (*mode == 'I') {
2872             init = 1;
2873             /*
2874              * mode++;
2875              */
2876         }
2877         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2878                           NULL, narg, args);
2879         if (f) {
2880             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
2881                 /*
2882                  * if push fails during open, open fails. close will pop us.
2883                  */
2884                 PerlIO_close (f);
2885                 return NULL;
2886             } else {
2887                 fd = PerlIO_fileno(f);
2888 #if (O_BINARY != O_TEXT) && !defined(__BEOS__)
2889                 /*
2890                  * do something about failing setmode()? --jhi
2891                  */
2892                 PerlLIO_setmode(fd, O_BINARY);
2893 #endif
2894                 if (init && fd == 2) {
2895                     /*
2896                      * Initial stderr is unbuffered
2897                      */
2898                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2899                 }
2900             }
2901         }
2902     }
2903     return f;
2904 }
2905
2906 /*
2907  * This "flush" is akin to sfio's sync in that it handles files in either
2908  * read or write state
2909  */
2910 IV
2911 PerlIOBuf_flush(PerlIO *f)
2912 {
2913     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2914     int code = 0;
2915     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2916         /*
2917          * write() the buffer
2918          */
2919         STDCHAR *buf = b->buf;
2920         STDCHAR *p = buf;
2921         PerlIO *n = PerlIONext(f);
2922         while (p < b->ptr) {
2923             SSize_t count = PerlIO_write(n, p, b->ptr - p);
2924             if (count > 0) {
2925                 p += count;
2926             }
2927             else if (count < 0 || PerlIO_error(n)) {
2928                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2929                 code = -1;
2930                 break;
2931             }
2932         }
2933         b->posn += (p - buf);
2934     }
2935     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2936         STDCHAR *buf = PerlIO_get_base(f);
2937         /*
2938          * Note position change
2939          */
2940         b->posn += (b->ptr - buf);
2941         if (b->ptr < b->end) {
2942             /*
2943              * We did not consume all of it
2944              */
2945             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
2946                 b->posn = PerlIO_tell(PerlIONext(f));
2947             }
2948         }
2949     }
2950     b->ptr = b->end = b->buf;
2951     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2952     /*
2953      * FIXME: Is this right for read case ?
2954      */
2955     if (PerlIO_flush(PerlIONext(f)) != 0)
2956         code = -1;
2957     return code;
2958 }
2959
2960 IV
2961 PerlIOBuf_fill(PerlIO *f)
2962 {
2963     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2964     PerlIO *n = PerlIONext(f);
2965     SSize_t avail;
2966     /*
2967      * FIXME: doing the down-stream flush is a bad idea if it causes
2968      * pre-read data in stdio buffer to be discarded but this is too
2969      * simplistic - as it skips _our_ hosekeeping and breaks tell tests.
2970      * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
2971      */
2972     if (PerlIO_flush(f) != 0)
2973         return -1;
2974     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2975         PerlIOBase_flush_linebuf();
2976
2977     if (!b->buf)
2978         PerlIO_get_base(f);     /* allocate via vtable */
2979
2980     b->ptr = b->end = b->buf;
2981     if (PerlIO_fast_gets(n)) {
2982         /*
2983          * Layer below is also buffered We do _NOT_ want to call its
2984          * ->Read() because that will loop till it gets what we asked for
2985          * which may hang on a pipe etc. Instead take anything it has to
2986          * hand, or ask it to fill _once_.
2987          */
2988         avail = PerlIO_get_cnt(n);
2989         if (avail <= 0) {
2990             avail = PerlIO_fill(n);
2991             if (avail == 0)
2992                 avail = PerlIO_get_cnt(n);
2993             else {
2994                 if (!PerlIO_error(n) && PerlIO_eof(n))
2995                     avail = 0;
2996             }
2997         }
2998         if (avail > 0) {
2999             STDCHAR *ptr = PerlIO_get_ptr(n);
3000             SSize_t cnt = avail;
3001             if (avail > b->bufsiz)
3002                 avail = b->bufsiz;
3003             Copy(ptr, b->buf, avail, STDCHAR);
3004             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3005         }
3006     }
3007     else {
3008         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3009     }
3010     if (avail <= 0) {
3011         if (avail == 0)
3012             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3013         else
3014             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3015         return -1;
3016     }
3017     b->end = b->buf + avail;
3018     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3019     return 0;
3020 }
3021
3022 SSize_t
3023 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
3024 {
3025     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3026     if (f) {
3027         if (!b->ptr)
3028             PerlIO_get_base(f);
3029         return PerlIOBase_read(f, vbuf, count);
3030     }
3031     return 0;
3032 }
3033
3034 SSize_t
3035 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
3036 {
3037     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3038     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3039     SSize_t unread = 0;
3040     SSize_t avail;
3041     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3042         PerlIO_flush(f);
3043     if (!b->buf)
3044         PerlIO_get_base(f);
3045     if (b->buf) {
3046         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3047             /*
3048              * Buffer is already a read buffer, we can overwrite any chars
3049              * which have been read back to buffer start
3050              */
3051             avail = (b->ptr - b->buf);
3052         }
3053         else {
3054             /*
3055              * Buffer is idle, set it up so whole buffer is available for
3056              * unread
3057              */
3058             avail = b->bufsiz;
3059             b->end = b->buf + avail;
3060             b->ptr = b->end;
3061             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3062             /*
3063              * Buffer extends _back_ from where we are now
3064              */
3065             b->posn -= b->bufsiz;
3066         }
3067         if (avail > (SSize_t) count) {
3068             /*
3069              * If we have space for more than count, just move count
3070              */
3071             avail = count;
3072         }
3073         if (avail > 0) {
3074             b->ptr -= avail;
3075             buf -= avail;
3076             /*
3077              * In simple stdio-like ungetc() case chars will be already
3078              * there
3079              */
3080             if (buf != b->ptr) {
3081                 Copy(buf, b->ptr, avail, STDCHAR);
3082             }
3083             count -= avail;
3084             unread += avail;
3085             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3086         }
3087     }
3088     return unread;
3089 }
3090
3091 SSize_t
3092 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
3093 {
3094     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3095     const STDCHAR *buf = (const STDCHAR *) vbuf;
3096     Size_t written = 0;
3097     if (!b->buf)
3098         PerlIO_get_base(f);
3099     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3100         return 0;
3101     while (count > 0) {
3102         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3103         if ((SSize_t) count < avail)
3104             avail = count;
3105         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3106         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3107             while (avail > 0) {
3108                 int ch = *buf++;
3109                 *(b->ptr)++ = ch;
3110                 count--;
3111                 avail--;
3112                 written++;
3113                 if (ch == '\n') {
3114                     PerlIO_flush(f);
3115                     break;
3116                 }
3117             }
3118         }
3119         else {
3120             if (avail) {
3121                 Copy(buf, b->ptr, avail, STDCHAR);
3122                 count -= avail;
3123                 buf += avail;
3124                 written += avail;
3125                 b->ptr += avail;
3126             }
3127         }
3128         if (b->ptr >= (b->buf + b->bufsiz))
3129             PerlIO_flush(f);
3130     }
3131     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3132         PerlIO_flush(f);
3133     return written;
3134 }
3135
3136 IV
3137 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
3138 {
3139     IV code;
3140     if ((code = PerlIO_flush(f)) == 0) {
3141         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3142         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3143         code = PerlIO_seek(PerlIONext(f), offset, whence);
3144         if (code == 0) {
3145             b->posn = PerlIO_tell(PerlIONext(f));
3146         }
3147     }
3148     return code;
3149 }
3150
3151 Off_t
3152 PerlIOBuf_tell(PerlIO *f)
3153 {
3154     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3155     /*
3156      * b->posn is file position where b->buf was read, or will be written
3157      */
3158     Off_t posn = b->posn;
3159     if (b->buf) {
3160         /*
3161          * If buffer is valid adjust position by amount in buffer
3162          */
3163         posn += (b->ptr - b->buf);
3164     }
3165     return posn;
3166 }
3167
3168 IV
3169 PerlIOBuf_close(PerlIO *f)
3170 {
3171     IV code = PerlIOBase_close(f);
3172     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3173     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3174         Safefree(b->buf);
3175     }
3176     b->buf = NULL;
3177     b->ptr = b->end = b->buf;
3178     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3179     return code;
3180 }
3181
3182 STDCHAR *
3183 PerlIOBuf_get_ptr(PerlIO *f)
3184 {
3185     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3186     if (!b->buf)
3187         PerlIO_get_base(f);
3188     return b->ptr;
3189 }
3190
3191 SSize_t
3192 PerlIOBuf_get_cnt(PerlIO *f)
3193 {
3194     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3195     if (!b->buf)
3196         PerlIO_get_base(f);
3197     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3198         return (b->end - b->ptr);
3199     return 0;
3200 }
3201
3202 STDCHAR *
3203 PerlIOBuf_get_base(PerlIO *f)
3204 {
3205     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3206     if (!b->buf) {
3207         if (!b->bufsiz)
3208             b->bufsiz = 4096;
3209         b->buf =
3210         Newz('B',b->buf,b->bufsiz, STDCHAR);
3211         if (!b->buf) {
3212             b->buf = (STDCHAR *) & b->oneword;
3213             b->bufsiz = sizeof(b->oneword);
3214         }
3215         b->ptr = b->buf;
3216         b->end = b->ptr;
3217     }
3218     return b->buf;
3219 }
3220
3221 Size_t
3222 PerlIOBuf_bufsiz(PerlIO *f)
3223 {
3224     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3225     if (!b->buf)
3226         PerlIO_get_base(f);
3227     return (b->end - b->buf);
3228 }
3229
3230 void
3231 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3232 {
3233     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3234     if (!b->buf)
3235         PerlIO_get_base(f);
3236     b->ptr = ptr;
3237     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3238         dTHX;
3239         assert(PerlIO_get_cnt(f) == cnt);
3240         assert(b->ptr >= b->buf);
3241     }
3242     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3243 }
3244
3245 PerlIO *
3246 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
3247 {
3248  return PerlIOBase_dup(aTHX_ f, o, param);
3249 }
3250
3251
3252
3253 PerlIO_funcs PerlIO_perlio = {
3254     "perlio",
3255     sizeof(PerlIOBuf),
3256     PERLIO_K_BUFFERED,
3257     PerlIOBuf_pushed,
3258     PerlIOBase_noop_ok,
3259     PerlIOBuf_open,
3260     NULL,
3261     PerlIOBase_fileno,
3262     PerlIOBuf_dup,
3263     PerlIOBuf_read,
3264     PerlIOBuf_unread,
3265     PerlIOBuf_write,
3266     PerlIOBuf_seek,
3267     PerlIOBuf_tell,
3268     PerlIOBuf_close,
3269     PerlIOBuf_flush,
3270     PerlIOBuf_fill,
3271     PerlIOBase_eof,
3272     PerlIOBase_error,
3273     PerlIOBase_clearerr,
3274     PerlIOBase_setlinebuf,
3275     PerlIOBuf_get_base,
3276     PerlIOBuf_bufsiz,
3277     PerlIOBuf_get_ptr,
3278     PerlIOBuf_get_cnt,
3279     PerlIOBuf_set_ptrcnt,
3280 };
3281
3282 /*--------------------------------------------------------------------------------------*/
3283 /*
3284  * Temp layer to hold unread chars when cannot do it any other way
3285  */
3286
3287 IV
3288 PerlIOPending_fill(PerlIO *f)
3289 {
3290     /*
3291      * Should never happen
3292      */
3293     PerlIO_flush(f);
3294     return 0;
3295 }
3296
3297 IV
3298 PerlIOPending_close(PerlIO *f)
3299 {
3300     /*
3301      * A tad tricky - flush pops us, then we close new top
3302      */
3303     PerlIO_flush(f);
3304     return PerlIO_close(f);
3305 }
3306
3307 IV
3308 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3309 {
3310     /*
3311      * A tad tricky - flush pops us, then we seek new top
3312      */
3313     PerlIO_flush(f);
3314     return PerlIO_seek(f, offset, whence);
3315 }
3316
3317
3318 IV
3319 PerlIOPending_flush(PerlIO *f)
3320 {
3321     dTHX;
3322     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3323     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3324         Safefree(b->buf);
3325         b->buf = NULL;
3326     }
3327     PerlIO_pop(aTHX_ f);
3328     return 0;
3329 }
3330
3331 void
3332 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3333 {
3334     if (cnt <= 0) {
3335         PerlIO_flush(f);
3336     }
3337     else {
3338         PerlIOBuf_set_ptrcnt(f, ptr, cnt);
3339     }
3340 }
3341
3342 IV
3343 PerlIOPending_pushed(PerlIO *f, const char *mode, SV *arg)
3344 {
3345     IV code = PerlIOBase_pushed(f, mode, arg);
3346     PerlIOl *l = PerlIOBase(f);
3347     /*
3348      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3349      * etc. get muddled when it changes mid-string when we auto-pop.
3350      */
3351     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3352         (PerlIOBase(PerlIONext(f))->
3353          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3354     return code;
3355 }
3356
3357 SSize_t
3358 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3359 {
3360     SSize_t avail = PerlIO_get_cnt(f);
3361     SSize_t got = 0;
3362     if (count < avail)
3363         avail = count;
3364     if (avail > 0)
3365         got = PerlIOBuf_read(f, vbuf, avail);
3366     if (got >= 0 && got < count) {
3367         SSize_t more =
3368             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3369         if (more >= 0 || got == 0)
3370             got += more;
3371     }
3372     return got;
3373 }
3374
3375 PerlIO_funcs PerlIO_pending = {
3376     "pending",
3377     sizeof(PerlIOBuf),
3378     PERLIO_K_BUFFERED,
3379     PerlIOPending_pushed,
3380     PerlIOBase_noop_ok,
3381     NULL,
3382     NULL,
3383     PerlIOBase_fileno,
3384     PerlIOBuf_dup,
3385     PerlIOPending_read,
3386     PerlIOBuf_unread,
3387     PerlIOBuf_write,
3388     PerlIOPending_seek,
3389     PerlIOBuf_tell,
3390     PerlIOPending_close,
3391     PerlIOPending_flush,
3392     PerlIOPending_fill,
3393     PerlIOBase_eof,
3394     PerlIOBase_error,
3395     PerlIOBase_clearerr,
3396     PerlIOBase_setlinebuf,
3397     PerlIOBuf_get_base,
3398     PerlIOBuf_bufsiz,
3399     PerlIOBuf_get_ptr,
3400     PerlIOBuf_get_cnt,
3401     PerlIOPending_set_ptrcnt,
3402 };
3403
3404
3405
3406 /*--------------------------------------------------------------------------------------*/
3407 /*
3408  * crlf - translation On read translate CR,LF to "\n" we do this by
3409  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3410  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3411  */
3412
3413 typedef struct {
3414     PerlIOBuf base;             /* PerlIOBuf stuff */
3415     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3416                                  * buffer */
3417 } PerlIOCrlf;
3418
3419 IV
3420 PerlIOCrlf_pushed(PerlIO *f, const char *mode, SV *arg)
3421 {
3422     IV code;
3423     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3424     code = PerlIOBuf_pushed(f, mode, arg);
3425 #if 0
3426     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3427                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3428                  PerlIOBase(f)->flags);
3429 #endif
3430     return code;
3431 }
3432
3433
3434 SSize_t
3435 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3436 {
3437     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3438     if (c->nl) {
3439         *(c->nl) = 0xd;
3440         c->nl = NULL;
3441     }
3442     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3443         return PerlIOBuf_unread(f, vbuf, count);
3444     else {
3445         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3446         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3447         SSize_t unread = 0;
3448         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3449             PerlIO_flush(f);
3450         if (!b->buf)
3451             PerlIO_get_base(f);
3452         if (b->buf) {
3453             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3454                 b->end = b->ptr = b->buf + b->bufsiz;
3455                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3456                 b->posn -= b->bufsiz;
3457             }
3458             while (count > 0 && b->ptr > b->buf) {
3459                 int ch = *--buf;
3460                 if (ch == '\n') {
3461                     if (b->ptr - 2 >= b->buf) {
3462                         *--(b->ptr) = 0xa;
3463                         *--(b->ptr) = 0xd;
3464                         unread++;
3465                         count--;
3466                     }
3467                     else {
3468                         buf++;
3469                         break;
3470                     }
3471                 }
3472                 else {
3473                     *--(b->ptr) = ch;
3474                     unread++;
3475                     count--;
3476                 }
3477             }
3478         }
3479         return unread;
3480     }
3481 }
3482
3483 SSize_t
3484 PerlIOCrlf_get_cnt(PerlIO *f)
3485 {
3486     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3487     if (!b->buf)
3488         PerlIO_get_base(f);
3489     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3490         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3491         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) {
3492             STDCHAR *nl = b->ptr;
3493           scan:
3494             while (nl < b->end && *nl != 0xd)
3495                 nl++;
3496             if (nl < b->end && *nl == 0xd) {
3497               test:
3498                 if (nl + 1 < b->end) {
3499                     if (nl[1] == 0xa) {
3500                         *nl = '\n';
3501                         c->nl = nl;
3502                     }
3503                     else {
3504                         /*
3505                          * Not CR,LF but just CR
3506                          */
3507                         nl++;
3508                         goto scan;
3509                     }
3510                 }
3511                 else {
3512                     /*
3513                      * Blast - found CR as last char in buffer
3514                      */
3515                     if (b->ptr < nl) {
3516                         /*
3517                          * They may not care, defer work as long as
3518                          * possible
3519                          */
3520                         return (nl - b->ptr);
3521                     }
3522                     else {
3523                         int code;
3524                         b->ptr++;       /* say we have read it as far as
3525                                          * flush() is concerned */
3526                         b->buf++;       /* Leave space in front of buffer */
3527                         b->bufsiz--;    /* Buffer is thus smaller */
3528                         code = PerlIO_fill(f);  /* Fetch some more */
3529                         b->bufsiz++;    /* Restore size for next time */
3530                         b->buf--;       /* Point at space */
3531                         b->ptr = nl = b->buf;   /* Which is what we hand
3532                                                  * off */
3533                         b->posn--;      /* Buffer starts here */
3534                         *nl = 0xd;      /* Fill in the CR */
3535                         if (code == 0)
3536                             goto test;  /* fill() call worked */
3537                         /*
3538                          * CR at EOF - just fall through
3539                          */
3540                     }
3541                 }
3542             }
3543         }
3544         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3545     }
3546     return 0;
3547 }
3548
3549 void
3550 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3551 {
3552     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3553     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3554     IV flags = PerlIOBase(f)->flags;
3555     if (!b->buf)
3556         PerlIO_get_base(f);
3557     if (!ptr) {
3558         if (c->nl)
3559             ptr = c->nl + 1;
3560         else {
3561             ptr = b->end;
3562             if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3563                 ptr--;
3564         }
3565         ptr -= cnt;
3566     }
3567     else {
3568         /*
3569          * Test code - delete when it works ...
3570          */
3571         STDCHAR *chk;
3572         if (c->nl)
3573             chk = c->nl + 1;
3574         else {
3575             chk = b->end;
3576             if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3577                 chk--;
3578         }
3579         chk -= cnt;
3580
3581         if (ptr != chk) {
3582             dTHX;
3583             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3584                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3585                        b->end, cnt);
3586         }
3587     }
3588     if (c->nl) {
3589         if (ptr > c->nl) {
3590             /*
3591              * They have taken what we lied about
3592              */
3593             *(c->nl) = 0xd;
3594             c->nl = NULL;
3595             ptr++;
3596         }
3597     }
3598     b->ptr = ptr;
3599     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3600 }
3601
3602 SSize_t
3603 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3604 {
3605     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3606         return PerlIOBuf_write(f, vbuf, count);
3607     else {
3608         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3609         const STDCHAR *buf = (const STDCHAR *) vbuf;
3610         const STDCHAR *ebuf = buf + count;
3611         if (!b->buf)
3612             PerlIO_get_base(f);
3613         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3614             return 0;
3615         while (buf < ebuf) {
3616             STDCHAR *eptr = b->buf + b->bufsiz;
3617             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3618             while (buf < ebuf && b->ptr < eptr) {
3619                 if (*buf == '\n') {
3620                     if ((b->ptr + 2) > eptr) {
3621                         /*
3622                          * Not room for both
3623                          */
3624                         PerlIO_flush(f);
3625                         break;
3626                     }
3627                     else {
3628                         *(b->ptr)++ = 0xd;      /* CR */
3629                         *(b->ptr)++ = 0xa;      /* LF */
3630                         buf++;
3631                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3632                             PerlIO_flush(f);
3633                             break;
3634                         }
3635                     }
3636                 }
3637                 else {
3638                     int ch = *buf++;
3639                     *(b->ptr)++ = ch;
3640                 }
3641                 if (b->ptr >= eptr) {
3642                     PerlIO_flush(f);
3643                     break;
3644                 }
3645             }
3646         }
3647         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3648             PerlIO_flush(f);
3649         return (buf - (STDCHAR *) vbuf);
3650     }
3651 }
3652
3653 IV
3654 PerlIOCrlf_flush(PerlIO *f)
3655 {
3656     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3657     if (c->nl) {
3658         *(c->nl) = 0xd;
3659         c->nl = NULL;
3660     }
3661     return PerlIOBuf_flush(f);
3662 }
3663
3664 PerlIO_funcs PerlIO_crlf = {
3665     "crlf",
3666     sizeof(PerlIOCrlf),
3667     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3668     PerlIOCrlf_pushed,
3669     PerlIOBase_noop_ok,         /* popped */
3670     PerlIOBuf_open,
3671     NULL,
3672     PerlIOBase_fileno,
3673     PerlIOBuf_dup,
3674     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3675                                  * ... */
3676     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3677     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3678     PerlIOBuf_seek,
3679     PerlIOBuf_tell,
3680     PerlIOBuf_close,
3681     PerlIOCrlf_flush,
3682     PerlIOBuf_fill,
3683     PerlIOBase_eof,
3684     PerlIOBase_error,
3685     PerlIOBase_clearerr,
3686     PerlIOBase_setlinebuf,
3687     PerlIOBuf_get_base,
3688     PerlIOBuf_bufsiz,
3689     PerlIOBuf_get_ptr,
3690     PerlIOCrlf_get_cnt,
3691     PerlIOCrlf_set_ptrcnt,
3692 };
3693
3694 #ifdef HAS_MMAP
3695 /*--------------------------------------------------------------------------------------*/
3696 /*
3697  * mmap as "buffer" layer
3698  */
3699
3700 typedef struct {
3701     PerlIOBuf base;             /* PerlIOBuf stuff */
3702     Mmap_t mptr;                /* Mapped address */
3703     Size_t len;                 /* mapped length */
3704     STDCHAR *bbuf;              /* malloced buffer if map fails */
3705 } PerlIOMmap;
3706
3707 static size_t page_size = 0;
3708
3709 IV
3710 PerlIOMmap_map(PerlIO *f)
3711 {
3712     dTHX;
3713     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3714     IV flags = PerlIOBase(f)->flags;
3715     IV code = 0;
3716     if (m->len)
3717         abort();
3718     if (flags & PERLIO_F_CANREAD) {
3719         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3720         int fd = PerlIO_fileno(f);
3721         Stat_t st;
3722         code = Fstat(fd, &st);
3723         if (code == 0 && S_ISREG(st.st_mode)) {
3724             SSize_t len = st.st_size - b->posn;
3725             if (len > 0) {
3726                 Off_t posn;
3727                 if (!page_size) {
3728 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3729                     {
3730                         SETERRNO(0, SS$_NORMAL);
3731 #   ifdef _SC_PAGESIZE
3732                         page_size = sysconf(_SC_PAGESIZE);
3733 #   else
3734                         page_size = sysconf(_SC_PAGE_SIZE);
3735 #   endif
3736                         if ((long) page_size < 0) {
3737                             if (errno) {
3738                                 SV *error = ERRSV;
3739                                 char *msg;
3740                                 STRLEN n_a;
3741                                 (void) SvUPGRADE(error, SVt_PV);
3742                                 msg = SvPVx(error, n_a);
3743                                 Perl_croak(aTHX_ "panic: sysconf: %s",
3744                                            msg);
3745                             }
3746                             else
3747                                 Perl_croak(aTHX_
3748                                            "panic: sysconf: pagesize unknown");
3749                         }
3750                     }
3751 #else
3752 #   ifdef HAS_GETPAGESIZE
3753                     page_size = getpagesize();
3754 #   else
3755 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3756                     page_size = PAGESIZE;       /* compiletime, bad */
3757 #       endif
3758 #   endif
3759 #endif
3760                     if ((IV) page_size <= 0)
3761                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3762                                    (IV) page_size);
3763                 }
3764                 if (b->posn < 0) {
3765                     /*
3766                      * This is a hack - should never happen - open should
3767                      * have set it !
3768                      */
3769                     b->posn = PerlIO_tell(PerlIONext(f));
3770                 }
3771                 posn = (b->posn / page_size) * page_size;
3772                 len = st.st_size - posn;
3773                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3774                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3775 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3776                     madvise(m->mptr, len, MADV_SEQUENTIAL);
3777 #endif
3778 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3779                     madvise(m->mptr, len, MADV_WILLNEED);
3780 #endif
3781                     PerlIOBase(f)->flags =
3782                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3783                     b->end = ((STDCHAR *) m->mptr) + len;
3784                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3785                     b->ptr = b->buf;
3786                     m->len = len;
3787                 }
3788                 else {
3789                     b->buf = NULL;
3790                 }
3791             }
3792             else {
3793                 PerlIOBase(f)->flags =
3794                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3795                 b->buf = NULL;
3796                 b->ptr = b->end = b->ptr;
3797                 code = -1;
3798             }
3799         }
3800     }
3801     return code;
3802 }
3803
3804 IV
3805 PerlIOMmap_unmap(PerlIO *f)
3806 {
3807     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3808     PerlIOBuf *b = &m->base;
3809     IV code = 0;
3810     if (m->len) {
3811         if (b->buf) {
3812             code = munmap(m->mptr, m->len);
3813             b->buf = NULL;
3814             m->len = 0;
3815             m->mptr = NULL;
3816             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3817                 code = -1;
3818         }
3819         b->ptr = b->end = b->buf;
3820         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3821     }
3822     return code;
3823 }
3824
3825 STDCHAR *
3826 PerlIOMmap_get_base(PerlIO *f)
3827 {
3828     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3829     PerlIOBuf *b = &m->base;
3830     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3831         /*
3832          * Already have a readbuffer in progress
3833          */
3834         return b->buf;
3835     }
3836     if (b->buf) {
3837         /*
3838          * We have a write buffer or flushed PerlIOBuf read buffer
3839          */
3840         m->bbuf = b->buf;       /* save it in case we need it again */
3841         b->buf = NULL;          /* Clear to trigger below */
3842     }
3843     if (!b->buf) {
3844         PerlIOMmap_map(f);      /* Try and map it */
3845         if (!b->buf) {
3846             /*
3847              * Map did not work - recover PerlIOBuf buffer if we have one
3848              */
3849             b->buf = m->bbuf;
3850         }
3851     }
3852     b->ptr = b->end = b->buf;
3853     if (b->buf)
3854         return b->buf;
3855     return PerlIOBuf_get_base(f);
3856 }
3857
3858 SSize_t
3859 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3860 {
3861     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3862     PerlIOBuf *b = &m->base;
3863     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3864         PerlIO_flush(f);
3865     if (b->ptr && (b->ptr - count) >= b->buf
3866         && memEQ(b->ptr - count, vbuf, count)) {
3867         b->ptr -= count;
3868         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3869         return count;
3870     }
3871     if (m->len) {
3872         /*
3873          * Loose the unwritable mapped buffer
3874          */
3875         PerlIO_flush(f);
3876         /*
3877          * If flush took the "buffer" see if we have one from before
3878          */
3879         if (!b->buf && m->bbuf)
3880             b->buf = m->bbuf;
3881         if (!b->buf) {
3882             PerlIOBuf_get_base(f);
3883             m->bbuf = b->buf;
3884         }
3885     }
3886     return PerlIOBuf_unread(f, vbuf, count);
3887 }
3888
3889 SSize_t
3890 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3891 {
3892     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3893     PerlIOBuf *b = &m->base;
3894     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3895         /*
3896          * No, or wrong sort of, buffer
3897          */
3898         if (m->len) {
3899             if (PerlIOMmap_unmap(f) != 0)
3900                 return 0;
3901         }
3902         /*
3903          * If unmap took the "buffer" see if we have one from before
3904          */
3905         if (!b->buf && m->bbuf)
3906             b->buf = m->bbuf;
3907         if (!b->buf) {
3908             PerlIOBuf_get_base(f);
3909             m->bbuf = b->buf;
3910         }
3911     }
3912     return PerlIOBuf_write(f, vbuf, count);
3913 }
3914
3915 IV
3916 PerlIOMmap_flush(PerlIO *f)
3917 {
3918     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3919     PerlIOBuf *b = &m->base;
3920     IV code = PerlIOBuf_flush(f);
3921     /*
3922      * Now we are "synced" at PerlIOBuf level
3923      */
3924     if (b->buf) {
3925         if (m->len) {
3926             /*
3927              * Unmap the buffer
3928              */
3929             if (PerlIOMmap_unmap(f) != 0)
3930                 code = -1;
3931         }
3932         else {
3933             /*
3934              * We seem to have a PerlIOBuf buffer which was not mapped
3935              * remember it in case we need one later
3936              */
3937             m->bbuf = b->buf;
3938         }
3939     }
3940     return code;
3941 }
3942
3943 IV
3944 PerlIOMmap_fill(PerlIO *f)
3945 {
3946     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3947     IV code = PerlIO_flush(f);
3948     if (code == 0 && !b->buf) {
3949         code = PerlIOMmap_map(f);
3950     }
3951     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3952         code = PerlIOBuf_fill(f);
3953     }
3954     return code;
3955 }
3956
3957 IV
3958 PerlIOMmap_close(PerlIO *f)
3959 {
3960     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3961     PerlIOBuf *b = &m->base;
3962     IV code = PerlIO_flush(f);
3963     if (m->bbuf) {
3964         b->buf = m->bbuf;
3965         m->bbuf = NULL;
3966         b->ptr = b->end = b->buf;
3967     }
3968     if (PerlIOBuf_close(f) != 0)
3969         code = -1;
3970     return code;
3971 }
3972
3973 PerlIO *
3974 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
3975 {
3976  return PerlIOBase_dup(aTHX_ f, o, param);
3977 }
3978
3979
3980 PerlIO_funcs PerlIO_mmap = {
3981     "mmap",
3982     sizeof(PerlIOMmap),
3983     PERLIO_K_BUFFERED,
3984     PerlIOBuf_pushed,
3985     PerlIOBase_noop_ok,
3986     PerlIOBuf_open,
3987     NULL,
3988     PerlIOBase_fileno,
3989     PerlIOMmap_dup,
3990     PerlIOBuf_read,
3991     PerlIOMmap_unread,
3992     PerlIOMmap_write,
3993     PerlIOBuf_seek,
3994     PerlIOBuf_tell,
3995     PerlIOBuf_close,
3996     PerlIOMmap_flush,
3997     PerlIOMmap_fill,
3998     PerlIOBase_eof,
3999     PerlIOBase_error,
4000     PerlIOBase_clearerr,
4001     PerlIOBase_setlinebuf,
4002     PerlIOMmap_get_base,
4003     PerlIOBuf_bufsiz,
4004     PerlIOBuf_get_ptr,
4005     PerlIOBuf_get_cnt,
4006     PerlIOBuf_set_ptrcnt,
4007 };
4008
4009 #endif                          /* HAS_MMAP */
4010
4011 #undef PerlIO_stdin
4012 PerlIO *
4013 PerlIO_stdin(void)
4014 {
4015     dTHX;
4016     if (!PL_perlio) {
4017         PerlIO_stdstreams(aTHX);
4018     }
4019     return &PL_perlio[1];
4020 }
4021
4022 #undef PerlIO_stdout
4023 PerlIO *
4024 PerlIO_stdout(void)
4025 {
4026     dTHX;
4027     if (!PL_perlio) {
4028         PerlIO_stdstreams(aTHX);
4029     }
4030     return &PL_perlio[2];
4031 }
4032
4033 #undef PerlIO_stderr
4034 PerlIO *
4035 PerlIO_stderr(void)
4036 {
4037     dTHX;
4038     if (!PL_perlio) {
4039         PerlIO_stdstreams(aTHX);
4040     }
4041     return &PL_perlio[3];
4042 }
4043
4044 /*--------------------------------------------------------------------------------------*/
4045
4046 #undef PerlIO_getname
4047 char *
4048 PerlIO_getname(PerlIO *f, char *buf)
4049 {
4050     dTHX;
4051     char *name = NULL;
4052 #ifdef VMS
4053     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4054     if (stdio)
4055         name = fgetname(stdio, buf);
4056 #else
4057     Perl_croak(aTHX_ "Don't know how to get file name");
4058 #endif
4059     return name;
4060 }
4061
4062
4063 /*--------------------------------------------------------------------------------------*/
4064 /*
4065  * Functions which can be called on any kind of PerlIO implemented in
4066  * terms of above
4067  */
4068
4069 #undef PerlIO_getc
4070 int
4071 PerlIO_getc(PerlIO *f)
4072 {
4073     STDCHAR buf[1];
4074     SSize_t count = PerlIO_read(f, buf, 1);
4075     if (count == 1) {
4076         return (unsigned char) buf[0];
4077     }
4078     return EOF;
4079 }
4080
4081 #undef PerlIO_ungetc
4082 int
4083 PerlIO_ungetc(PerlIO *f, int ch)
4084 {
4085     if (ch != EOF) {
4086         STDCHAR buf = ch;
4087         if (PerlIO_unread(f, &buf, 1) == 1)
4088             return ch;
4089     }
4090     return EOF;
4091 }
4092
4093 #undef PerlIO_putc
4094 int
4095 PerlIO_putc(PerlIO *f, int ch)
4096 {
4097     STDCHAR buf = ch;
4098     return PerlIO_write(f, &buf, 1);
4099 }
4100
4101 #undef PerlIO_puts
4102 int
4103 PerlIO_puts(PerlIO *f, const char *s)
4104 {
4105     STRLEN len = strlen(s);
4106     return PerlIO_write(f, s, len);
4107 }
4108
4109 #undef PerlIO_rewind
4110 void
4111 PerlIO_rewind(PerlIO *f)
4112 {
4113     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4114     PerlIO_clearerr(f);
4115 }
4116
4117 #undef PerlIO_vprintf
4118 int
4119 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4120 {
4121     dTHX;
4122     SV *sv = newSVpvn("", 0);
4123     char *s;
4124     STRLEN len;
4125     SSize_t wrote;
4126 #ifdef NEED_VA_COPY
4127     va_list apc;
4128     Perl_va_copy(ap, apc);
4129     sv_vcatpvf(sv, fmt, &apc);
4130 #else
4131     sv_vcatpvf(sv, fmt, &ap);
4132 #endif
4133     s = SvPV(sv, len);
4134     wrote = PerlIO_write(f, s, len);
4135     SvREFCNT_dec(sv);
4136     return wrote;
4137 }
4138
4139 #undef PerlIO_printf
4140 int
4141 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4142 {
4143     va_list ap;
4144     int result;
4145     va_start(ap, fmt);
4146     result = PerlIO_vprintf(f, fmt, ap);
4147     va_end(ap);
4148     return result;
4149 }
4150
4151 #undef PerlIO_stdoutf
4152 int
4153 PerlIO_stdoutf(const char *fmt, ...)
4154 {
4155     va_list ap;
4156     int result;
4157     va_start(ap, fmt);
4158     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4159     va_end(ap);
4160     return result;
4161 }
4162
4163 #undef PerlIO_tmpfile
4164 PerlIO *
4165 PerlIO_tmpfile(void)
4166 {
4167     /*
4168      * I have no idea how portable mkstemp() is ...
4169      */
4170 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4171     dTHX;
4172     PerlIO *f = NULL;
4173     FILE *stdio = PerlSIO_tmpfile();
4174     if (stdio) {
4175         PerlIOStdio *s =
4176             PerlIOSelf(PerlIO_push
4177                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4178                         "w+", Nullsv), PerlIOStdio);
4179         s->stdio = stdio;
4180     }
4181     return f;
4182 #else
4183     dTHX;
4184     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4185     int fd = mkstemp(SvPVX(sv));
4186     PerlIO *f = NULL;
4187     if (fd >= 0) {
4188         f = PerlIO_fdopen(fd, "w+");
4189         if (f) {
4190             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4191         }
4192         PerlLIO_unlink(SvPVX(sv));
4193         SvREFCNT_dec(sv);
4194     }
4195     return f;
4196 #endif
4197 }
4198
4199 #undef HAS_FSETPOS
4200 #undef HAS_FGETPOS
4201
4202 #endif                          /* USE_SFIO */
4203 #endif                          /* PERLIO_IS_STDIO */
4204
4205 /*======================================================================================*/
4206 /*
4207  * Now some functions in terms of above which may be needed even if we are
4208  * not in true PerlIO mode
4209  */
4210
4211 #ifndef HAS_FSETPOS
4212 #undef PerlIO_setpos
4213 int
4214 PerlIO_setpos(PerlIO *f, SV *pos)
4215 {
4216     dTHX;
4217     if (SvOK(pos)) {
4218         STRLEN len;
4219         Off_t *posn = (Off_t *) SvPV(pos, len);
4220         if (f && len == sizeof(Off_t))
4221             return PerlIO_seek(f, *posn, SEEK_SET);
4222     }
4223     SETERRNO(EINVAL, SS$_IVCHAN);
4224     return -1;
4225 }
4226 #else
4227 #undef PerlIO_setpos
4228 int
4229 PerlIO_setpos(PerlIO *f, SV *pos)
4230 {
4231     dTHX;
4232     if (SvOK(pos)) {
4233         STRLEN len;
4234         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4235         if (f && len == sizeof(Fpos_t)) {
4236 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4237             return fsetpos64(f, fpos);
4238 #else
4239             return fsetpos(f, fpos);
4240 #endif
4241         }
4242     }
4243     SETERRNO(EINVAL, SS$_IVCHAN);
4244     return -1;
4245 }
4246 #endif
4247
4248 #ifndef HAS_FGETPOS
4249 #undef PerlIO_getpos
4250 int
4251 PerlIO_getpos(PerlIO *f, SV *pos)
4252 {
4253     dTHX;
4254     Off_t posn = PerlIO_tell(f);
4255     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4256     return (posn == (Off_t) - 1) ? -1 : 0;
4257 }
4258 #else
4259 #undef PerlIO_getpos
4260 int
4261 PerlIO_getpos(PerlIO *f, SV *pos)
4262 {
4263     dTHX;
4264     Fpos_t fpos;
4265     int code;
4266 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4267     code = fgetpos64(f, &fpos);
4268 #else
4269     code = fgetpos(f, &fpos);
4270 #endif
4271     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4272     return code;
4273 }
4274 #endif
4275
4276 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4277
4278 int
4279 vprintf(char *pat, char *args)
4280 {
4281     _doprnt(pat, args, stdout);
4282     return 0;                   /* wrong, but perl doesn't use the return
4283                                  * value */
4284 }
4285
4286 int
4287 vfprintf(FILE *fd, char *pat, char *args)
4288 {
4289     _doprnt(pat, args, fd);
4290     return 0;                   /* wrong, but perl doesn't use the return
4291                                  * value */
4292 }
4293
4294 #endif
4295
4296 #ifndef PerlIO_vsprintf
4297 int
4298 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4299 {
4300     int val = vsprintf(s, fmt, ap);
4301     if (n >= 0) {
4302         if (strlen(s) >= (STRLEN) n) {
4303             dTHX;
4304             (void) PerlIO_puts(Perl_error_log,
4305                                "panic: sprintf overflow - memory corrupted!\n");
4306             my_exit(1);
4307         }
4308     }
4309     return val;
4310 }
4311 #endif
4312
4313 #ifndef PerlIO_sprintf
4314 int
4315 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4316 {
4317     va_list ap;
4318     int result;
4319     va_start(ap, fmt);
4320     result = PerlIO_vsprintf(s, n, fmt, ap);
4321     va_end(ap);
4322     return result;
4323 }
4324 #endif
4325
4326
4327
4328
4329