perlio.c

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