perlio.c

   1 /*
   2  * perlio.c Copyright (c) 1996-2001, Nick Ing-Simmons You may distribute
   3  * under the terms of either the GNU General Public License or the
   4  * Artistic License, as specified in the README file.
   5  */
   6
   7 /*
   8  * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
   9  * at the dispatch tables, even when we do not need it for other reasons.
  10  * Invent a dSYS macro to abstract this out
  11  */
  12 #ifdef PERL_IMPLICIT_SYS
  13 #define dSYS dTHX
  14 #else
  15 #define dSYS dNOOP
  16 #endif
  17
  18 #define VOIDUSED 1
  19 #ifdef PERL_MICRO
  20 #   include "uconfig.h"
  21 #else
  22 #   include "config.h"
  23 #endif
  24
  25 #define PERLIO_NOT_STDIO 0
  26 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  27 /*
  28  * #define PerlIO FILE
  29  */
  30 #endif
  31 /*
  32  * This file provides those parts of PerlIO abstraction
  33  * which are not #defined in perlio.h.
  34  * Which these are depends on various Configure #ifdef's
  35  */
  36
  37 #include "EXTERN.h"
  38 #define PERL_IN_PERLIO_C
  39 #include "perl.h"
  40
  41 #ifdef PERL_IMPLICIT_CONTEXT
  42 #undef dSYS
  43 #define dSYS dTHX
  44 #endif
  45
  46 #include "XSUB.h"
  47
  48 int
  49 perlsio_binmode(FILE *fp, int iotype, int mode)
  50 {
  51     /*
  52      * This used to be contents of do_binmode in doio.c
  53      */
  54 #ifdef DOSISH
  55 #  if defined(atarist) || defined(__MINT__)
  56     if (!fflush(fp)) {
  57         if (mode & O_BINARY)
  58             ((FILE *) fp)->_flag |= _IOBIN;
  59         else
  60             ((FILE *) fp)->_flag &= ~_IOBIN;
  61         return 1;
  62     }
  63     return 0;
  64 #  else
  65     dTHX;
  66 #ifdef NETWARE
  67     if (PerlLIO_setmode(fp, mode) != -1) {
  68 #else
  69     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  70 #endif
  71 #    if defined(WIN32) && defined(__BORLANDC__)
  72         /*
  73          * The translation mode of the stream is maintained independent of
  74          * the translation mode of the fd in the Borland RTL (heavy
  75          * digging through their runtime sources reveal).  User has to set
  76          * the mode explicitly for the stream (though they don't document
  77          * this anywhere). GSAR 97-5-24
  78          */
  79         fseek(fp, 0L, 0);
  80         if (mode & O_BINARY)
  81             fp->flags |= _F_BIN;
  82         else
  83             fp->flags &= ~_F_BIN;
  84 #    endif
  85         return 1;
  86     }
  87     else
  88         return 0;
  89 #  endif
  90 #else
  91 #  if defined(USEMYBINMODE)
  92     if (my_binmode(fp, iotype, mode) != FALSE)
  93         return 1;
  94     else
  95         return 0;
  96 #  else
  97     return 1;
  98 #  endif
  99 #endif
 100 }
 101
 102 #ifndef O_ACCMODE
 103 #define O_ACCMODE 3             /* Assume traditional implementation */
 104 #endif
 105
 106 int
 107 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
 108 {
 109     int result = rawmode & O_ACCMODE;
 110     int ix = 0;
 111     int ptype;
 112     switch (result) {
 113     case O_RDONLY:
 114         ptype = IoTYPE_RDONLY;
 115         break;
 116     case O_WRONLY:
 117         ptype = IoTYPE_WRONLY;
 118         break;
 119     case O_RDWR:
 120     default:
 121         ptype = IoTYPE_RDWR;
 122         break;
 123     }
 124     if (writing)
 125         *writing = (result != O_RDONLY);
 126
 127     if (result == O_RDONLY) {
 128         mode[ix++] = 'r';
 129     }
 130 #ifdef O_APPEND
 131     else if (rawmode & O_APPEND) {
 132         mode[ix++] = 'a';
 133         if (result != O_WRONLY)
 134             mode[ix++] = '+';
 135     }
 136 #endif
 137     else {
 138         if (result == O_WRONLY)
 139             mode[ix++] = 'w';
 140         else {
 141             mode[ix++] = 'r';
 142             mode[ix++] = '+';
 143         }
 144     }
 145     if (rawmode & O_BINARY)
 146         mode[ix++] = 'b';
 147     mode[ix] = '\0';
 148     return ptype;
 149 }
 150
 151 #ifndef PERLIO_LAYERS
 152 int
 153 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 154 {
 155     if (!names || !*names || strEQ(names, ":crlf") || strEQ(names, ":raw")) {
 156         return 0;
 157     }
 158     Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
 159     /*
 160      * NOTREACHED
 161      */
 162     return -1;
 163 }
 164
 165 void
 166 PerlIO_destruct(pTHX)
 167 {
 168 }
 169
 170 int
 171 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 172 {
 173 #ifdef USE_SFIO
 174     return 1;
 175 #else
 176     return perlsio_binmode(fp, iotype, mode);
 177 #endif
 178 }
 179
 180 PerlIO *
 181 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
 182 {
 183 #ifndef PERL_MICRO
 184     if (f) {
 185         int fd = PerlLIO_dup(PerlIO_fileno(f));
 186         if (fd >= 0) {
 187             char mode[8];
 188             int omode = fcntl(fd, F_GETFL);
 189             PerlIO_intmode2str(omode,mode,NULL);
 190             /* the r+ is a hack */
 191             return PerlIO_fdopen(fd, mode);
 192         }
 193         return NULL;
 194     }
 195     else {
 196         SETERRNO(EBADF, SS$_IVCHAN);
 197     }
 198 #endif
 199     return NULL;
 200 }
 201
 202
 203 /*
 204  * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
 205  */
 206
 207 PerlIO *
 208 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 209              int imode, int perm, PerlIO *old, int narg, SV **args)
 210 {
 211     if (narg == 1) {
 212         if (*args == &PL_sv_undef)
 213             return PerlIO_tmpfile();
 214         else {
 215             char *name = SvPV_nolen(*args);
 216             if (*mode == '#') {
 217                 fd = PerlLIO_open3(name, imode, perm);
 218                 if (fd >= 0)
 219                     return PerlIO_fdopen(fd, (char *) mode + 1);
 220             }
 221             else if (old) {
 222                 return PerlIO_reopen(name, mode, old);
 223             }
 224             else {
 225                 return PerlIO_open(name, mode);
 226             }
 227         }
 228     }
 229     else {
 230         return PerlIO_fdopen(fd, (char *) mode);
 231     }
 232     return NULL;
 233 }
 234
 235 XS(XS_PerlIO__Layer__find)
 236 {
 237     dXSARGS;
 238     if (items < 2)
 239         Perl_croak(aTHX_ "Usage class->find(name[,load])");
 240     else {
 241         char *name = SvPV_nolen(ST(1));
 242         ST(0) = (strEQ(name, "crlf")
 243                  || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
 244         XSRETURN(1);
 245     }
 246 }
 247
 248
 249 void
 250 Perl_boot_core_PerlIO(pTHX)
 251 {
 252     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
 253 }
 254
 255 #endif
 256
 257
 258 #ifdef PERLIO_IS_STDIO
 259
 260 void
 261 PerlIO_init(pTHX)
 262 {
 263     /*
 264      * Does nothing (yet) except force this file to be included in perl
 265      * binary. That allows this file to force inclusion of other functions
 266      * that may be required by loadable extensions e.g. for
 267      * FileHandle::tmpfile
 268      */
 269 }
 270
 271 #undef PerlIO_tmpfile
 272 PerlIO *
 273 PerlIO_tmpfile(void)
 274 {
 275     return tmpfile();
 276 }
 277
 278 #else                           /* PERLIO_IS_STDIO */
 279
 280 #ifdef USE_SFIO
 281
 282 #undef HAS_FSETPOS
 283 #undef HAS_FGETPOS
 284
 285 /*
 286  * This section is just to make sure these functions get pulled in from
 287  * libsfio.a
 288  */
 289
 290 #undef PerlIO_tmpfile
 291 PerlIO *
 292 PerlIO_tmpfile(void)
 293 {
 294     return sftmp(0);
 295 }
 296
 297 void
 298 PerlIO_init(pTHX)
 299 {
 300     /*
 301      * Force this file to be included in perl binary. Which allows this
 302      * file to force inclusion of other functions that may be required by
 303      * loadable extensions e.g. for FileHandle::tmpfile
 304      */
 305
 306     /*
 307      * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
 308      * results in a lot of lseek()s to regular files and lot of small
 309      * writes to pipes.
 310      */
 311     sfset(sfstdout, SF_SHARE, 0);
 312 }
 313
 314 PerlIO *
 315 PerlIO_importFILE(FILE *stdio, int fl)
 316 {
 317     int fd = fileno(stdio);
 318     PerlIO *r = PerlIO_fdopen(fd, "r+");
 319     return r;
 320 }
 321
 322 FILE *
 323 PerlIO_findFILE(PerlIO *pio)
 324 {
 325     int fd = PerlIO_fileno(pio);
 326     FILE *f = fdopen(fd, "r+");
 327     PerlIO_flush(pio);
 328     if (!f && errno == EINVAL)
 329         f = fdopen(fd, "w");
 330     if (!f && errno == EINVAL)
 331         f = fdopen(fd, "r");
 332     return f;
 333 }
 334
 335
 336 #else                           /* USE_SFIO */
 337 /*======================================================================================*/
 338 /*
 339  * Implement all the PerlIO interface ourselves.
 340  */
 341
 342 #include "perliol.h"
 343
 344 /*
 345  * We _MUST_ have <unistd.h> if we are using lseek() and may have large
 346  * files
 347  */
 348 #ifdef I_UNISTD
 349 #include <unistd.h>
 350 #endif
 351 #ifdef HAS_MMAP
 352 #include <sys/mman.h>
 353 #endif
 354
 355
 356 void PerlIO_debug(const char *fmt, ...)
 357     __attribute__ ((format(__printf__, 1, 2)));
 358
 359 void
 360 PerlIO_debug(const char *fmt, ...)
 361 {
 362     static int dbg = 0;
 363     va_list ap;
 364     dSYS;
 365     va_start(ap, fmt);
 366     if (!dbg) {
 367         char *s = PerlEnv_getenv("PERLIO_DEBUG");
 368         if (s && *s)
 369             dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
 370         else
 371             dbg = -1;
 372     }
 373     if (dbg > 0) {
 374         dTHX;
 375 #ifdef USE_ITHREADS
 376         /* Use fixed buffer as sv_catpvf etc. needs SVs */
 377         char buffer[1024];
 378         char *s;
 379         STRLEN len;
 380         s = CopFILE(PL_curcop);
 381         if (!s)
 382             s = "(none)";
 383         sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
 384         len = strlen(buffer);
 385         vsprintf(buffer+len, fmt, ap);
 386         PerlLIO_write(dbg, buffer, strlen(buffer));
 387 #else
 388         SV *sv = newSVpvn("", 0);
 389         char *s;
 390         STRLEN len;
 391         s = CopFILE(PL_curcop);
 392         if (!s)
 393             s = "(none)";
 394         Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
 395                        (IV) CopLINE(PL_curcop));
 396         Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 397
 398         s = SvPV(sv, len);
 399         PerlLIO_write(dbg, s, len);
 400         SvREFCNT_dec(sv);
 401 #endif
 402     }
 403     va_end(ap);
 404 }
 405
 406 /*--------------------------------------------------------------------------------------*/
 407
 408 /*
 409  * Inner level routines
 410  */
 411
 412 /*
 413  * Table of pointers to the PerlIO structs (malloc'ed)
 414  */
 415 #define PERLIO_TABLE_SIZE 64
 416
 417 PerlIO *
 418 PerlIO_allocate(pTHX)
 419 {
 420     /*
 421      * Find a free slot in the table, allocating new table as necessary
 422      */
 423     PerlIO **last;
 424     PerlIO *f;
 425     last = &PL_perlio;
 426     while ((f = *last)) {
 427         int i;
 428         last = (PerlIO **) (f);
 429         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 430             if (!*++f) {
 431                 return f;
 432             }
 433         }
 434     }
 435     Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 436     if (!f) {
 437         return NULL;
 438     }
 439     *last = f;
 440     return f + 1;
 441 }
 442
 443 #undef PerlIO_fdupopen
 444 PerlIO *
 445 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
 446 {
 447     if (f && *f) {
 448         PerlIO_funcs *tab = PerlIOBase(f)->tab;
 449         PerlIO *new;
 450         PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
 451         new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param);
 452         return new;
 453     }
 454     else {
 455         SETERRNO(EBADF, SS$_IVCHAN);
 456         return NULL;
 457     }
 458 }
 459
 460 void
 461 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 462 {
 463     PerlIO *table = *tablep;
 464     if (table) {
 465         int i;
 466         PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
 467         for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
 468             PerlIO *f = table + i;
 469             if (*f) {
 470                 PerlIO_close(f);
 471             }
 472         }
 473         Safefree(table);
 474         *tablep = NULL;
 475     }
 476 }
 477
 478
 479 PerlIO_list_t *
 480 PerlIO_list_alloc(pTHX)
 481 {
 482     PerlIO_list_t *list;
 483     Newz('L', list, 1, PerlIO_list_t);
 484     list->refcnt = 1;
 485     return list;
 486 }
 487
 488 void
 489 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
 490 {
 491     if (list) {
 492         if (--list->refcnt == 0) {
 493             if (list->array) {
 494                 IV i;
 495                 for (i = 0; i < list->cur; i++) {
 496                     if (list->array[i].arg)
 497                         SvREFCNT_dec(list->array[i].arg);
 498                 }
 499                 Safefree(list->array);
 500             }
 501             Safefree(list);
 502         }
 503     }
 504 }
 505
 506 void
 507 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
 508 {
 509     PerlIO_pair_t *p;
 510     if (list->cur >= list->len) {
 511         list->len += 8;
 512         if (list->array)
 513             Renew(list->array, list->len, PerlIO_pair_t);
 514         else
 515             New('l', list->array, list->len, PerlIO_pair_t);
 516     }
 517     p = &(list->array[list->cur++]);
 518     p->funcs = funcs;
 519     if ((p->arg = arg)) {
 520         SvREFCNT_inc(arg);
 521     }
 522 }
 523
 524 PerlIO_list_t *
 525 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
 526 {
 527     PerlIO_list_t *list = (PerlIO_list_t *) NULL;
 528     if (proto) {
 529         int i;
 530         list = PerlIO_list_alloc(aTHX);
 531         for (i=0; i < proto->cur; i++) {
 532             SV *arg = Nullsv;
 533             if (proto->array[i].arg)
 534                 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
 535             PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
 536         }
 537     }
 538     return list;
 539 }
 540
 541 void
 542 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
 543 {
 544 #ifdef USE_ITHREADS
 545     PerlIO **table = &proto->Iperlio;
 546     PerlIO *f;
 547     PL_perlio = NULL;
 548     PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
 549     PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
 550     PerlIO_allocate(aTHX); /* root slot is never used */
 551     PerlIO_debug("Clone %p from %p\n",aTHX,proto);
 552     while ((f = *table)) {
 553             int i;
 554             table = (PerlIO **) (f++);
 555             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 556                 if (*f) {
 557                     (void) fp_dup(f, 0, param);
 558                 }
 559                 f++;
 560             }
 561         }
 562 #endif
 563 }
 564
 565 void
 566 PerlIO_destruct(pTHX)
 567 {
 568     PerlIO **table = &PL_perlio;
 569     PerlIO *f;
 570 #ifdef USE_ITHREADS
 571     PerlIO_debug("Destruct %p\n",aTHX);
 572 #endif
 573     while ((f = *table)) {
 574         int i;
 575         table = (PerlIO **) (f++);
 576         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 577             PerlIO *x = f;
 578             PerlIOl *l;
 579             while ((l = *x)) {
 580                 if (l->tab->kind & PERLIO_K_DESTRUCT) {
 581                     PerlIO_debug("Destruct popping %s\n", l->tab->name);
 582                     PerlIO_flush(x);
 583                     PerlIO_pop(aTHX_ x);
 584                 }
 585                 else {
 586                     x = PerlIONext(x);
 587                 }
 588             }
 589             f++;
 590         }
 591     }
 592     PerlIO_list_free(aTHX_ PL_known_layers);
 593     PL_known_layers = NULL;
 594     PerlIO_list_free(aTHX_ PL_def_layerlist);
 595     PL_def_layerlist = NULL;
 596 }
 597
 598 void
 599 PerlIO_pop(pTHX_ PerlIO *f)
 600 {
 601     PerlIOl *l = *f;
 602     if (l) {
 603         PerlIO_debug("PerlIO_pop f=%p %s\n", f, l->tab->name);
 604         if (l->tab->Popped) {
 605             /*
 606              * If popped returns non-zero do not free its layer structure
 607              * it has either done so itself, or it is shared and still in
 608              * use
 609              */
 610             if ((*l->tab->Popped) (f) != 0)
 611                 return;
 612         }
 613         *f = l->next;;
 614         Safefree(l);
 615     }
 616 }
 617
 618 /*--------------------------------------------------------------------------------------*/
 619 /*
 620  * XS Interface for perl code
 621  */
 622
 623 PerlIO_funcs *
 624 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 625 {
 626     IV i;
 627     if ((SSize_t) len <= 0)
 628         len = strlen(name);
 629     for (i = 0; i < PL_known_layers->cur; i++) {
 630         PerlIO_funcs *f = PL_known_layers->array[i].funcs;
 631         if (memEQ(f->name, name, len)) {
 632             PerlIO_debug("%.*s => %p\n", (int) len, name, f);
 633             return f;
 634         }
 635     }
 636     if (load && PL_subname && PL_def_layerlist
 637         && PL_def_layerlist->cur >= 2) {
 638         SV *pkgsv = newSVpvn("PerlIO", 6);
 639         SV *layer = newSVpvn(name, len);
 640         ENTER;
 641         /*
 642          * The two SVs are magically freed by load_module
 643          */
 644         Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
 645         LEAVE;
 646         return PerlIO_find_layer(aTHX_ name, len, 0);
 647     }
 648     PerlIO_debug("Cannot find %.*s\n", (int) len, name);
 649     return NULL;
 650 }
 651
 652 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 653
 654 static int
 655 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 656 {
 657     if (SvROK(sv)) {
 658         IO *io = GvIOn((GV *) SvRV(sv));
 659         PerlIO *ifp = IoIFP(io);
 660         PerlIO *ofp = IoOFP(io);
 661         Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
 662     }
 663     return 0;
 664 }
 665
 666 static int
 667 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 668 {
 669     if (SvROK(sv)) {
 670         IO *io = GvIOn((GV *) SvRV(sv));
 671         PerlIO *ifp = IoIFP(io);
 672         PerlIO *ofp = IoOFP(io);
 673         Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
 674     }
 675     return 0;
 676 }
 677
 678 static int
 679 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 680 {
 681     Perl_warn(aTHX_ "clear %" SVf, sv);
 682     return 0;
 683 }
 684
 685 static int
 686 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 687 {
 688     Perl_warn(aTHX_ "free %" SVf, sv);
 689     return 0;
 690 }
 691
 692 MGVTBL perlio_vtab = {
 693     perlio_mg_get,
 694     perlio_mg_set,
 695     NULL,                       /* len */
 696     perlio_mg_clear,
 697     perlio_mg_free
 698 };
 699
 700 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 701 {
 702     dXSARGS;
 703     SV *sv = SvRV(ST(1));
 704     AV *av = newAV();
 705     MAGIC *mg;
 706     int count = 0;
 707     int i;
 708     sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
 709     SvRMAGICAL_off(sv);
 710     mg = mg_find(sv, PERL_MAGIC_ext);
 711     mg->mg_virtual = &perlio_vtab;
 712     mg_magical(sv);
 713     Perl_warn(aTHX_ "attrib %" SVf, sv);
 714     for (i = 2; i < items; i++) {
 715         STRLEN len;
 716         const char *name = SvPV(ST(i), len);
 717         SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
 718         if (layer) {
 719             av_push(av, SvREFCNT_inc(layer));
 720         }
 721         else {
 722             ST(count) = ST(i);
 723             count++;
 724         }
 725     }
 726     SvREFCNT_dec(av);
 727     XSRETURN(count);
 728 }
 729
 730 #endif                          /* USE_ATTIBUTES_FOR_PERLIO */
 731
 732 SV *
 733 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 734 {
 735     HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
 736     SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
 737     return sv;
 738 }
 739
 740 XS(XS_PerlIO__Layer__find)
 741 {
 742     dXSARGS;
 743     if (items < 2)
 744         Perl_croak(aTHX_ "Usage class->find(name[,load])");
 745     else {
 746         STRLEN len = 0;
 747         char *name = SvPV(ST(1), len);
 748         bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
 749         PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
 750         ST(0) =
 751             (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
 752             &PL_sv_undef;
 753         XSRETURN(1);
 754     }
 755 }
 756
 757 void
 758 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 759 {
 760     if (!PL_known_layers)
 761         PL_known_layers = PerlIO_list_alloc(aTHX);
 762     PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
 763     PerlIO_debug("define %s %p\n", tab->name, tab);
 764 }
 765
 766 int
 767 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 768 {
 769     if (names) {
 770         const char *s = names;
 771         while (*s) {
 772             while (isSPACE(*s) || *s == ':')
 773                 s++;
 774             if (*s) {
 775                 STRLEN llen = 0;
 776                 const char *e = s;
 777                 const char *as = Nullch;
 778                 STRLEN alen = 0;
 779                 if (!isIDFIRST(*s)) {
 780                     /*
 781                      * Message is consistent with how attribute lists are
 782                      * passed. Even though this means "foo : : bar" is
 783                      * seen as an invalid separator character.
 784                      */
 785                     char q = ((*s == '\'') ? '"' : '\'');
 786                     Perl_warn(aTHX_
 787                               "perlio: invalid separator character %c%c%c in layer specification list %s",
 788                               q, *s, q, s);
 789                     return -1;
 790                 }
 791                 do {
 792                     e++;
 793                 } while (isALNUM(*e));
 794                 llen = e - s;
 795                 if (*e == '(') {
 796                     int nesting = 1;
 797                     as = ++e;
 798                     while (nesting) {
 799                         switch (*e++) {
 800                         case ')':
 801                             if (--nesting == 0)
 802                                 alen = (e - 1) - as;
 803                             break;
 804                         case '(':
 805                             ++nesting;
 806                             break;
 807                         case '\\':
 808                             /*
 809                              * It's a nul terminated string, not allowed
 810                              * to \ the terminating null. Anything other
 811                              * character is passed over.
 812                              */
 813                             if (*e++) {
 814                                 break;
 815                             }
 816                             /*
 817                              * Drop through
 818                              */
 819                         case '\0':
 820                             e--;
 821                             Perl_warn(aTHX_
 822                                       "perlio: argument list not closed for layer \"%.*s\"",
 823                                       (int) (e - s), s);
 824                             return -1;
 825                         default:
 826                             /*
 827                              * boring.
 828                              */
 829                             break;
 830                         }
 831                     }
 832                 }
 833                 if (e > s) {
 834                     PerlIO_funcs *layer =
 835                         PerlIO_find_layer(aTHX_ s, llen, 1);
 836                     if (layer) {
 837                         PerlIO_list_push(aTHX_ av, layer,
 838                                          (as) ? newSVpvn(as,
 839                                                          alen) :
 840                                          &PL_sv_undef);
 841                     }
 842                     else {
 843                         Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",
 844                                   (int) llen, s);
 845                         return -1;
 846                     }
 847                 }
 848                 s = e;
 849             }
 850         }
 851     }
 852     return 0;
 853 }
 854
 855 void
 856 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
 857 {
 858     PerlIO_funcs *tab = &PerlIO_perlio;
 859     if (O_BINARY != O_TEXT) {
 860         tab = &PerlIO_crlf;
 861     }
 862     else {
 863         if (PerlIO_stdio.Set_ptrcnt) {
 864             tab = &PerlIO_stdio;
 865         }
 866     }
 867     PerlIO_debug("Pushing %s\n", tab->name);
 868     PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
 869                      &PL_sv_undef);
 870 }
 871
 872 SV *
 873 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
 874 {
 875     return av->array[n].arg;
 876 }
 877
 878 PerlIO_funcs *
 879 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
 880 {
 881     if (n >= 0 && n < av->cur) {
 882         PerlIO_debug("Layer %" IVdf " is %s\n", n,
 883                      av->array[n].funcs->name);
 884         return av->array[n].funcs;
 885     }
 886     if (!def)
 887         Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
 888     return def;
 889 }
 890
 891 PerlIO_list_t *
 892 PerlIO_default_layers(pTHX)
 893 {
 894     if (!PL_def_layerlist) {
 895         const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
 896         PerlIO_funcs *osLayer = &PerlIO_unix;
 897         PL_def_layerlist = PerlIO_list_alloc(aTHX);
 898         PerlIO_define_layer(aTHX_ & PerlIO_unix);
 899 #if defined(WIN32) && !defined(UNDER_CE)
 900         PerlIO_define_layer(aTHX_ & PerlIO_win32);
 901 #if 0
 902         osLayer = &PerlIO_win32;
 903 #endif
 904 #endif
 905         PerlIO_define_layer(aTHX_ & PerlIO_raw);
 906         PerlIO_define_layer(aTHX_ & PerlIO_perlio);
 907         PerlIO_define_layer(aTHX_ & PerlIO_stdio);
 908         PerlIO_define_layer(aTHX_ & PerlIO_crlf);
 909 #ifdef HAS_MMAP
 910         PerlIO_define_layer(aTHX_ & PerlIO_mmap);
 911 #endif
 912         PerlIO_define_layer(aTHX_ & PerlIO_utf8);
 913         PerlIO_define_layer(aTHX_ & PerlIO_byte);
 914         PerlIO_list_push(aTHX_ PL_def_layerlist,
 915                          PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
 916                          &PL_sv_undef);
 917         if (s) {
 918             PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
 919         }
 920         else {
 921             PerlIO_default_buffer(aTHX_ PL_def_layerlist);
 922         }
 923     }
 924     if (PL_def_layerlist->cur < 2) {
 925         PerlIO_default_buffer(aTHX_ PL_def_layerlist);
 926     }
 927     return PL_def_layerlist;
 928 }
 929
 930 void
 931 Perl_boot_core_PerlIO(pTHX)
 932 {
 933 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 934     newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
 935           __FILE__);
 936 #endif
 937     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
 938 }
 939
 940 PerlIO_funcs *
 941 PerlIO_default_layer(pTHX_ I32 n)
 942 {
 943     PerlIO_list_t *av = PerlIO_default_layers(aTHX);
 944     if (n < 0)
 945         n += av->cur;
 946     return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
 947 }
 948
 949 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
 950 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
 951
 952 void
 953 PerlIO_stdstreams(pTHX)
 954 {
 955     if (!PL_perlio) {
 956         PerlIO_allocate(aTHX);
 957         PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
 958         PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
 959         PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
 960     }
 961 }
 962
 963 PerlIO *
 964 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
 965 {
 966     PerlIOl *l = NULL;
 967     Newc('L',l,tab->size,char,PerlIOl);
 968     if (l) {
 969         Zero(l, tab->size, char);
 970         l->next = *f;
 971         l->tab = tab;
 972         *f = l;
 973         PerlIO_debug("PerlIO_push f=%p %s %s %p\n", f, tab->name,
 974                      (mode) ? mode : "(Null)", arg);
 975         if ((*l->tab->Pushed) (f, mode, arg) != 0) {
 976             PerlIO_pop(aTHX_ f);
 977             return NULL;
 978         }
 979     }
 980     return f;
 981 }
 982
 983 IV
 984 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
 985 {
 986     dTHX;
 987     PerlIO_pop(aTHX_ f);
 988     if (*f) {
 989         PerlIO_flush(f);
 990         PerlIO_pop(aTHX_ f);
 991         return 0;
 992     }
 993     return -1;
 994 }
 995
 996 IV
 997 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
 998 {
 999     /*
1000      * Remove the dummy layer
1001      */
1002     dTHX;
1003     PerlIO_pop(aTHX_ f);
1004     /*
1005      * Pop back to bottom layer
1006      */
1007     if (f && *f) {
1008         PerlIO_flush(f);
1009         while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
1010             if (*PerlIONext(f)) {
1011                 PerlIO_pop(aTHX_ f);
1012             }
1013             else {
1014                 /*
1015                  * Nothing bellow - push unix on top then remove it
1016                  */
1017                 if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
1018                     PerlIO_pop(aTHX_ PerlIONext(f));
1019                 }
1020                 break;
1021             }
1022         }
1023         PerlIO_debug(":raw f=%p :%s\n", f, PerlIOBase(f)->tab->name);
1024         return 0;
1025     }
1026     return -1;
1027 }
1028
1029 int
1030 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1031                     PerlIO_list_t *layers, IV n)
1032 {
1033     IV max = layers->cur;
1034     int code = 0;
1035     while (n < max) {
1036         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1037         if (tab) {
1038             if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1039                 code = -1;
1040                 break;
1041             }
1042         }
1043         n++;
1044     }
1045     return code;
1046 }
1047
1048 int
1049 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1050 {
1051     int code = 0;
1052     if (names) {
1053         PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1054         code = PerlIO_parse_layers(aTHX_ layers, names);
1055         if (code == 0) {
1056             code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
1057         }
1058         PerlIO_list_free(aTHX_ layers);
1059     }
1060     return code;
1061 }
1062
1063
1064 /*--------------------------------------------------------------------------------------*/
1065 /*
1066  * Given the abstraction above the public API functions
1067  */
1068
1069 int
1070 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1071 {
1072     PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1073                  f, PerlIOBase(f)->tab->name, iotype, mode,
1074                  (names) ? names : "(Null)");
1075     /* 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) (&l) : &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)
1980 {
1981     PerlIO *nexto = PerlIONext(o);
1982     if (*nexto) {
1983         PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
1984         f = (*tab->Dup)(aTHX_ f, nexto, param);
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)(o);
1993             if (arg) {
1994                 arg = PerlIO_sv_dup(aTHX_ arg, param);
1995             }
1996         }
1997         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
1998         if (!f && arg) {
1999             SvREFCNT_dec(arg);
2000         }
2001     }
2002     return f;
2003 }
2004
2005 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2006 #ifdef USE_THREADS
2007 perl_mutex PerlIO_mutex;
2008 #endif
2009 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2010
2011 void
2012 PerlIO_init(pTHX)
2013 {
2014  /* Place holder for stdstreams call ??? */
2015 #ifdef USE_THREADS
2016  MUTEX_INIT(&PerlIO_mutex);
2017 #endif
2018 }
2019
2020 void
2021 PerlIOUnix_refcnt_inc(int fd)
2022 {
2023     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2024 #ifdef USE_THREADS
2025         MUTEX_LOCK(&PerlIO_mutex);
2026 #endif
2027         PerlIO_fd_refcnt[fd]++;
2028         PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2029 #ifdef USE_THREADS
2030         MUTEX_UNLOCK(&PerlIO_mutex);
2031 #endif
2032     }
2033 }
2034
2035 int
2036 PerlIOUnix_refcnt_dec(int fd)
2037 {
2038     int cnt = 0;
2039     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2040 #ifdef USE_THREADS
2041         MUTEX_LOCK(&PerlIO_mutex);
2042 #endif
2043         cnt = --PerlIO_fd_refcnt[fd];
2044         PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2045 #ifdef USE_THREADS
2046         MUTEX_UNLOCK(&PerlIO_mutex);
2047 #endif
2048     }
2049     return cnt;
2050 }
2051
2052 void
2053 PerlIO_cleanup(pTHX)
2054 {
2055     int i;
2056 #ifdef USE_ITHREADS
2057     PerlIO_debug("Cleanup %p\n",aTHX);
2058 #endif
2059     /* Raise STDIN..STDERR refcount so we don't close them */
2060     for (i=0; i < 3; i++)
2061         PerlIOUnix_refcnt_inc(i);
2062     PerlIO_cleantable(aTHX_ &PL_perlio);
2063     /* Restore STDIN..STDERR refcount */
2064     for (i=0; i < 3; i++)
2065         PerlIOUnix_refcnt_dec(i);
2066 }
2067
2068
2069
2070 /*--------------------------------------------------------------------------------------*/
2071 /*
2072  * Bottom-most level for UNIX-like case
2073  */
2074
2075 typedef struct {
2076     struct _PerlIO base;        /* The generic part */
2077     int fd;                     /* UNIX like file descriptor */
2078     int oflags;                 /* open/fcntl flags */
2079 } PerlIOUnix;
2080
2081 int
2082 PerlIOUnix_oflags(const char *mode)
2083 {
2084     int oflags = -1;
2085     if (*mode == 'I' || *mode == '#')
2086         mode++;
2087     switch (*mode) {
2088     case 'r':
2089         oflags = O_RDONLY;
2090         if (*++mode == '+') {
2091             oflags = O_RDWR;
2092             mode++;
2093         }
2094         break;
2095
2096     case 'w':
2097         oflags = O_CREAT | O_TRUNC;
2098         if (*++mode == '+') {
2099             oflags |= O_RDWR;
2100             mode++;
2101         }
2102         else
2103             oflags |= O_WRONLY;
2104         break;
2105
2106     case 'a':
2107         oflags = O_CREAT | O_APPEND;
2108         if (*++mode == '+') {
2109             oflags |= O_RDWR;
2110             mode++;
2111         }
2112         else
2113             oflags |= O_WRONLY;
2114         break;
2115     }
2116     if (*mode == 'b') {
2117         oflags |= O_BINARY;
2118         oflags &= ~O_TEXT;
2119         mode++;
2120     }
2121     else if (*mode == 't') {
2122         oflags |= O_TEXT;
2123         oflags &= ~O_BINARY;
2124         mode++;
2125     }
2126     /*
2127      * Always open in binary mode
2128      */
2129     oflags |= O_BINARY;
2130     if (*mode || oflags == -1) {
2131         SETERRNO(EINVAL, LIB$_INVARG);
2132         oflags = -1;
2133     }
2134     return oflags;
2135 }
2136
2137 IV
2138 PerlIOUnix_fileno(PerlIO *f)
2139 {
2140     return PerlIOSelf(f, PerlIOUnix)->fd;
2141 }
2142
2143 IV
2144 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
2145 {
2146     IV code = PerlIOBase_pushed(f, mode, arg);
2147     PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2148     if (*PerlIONext(f)) {
2149         s->fd = PerlIO_fileno(PerlIONext(f));
2150         /*
2151          * XXX could (or should) we retrieve the oflags from the open file
2152          * handle rather than believing the "mode" we are passed in? XXX
2153          * Should the value on NULL mode be 0 or -1?
2154          */
2155         s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2156     }
2157     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2158     return code;
2159 }
2160
2161 PerlIO *
2162 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2163                 IV n, const char *mode, int fd, int imode,
2164                 int perm, PerlIO *f, int narg, SV **args)
2165 {
2166     if (f) {
2167         if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2168             (*PerlIOBase(f)->tab->Close) (f);
2169     }
2170     if (narg > 0) {
2171         char *path = SvPV_nolen(*args);
2172         if (*mode == '#')
2173             mode++;
2174         else {
2175             imode = PerlIOUnix_oflags(mode);
2176             perm = 0666;
2177         }
2178         if (imode != -1) {
2179             fd = PerlLIO_open3(path, imode, perm);
2180         }
2181     }
2182     if (fd >= 0) {
2183         PerlIOUnix *s;
2184         if (*mode == 'I')
2185             mode++;
2186         if (!f) {
2187             f = PerlIO_allocate(aTHX);
2188             s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
2189                            PerlIOUnix);
2190         }
2191         else
2192             s = PerlIOSelf(f, PerlIOUnix);
2193         s->fd = fd;
2194         s->oflags = imode;
2195         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2196         PerlIOUnix_refcnt_inc(fd);
2197         return f;
2198     }
2199     else {
2200         if (f) {
2201             /*
2202              * FIXME: pop layers ???
2203              */
2204         }
2205         return NULL;
2206     }
2207 }
2208
2209 PerlIO *
2210 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
2211 {
2212     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2213     int fd = os->fd;
2214     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2215         f = PerlIOBase_dup(aTHX_ f, o, param);
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)
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))) {
2494         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2495         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2496         PerlIOUnix_refcnt_inc(fileno(stdio));
2497     }
2498     return f;
2499 }
2500
2501 IV
2502 PerlIOStdio_close(PerlIO *f)
2503 {
2504     dSYS;
2505 #ifdef SOCKS5_VERSION_NAME
2506     int optval;
2507     Sock_size_t optlen = sizeof(int);
2508 #endif
2509     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2510     if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2511         /* Do not close it but do flush any buffers */
2512         PerlIO_flush(f);
2513         return 0;
2514     }
2515     return (
2516 #ifdef SOCKS5_VERSION_NAME
2517                (getsockopt
2518                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2519                  &optlen) <
2520                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2521 #else
2522                PerlSIO_fclose(stdio)
2523 #endif
2524         );
2525
2526 }
2527
2528
2529
2530 SSize_t
2531 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2532 {
2533     dSYS;
2534     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2535     SSize_t got = 0;
2536     if (count == 1) {
2537         STDCHAR *buf = (STDCHAR *) vbuf;
2538         /*
2539          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2540          * stdio does not do that for fread()
2541          */
2542         int ch = PerlSIO_fgetc(s);
2543         if (ch != EOF) {
2544             *buf = ch;
2545             got = 1;
2546         }
2547     }
2548     else
2549         got = PerlSIO_fread(vbuf, 1, count, s);
2550     return got;
2551 }
2552
2553 SSize_t
2554 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2555 {
2556     dSYS;
2557     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2558     STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2559     SSize_t unread = 0;
2560     while (count > 0) {
2561         int ch = *buf-- & 0xff;
2562         if (PerlSIO_ungetc(ch, s) != ch)
2563             break;
2564         unread++;
2565         count--;
2566     }
2567     return unread;
2568 }
2569
2570 SSize_t
2571 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2572 {
2573     dSYS;
2574     return PerlSIO_fwrite(vbuf, 1, count,
2575                           PerlIOSelf(f, PerlIOStdio)->stdio);
2576 }
2577
2578 IV
2579 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2580 {
2581     dSYS;
2582     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2583     return PerlSIO_fseek(stdio, offset, whence);
2584 }
2585
2586 Off_t
2587 PerlIOStdio_tell(PerlIO *f)
2588 {
2589     dSYS;
2590     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2591     return PerlSIO_ftell(stdio);
2592 }
2593
2594 IV
2595 PerlIOStdio_flush(PerlIO *f)
2596 {
2597     dSYS;
2598     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2599     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2600         return PerlSIO_fflush(stdio);
2601     }
2602     else {
2603 #if 0
2604         /*
2605          * FIXME: This discards ungetc() and pre-read stuff which is not
2606          * right if this is just a "sync" from a layer above Suspect right
2607          * design is to do _this_ but not have layer above flush this
2608          * layer read-to-read
2609          */
2610         /*
2611          * Not writeable - sync by attempting a seek
2612          */
2613         int err = errno;
2614         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2615             errno = err;
2616 #endif
2617     }
2618     return 0;
2619 }
2620
2621 IV
2622 PerlIOStdio_fill(PerlIO *f)
2623 {
2624     dSYS;
2625     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2626     int c;
2627     /*
2628      * fflush()ing read-only streams can cause trouble on some stdio-s
2629      */
2630     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2631         if (PerlSIO_fflush(stdio) != 0)
2632             return EOF;
2633     }
2634     c = PerlSIO_fgetc(stdio);
2635     if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2636         return EOF;
2637     return 0;
2638 }
2639
2640 IV
2641 PerlIOStdio_eof(PerlIO *f)
2642 {
2643     dSYS;
2644     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2645 }
2646
2647 IV
2648 PerlIOStdio_error(PerlIO *f)
2649 {
2650     dSYS;
2651     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2652 }
2653
2654 void
2655 PerlIOStdio_clearerr(PerlIO *f)
2656 {
2657     dSYS;
2658     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2659 }
2660
2661 void
2662 PerlIOStdio_setlinebuf(PerlIO *f)
2663 {
2664     dSYS;
2665 #ifdef HAS_SETLINEBUF
2666     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2667 #else
2668     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2669 #endif
2670 }
2671
2672 #ifdef FILE_base
2673 STDCHAR *
2674 PerlIOStdio_get_base(PerlIO *f)
2675 {
2676     dSYS;
2677     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2678     return PerlSIO_get_base(stdio);
2679 }
2680
2681 Size_t
2682 PerlIOStdio_get_bufsiz(PerlIO *f)
2683 {
2684     dSYS;
2685     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2686     return PerlSIO_get_bufsiz(stdio);
2687 }
2688 #endif
2689
2690 #ifdef USE_STDIO_PTR
2691 STDCHAR *
2692 PerlIOStdio_get_ptr(PerlIO *f)
2693 {
2694     dSYS;
2695     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2696     return PerlSIO_get_ptr(stdio);
2697 }
2698
2699 SSize_t
2700 PerlIOStdio_get_cnt(PerlIO *f)
2701 {
2702     dSYS;
2703     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2704     return PerlSIO_get_cnt(stdio);
2705 }
2706
2707 void
2708 PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2709 {
2710     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2711     dSYS;
2712     if (ptr != NULL) {
2713 #ifdef STDIO_PTR_LVALUE
2714         PerlSIO_set_ptr(stdio, ptr);
2715 #ifdef STDIO_PTR_LVAL_SETS_CNT
2716         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2717             dTHX;
2718             assert(PerlSIO_get_cnt(stdio) == (cnt));
2719         }
2720 #endif
2721 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2722         /*
2723          * Setting ptr _does_ change cnt - we are done
2724          */
2725         return;
2726 #endif
2727 #else                           /* STDIO_PTR_LVALUE */
2728         PerlProc_abort();
2729 #endif                          /* STDIO_PTR_LVALUE */
2730     }
2731     /*
2732      * Now (or only) set cnt
2733      */
2734 #ifdef STDIO_CNT_LVALUE
2735     PerlSIO_set_cnt(stdio, cnt);
2736 #else                           /* STDIO_CNT_LVALUE */
2737 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2738     PerlSIO_set_ptr(stdio,
2739                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2740                                               cnt));
2741 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2742     PerlProc_abort();
2743 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2744 #endif                          /* STDIO_CNT_LVALUE */
2745 }
2746
2747 #endif
2748
2749 PerlIO_funcs PerlIO_stdio = {
2750     "stdio",
2751     sizeof(PerlIOStdio),
2752     PERLIO_K_BUFFERED,
2753     PerlIOBase_pushed,
2754     PerlIOBase_noop_ok,
2755     PerlIOStdio_open,
2756     NULL,
2757     PerlIOStdio_fileno,
2758     PerlIOStdio_dup,
2759     PerlIOStdio_read,
2760     PerlIOStdio_unread,
2761     PerlIOStdio_write,
2762     PerlIOStdio_seek,
2763     PerlIOStdio_tell,
2764     PerlIOStdio_close,
2765     PerlIOStdio_flush,
2766     PerlIOStdio_fill,
2767     PerlIOStdio_eof,
2768     PerlIOStdio_error,
2769     PerlIOStdio_clearerr,
2770     PerlIOStdio_setlinebuf,
2771 #ifdef FILE_base
2772     PerlIOStdio_get_base,
2773     PerlIOStdio_get_bufsiz,
2774 #else
2775     NULL,
2776     NULL,
2777 #endif
2778 #ifdef USE_STDIO_PTR
2779     PerlIOStdio_get_ptr,
2780     PerlIOStdio_get_cnt,
2781 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2782     PerlIOStdio_set_ptrcnt
2783 #else                           /* STDIO_PTR_LVALUE */
2784     NULL
2785 #endif                          /* STDIO_PTR_LVALUE */
2786 #else                           /* USE_STDIO_PTR */
2787     NULL,
2788     NULL,
2789     NULL
2790 #endif                          /* USE_STDIO_PTR */
2791 };
2792
2793 #undef PerlIO_exportFILE
2794 FILE *
2795 PerlIO_exportFILE(PerlIO *f, int fl)
2796 {
2797     FILE *stdio;
2798     PerlIO_flush(f);
2799     stdio = fdopen(PerlIO_fileno(f), "r+");
2800     if (stdio) {
2801         dTHX;
2802         PerlIOStdio *s =
2803             PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2804                        PerlIOStdio);
2805         s->stdio = stdio;
2806     }
2807     return stdio;
2808 }
2809
2810 #undef PerlIO_findFILE
2811 FILE *
2812 PerlIO_findFILE(PerlIO *f)
2813 {
2814     PerlIOl *l = *f;
2815     while (l) {
2816         if (l->tab == &PerlIO_stdio) {
2817             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2818             return s->stdio;
2819         }
2820         l = *PerlIONext(&l);
2821     }
2822     return PerlIO_exportFILE(f, 0);
2823 }
2824
2825 #undef PerlIO_releaseFILE
2826 void
2827 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2828 {
2829 }
2830
2831 /*--------------------------------------------------------------------------------------*/
2832 /*
2833  * perlio buffer layer
2834  */
2835
2836 IV
2837 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2838 {
2839     dSYS;
2840     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2841     int fd = PerlIO_fileno(f);
2842     Off_t posn;
2843     if (fd >= 0 && PerlLIO_isatty(fd)) {
2844         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2845     }
2846     posn = PerlIO_tell(PerlIONext(f));
2847     if (posn != (Off_t) - 1) {
2848         b->posn = posn;
2849     }
2850     return PerlIOBase_pushed(f, mode, arg);
2851 }
2852
2853 PerlIO *
2854 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2855                IV n, const char *mode, int fd, int imode, int perm,
2856                PerlIO *f, int narg, SV **args)
2857 {
2858     if (f) {
2859         PerlIO *next = PerlIONext(f);
2860         PerlIO_funcs *tab =
2861             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2862         next =
2863             (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2864                           next, narg, args);
2865         if (!next
2866             || (*PerlIOBase(f)->tab->Pushed) (f, mode, PerlIOArg) != 0) {
2867             return NULL;
2868         }
2869     }
2870     else {
2871         PerlIO_funcs *tab =
2872             PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2873         int init = 0;
2874         if (*mode == 'I') {
2875             init = 1;
2876             /*
2877              * mode++;
2878              */
2879         }
2880         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2881                           NULL, narg, args);
2882         if (f) {
2883             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
2884                 /*
2885                  * if push fails during open, open fails. close will pop us.
2886                  */
2887                 PerlIO_close (f);
2888                 return NULL;
2889             } else {
2890                 fd = PerlIO_fileno(f);
2891 #if (O_BINARY != O_TEXT) && !defined(__BEOS__)
2892                 /*
2893                  * do something about failing setmode()? --jhi
2894                  */
2895                 PerlLIO_setmode(fd, O_BINARY);
2896 #endif
2897                 if (init && fd == 2) {
2898                     /*
2899                      * Initial stderr is unbuffered
2900                      */
2901                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2902                 }
2903             }
2904         }
2905     }
2906     return f;
2907 }
2908
2909 /*
2910  * This "flush" is akin to sfio's sync in that it handles files in either
2911  * read or write state
2912  */
2913 IV
2914 PerlIOBuf_flush(PerlIO *f)
2915 {
2916     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2917     int code = 0;
2918     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2919         /*
2920          * write() the buffer
2921          */
2922         STDCHAR *buf = b->buf;
2923         STDCHAR *p = buf;
2924         PerlIO *n = PerlIONext(f);
2925         while (p < b->ptr) {
2926             SSize_t count = PerlIO_write(n, p, b->ptr - p);
2927             if (count > 0) {
2928                 p += count;
2929             }
2930             else if (count < 0 || PerlIO_error(n)) {
2931                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2932                 code = -1;
2933                 break;
2934             }
2935         }
2936         b->posn += (p - buf);
2937     }
2938     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2939         STDCHAR *buf = PerlIO_get_base(f);
2940         /*
2941          * Note position change
2942          */
2943         b->posn += (b->ptr - buf);
2944         if (b->ptr < b->end) {
2945             /*
2946              * We did not consume all of it
2947              */
2948             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
2949                 b->posn = PerlIO_tell(PerlIONext(f));
2950             }
2951         }
2952     }
2953     b->ptr = b->end = b->buf;
2954     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2955     /*
2956      * FIXME: Is this right for read case ?
2957      */
2958     if (PerlIO_flush(PerlIONext(f)) != 0)
2959         code = -1;
2960     return code;
2961 }
2962
2963 IV
2964 PerlIOBuf_fill(PerlIO *f)
2965 {
2966     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2967     PerlIO *n = PerlIONext(f);
2968     SSize_t avail;
2969     /*
2970      * FIXME: doing the down-stream flush is a bad idea if it causes
2971      * pre-read data in stdio buffer to be discarded but this is too
2972      * simplistic - as it skips _our_ hosekeeping and breaks tell tests.
2973      * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
2974      */
2975     if (PerlIO_flush(f) != 0)
2976         return -1;
2977     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2978         PerlIOBase_flush_linebuf();
2979
2980     if (!b->buf)
2981         PerlIO_get_base(f);     /* allocate via vtable */
2982
2983     b->ptr = b->end = b->buf;
2984     if (PerlIO_fast_gets(n)) {
2985         /*
2986          * Layer below is also buffered We do _NOT_ want to call its
2987          * ->Read() because that will loop till it gets what we asked for
2988          * which may hang on a pipe etc. Instead take anything it has to
2989          * hand, or ask it to fill _once_.
2990          */
2991         avail = PerlIO_get_cnt(n);
2992         if (avail <= 0) {
2993             avail = PerlIO_fill(n);
2994             if (avail == 0)
2995                 avail = PerlIO_get_cnt(n);
2996             else {
2997                 if (!PerlIO_error(n) && PerlIO_eof(n))
2998                     avail = 0;
2999             }
3000         }
3001         if (avail > 0) {
3002             STDCHAR *ptr = PerlIO_get_ptr(n);
3003             SSize_t cnt = avail;
3004             if (avail > b->bufsiz)
3005                 avail = b->bufsiz;
3006             Copy(ptr, b->buf, avail, STDCHAR);
3007             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3008         }
3009     }
3010     else {
3011         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3012     }
3013     if (avail <= 0) {
3014         if (avail == 0)
3015             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3016         else
3017             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3018         return -1;
3019     }
3020     b->end = b->buf + avail;
3021     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3022     return 0;
3023 }
3024
3025 SSize_t
3026 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
3027 {
3028     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3029     if (f) {
3030         if (!b->ptr)
3031             PerlIO_get_base(f);
3032         return PerlIOBase_read(f, vbuf, count);
3033     }
3034     return 0;
3035 }
3036
3037 SSize_t
3038 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
3039 {
3040     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3041     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3042     SSize_t unread = 0;
3043     SSize_t avail;
3044     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3045         PerlIO_flush(f);
3046     if (!b->buf)
3047         PerlIO_get_base(f);
3048     if (b->buf) {
3049         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3050             /*
3051              * Buffer is already a read buffer, we can overwrite any chars
3052              * which have been read back to buffer start
3053              */
3054             avail = (b->ptr - b->buf);
3055         }
3056         else {
3057             /*
3058              * Buffer is idle, set it up so whole buffer is available for
3059              * unread
3060              */
3061             avail = b->bufsiz;
3062             b->end = b->buf + avail;
3063             b->ptr = b->end;
3064             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3065             /*
3066              * Buffer extends _back_ from where we are now
3067              */
3068             b->posn -= b->bufsiz;
3069         }
3070         if (avail > (SSize_t) count) {
3071             /*
3072              * If we have space for more than count, just move count
3073              */
3074             avail = count;
3075         }
3076         if (avail > 0) {
3077             b->ptr -= avail;
3078             buf -= avail;
3079             /*
3080              * In simple stdio-like ungetc() case chars will be already
3081              * there
3082              */
3083             if (buf != b->ptr) {
3084                 Copy(buf, b->ptr, avail, STDCHAR);
3085             }
3086             count -= avail;
3087             unread += avail;
3088             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3089         }
3090     }
3091     return unread;
3092 }
3093
3094 SSize_t
3095 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
3096 {
3097     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3098     const STDCHAR *buf = (const STDCHAR *) vbuf;
3099     Size_t written = 0;
3100     if (!b->buf)
3101         PerlIO_get_base(f);
3102     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3103         return 0;
3104     while (count > 0) {
3105         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3106         if ((SSize_t) count < avail)
3107             avail = count;
3108         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3109         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3110             while (avail > 0) {
3111                 int ch = *buf++;
3112                 *(b->ptr)++ = ch;
3113                 count--;
3114                 avail--;
3115                 written++;
3116                 if (ch == '\n') {
3117                     PerlIO_flush(f);
3118                     break;
3119                 }
3120             }
3121         }
3122         else {
3123             if (avail) {
3124                 Copy(buf, b->ptr, avail, STDCHAR);
3125                 count -= avail;
3126                 buf += avail;
3127                 written += avail;
3128                 b->ptr += avail;
3129             }
3130         }
3131         if (b->ptr >= (b->buf + b->bufsiz))
3132             PerlIO_flush(f);
3133     }
3134     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3135         PerlIO_flush(f);
3136     return written;
3137 }
3138
3139 IV
3140 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
3141 {
3142     IV code;
3143     if ((code = PerlIO_flush(f)) == 0) {
3144         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3145         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3146         code = PerlIO_seek(PerlIONext(f), offset, whence);
3147         if (code == 0) {
3148             b->posn = PerlIO_tell(PerlIONext(f));
3149         }
3150     }
3151     return code;
3152 }
3153
3154 Off_t
3155 PerlIOBuf_tell(PerlIO *f)
3156 {
3157     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3158     /*
3159      * b->posn is file position where b->buf was read, or will be written
3160      */
3161     Off_t posn = b->posn;
3162     if (b->buf) {
3163         /*
3164          * If buffer is valid adjust position by amount in buffer
3165          */
3166         posn += (b->ptr - b->buf);
3167     }
3168     return posn;
3169 }
3170
3171 IV
3172 PerlIOBuf_close(PerlIO *f)
3173 {
3174     IV code = PerlIOBase_close(f);
3175     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3176     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3177         Safefree(b->buf);
3178     }
3179     b->buf = NULL;
3180     b->ptr = b->end = b->buf;
3181     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3182     return code;
3183 }
3184
3185 STDCHAR *
3186 PerlIOBuf_get_ptr(PerlIO *f)
3187 {
3188     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3189     if (!b->buf)
3190         PerlIO_get_base(f);
3191     return b->ptr;
3192 }
3193
3194 SSize_t
3195 PerlIOBuf_get_cnt(PerlIO *f)
3196 {
3197     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3198     if (!b->buf)
3199         PerlIO_get_base(f);
3200     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3201         return (b->end - b->ptr);
3202     return 0;
3203 }
3204
3205 STDCHAR *
3206 PerlIOBuf_get_base(PerlIO *f)
3207 {
3208     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3209     if (!b->buf) {
3210         if (!b->bufsiz)
3211             b->bufsiz = 4096;
3212         b->buf =
3213         Newz('B',b->buf,b->bufsiz, STDCHAR);
3214         if (!b->buf) {
3215             b->buf = (STDCHAR *) & b->oneword;
3216             b->bufsiz = sizeof(b->oneword);
3217         }
3218         b->ptr = b->buf;
3219         b->end = b->ptr;
3220     }
3221     return b->buf;
3222 }
3223
3224 Size_t
3225 PerlIOBuf_bufsiz(PerlIO *f)
3226 {
3227     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3228     if (!b->buf)
3229         PerlIO_get_base(f);
3230     return (b->end - b->buf);
3231 }
3232
3233 void
3234 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3235 {
3236     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3237     if (!b->buf)
3238         PerlIO_get_base(f);
3239     b->ptr = ptr;
3240     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3241         dTHX;
3242         assert(PerlIO_get_cnt(f) == cnt);
3243         assert(b->ptr >= b->buf);
3244     }
3245     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3246 }
3247
3248 PerlIO *
3249 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
3250 {
3251  return PerlIOBase_dup(aTHX_ f, o, param);
3252 }
3253
3254
3255
3256 PerlIO_funcs PerlIO_perlio = {
3257     "perlio",
3258     sizeof(PerlIOBuf),
3259     PERLIO_K_BUFFERED,
3260     PerlIOBuf_pushed,
3261     PerlIOBase_noop_ok,
3262     PerlIOBuf_open,
3263     NULL,
3264     PerlIOBase_fileno,
3265     PerlIOBuf_dup,
3266     PerlIOBuf_read,
3267     PerlIOBuf_unread,
3268     PerlIOBuf_write,
3269     PerlIOBuf_seek,
3270     PerlIOBuf_tell,
3271     PerlIOBuf_close,
3272     PerlIOBuf_flush,
3273     PerlIOBuf_fill,
3274     PerlIOBase_eof,
3275     PerlIOBase_error,
3276     PerlIOBase_clearerr,
3277     PerlIOBase_setlinebuf,
3278     PerlIOBuf_get_base,
3279     PerlIOBuf_bufsiz,
3280     PerlIOBuf_get_ptr,
3281     PerlIOBuf_get_cnt,
3282     PerlIOBuf_set_ptrcnt,
3283 };
3284
3285 /*--------------------------------------------------------------------------------------*/
3286 /*
3287  * Temp layer to hold unread chars when cannot do it any other way
3288  */
3289
3290 IV
3291 PerlIOPending_fill(PerlIO *f)
3292 {
3293     /*
3294      * Should never happen
3295      */
3296     PerlIO_flush(f);
3297     return 0;
3298 }
3299
3300 IV
3301 PerlIOPending_close(PerlIO *f)
3302 {
3303     /*
3304      * A tad tricky - flush pops us, then we close new top
3305      */
3306     PerlIO_flush(f);
3307     return PerlIO_close(f);
3308 }
3309
3310 IV
3311 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3312 {
3313     /*
3314      * A tad tricky - flush pops us, then we seek new top
3315      */
3316     PerlIO_flush(f);
3317     return PerlIO_seek(f, offset, whence);
3318 }
3319
3320
3321 IV
3322 PerlIOPending_flush(PerlIO *f)
3323 {
3324     dTHX;
3325     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3326     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3327         Safefree(b->buf);
3328         b->buf = NULL;
3329     }
3330     PerlIO_pop(aTHX_ f);
3331     return 0;
3332 }
3333
3334 void
3335 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3336 {
3337     if (cnt <= 0) {
3338         PerlIO_flush(f);
3339     }
3340     else {
3341         PerlIOBuf_set_ptrcnt(f, ptr, cnt);
3342     }
3343 }
3344
3345 IV
3346 PerlIOPending_pushed(PerlIO *f, const char *mode, SV *arg)
3347 {
3348     IV code = PerlIOBase_pushed(f, mode, arg);
3349     PerlIOl *l = PerlIOBase(f);
3350     /*
3351      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3352      * etc. get muddled when it changes mid-string when we auto-pop.
3353      */
3354     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3355         (PerlIOBase(PerlIONext(f))->
3356          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3357     return code;
3358 }
3359
3360 SSize_t
3361 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3362 {
3363     SSize_t avail = PerlIO_get_cnt(f);
3364     SSize_t got = 0;
3365     if (count < avail)
3366         avail = count;
3367     if (avail > 0)
3368         got = PerlIOBuf_read(f, vbuf, avail);
3369     if (got >= 0 && got < count) {
3370         SSize_t more =
3371             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3372         if (more >= 0 || got == 0)
3373             got += more;
3374     }
3375     return got;
3376 }
3377
3378 PerlIO_funcs PerlIO_pending = {
3379     "pending",
3380     sizeof(PerlIOBuf),
3381     PERLIO_K_BUFFERED,
3382     PerlIOPending_pushed,
3383     PerlIOBase_noop_ok,
3384     NULL,
3385     NULL,
3386     PerlIOBase_fileno,
3387     PerlIOBuf_dup,
3388     PerlIOPending_read,
3389     PerlIOBuf_unread,
3390     PerlIOBuf_write,
3391     PerlIOPending_seek,
3392     PerlIOBuf_tell,
3393     PerlIOPending_close,
3394     PerlIOPending_flush,
3395     PerlIOPending_fill,
3396     PerlIOBase_eof,
3397     PerlIOBase_error,
3398     PerlIOBase_clearerr,
3399     PerlIOBase_setlinebuf,
3400     PerlIOBuf_get_base,
3401     PerlIOBuf_bufsiz,
3402     PerlIOBuf_get_ptr,
3403     PerlIOBuf_get_cnt,
3404     PerlIOPending_set_ptrcnt,
3405 };
3406
3407
3408
3409 /*--------------------------------------------------------------------------------------*/
3410 /*
3411  * crlf - translation On read translate CR,LF to "\n" we do this by
3412  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3413  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3414  */
3415
3416 typedef struct {
3417     PerlIOBuf base;             /* PerlIOBuf stuff */
3418     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3419                                  * buffer */
3420 } PerlIOCrlf;
3421
3422 IV
3423 PerlIOCrlf_pushed(PerlIO *f, const char *mode, SV *arg)
3424 {
3425     IV code;
3426     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3427     code = PerlIOBuf_pushed(f, mode, arg);
3428 #if 0
3429     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3430                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3431                  PerlIOBase(f)->flags);
3432 #endif
3433     return code;
3434 }
3435
3436
3437 SSize_t
3438 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3439 {
3440     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3441     if (c->nl) {
3442         *(c->nl) = 0xd;
3443         c->nl = NULL;
3444     }
3445     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3446         return PerlIOBuf_unread(f, vbuf, count);
3447     else {
3448         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3449         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3450         SSize_t unread = 0;
3451         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3452             PerlIO_flush(f);
3453         if (!b->buf)
3454             PerlIO_get_base(f);
3455         if (b->buf) {
3456             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3457                 b->end = b->ptr = b->buf + b->bufsiz;
3458                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3459                 b->posn -= b->bufsiz;
3460             }
3461             while (count > 0 && b->ptr > b->buf) {
3462                 int ch = *--buf;
3463                 if (ch == '\n') {
3464                     if (b->ptr - 2 >= b->buf) {
3465                         *--(b->ptr) = 0xa;
3466                         *--(b->ptr) = 0xd;
3467                         unread++;
3468                         count--;
3469                     }
3470                     else {
3471                         buf++;
3472                         break;
3473                     }
3474                 }
3475                 else {
3476                     *--(b->ptr) = ch;
3477                     unread++;
3478                     count--;
3479                 }
3480             }
3481         }
3482         return unread;
3483     }
3484 }
3485
3486 SSize_t
3487 PerlIOCrlf_get_cnt(PerlIO *f)
3488 {
3489     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3490     if (!b->buf)
3491         PerlIO_get_base(f);
3492     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3493         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3494         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) {
3495             STDCHAR *nl = b->ptr;
3496           scan:
3497             while (nl < b->end && *nl != 0xd)
3498                 nl++;
3499             if (nl < b->end && *nl == 0xd) {
3500               test:
3501                 if (nl + 1 < b->end) {
3502                     if (nl[1] == 0xa) {
3503                         *nl = '\n';
3504                         c->nl = nl;
3505                     }
3506                     else {
3507                         /*
3508                          * Not CR,LF but just CR
3509                          */
3510                         nl++;
3511                         goto scan;
3512                     }
3513                 }
3514                 else {
3515                     /*
3516                      * Blast - found CR as last char in buffer
3517                      */
3518                     if (b->ptr < nl) {
3519                         /*
3520                          * They may not care, defer work as long as
3521                          * possible
3522                          */
3523                         return (nl - b->ptr);
3524                     }
3525                     else {
3526                         int code;
3527                         b->ptr++;       /* say we have read it as far as
3528                                          * flush() is concerned */
3529                         b->buf++;       /* Leave space in front of buffer */
3530                         b->bufsiz--;    /* Buffer is thus smaller */
3531                         code = PerlIO_fill(f);  /* Fetch some more */
3532                         b->bufsiz++;    /* Restore size for next time */
3533                         b->buf--;       /* Point at space */
3534                         b->ptr = nl = b->buf;   /* Which is what we hand
3535                                                  * off */
3536                         b->posn--;      /* Buffer starts here */
3537                         *nl = 0xd;      /* Fill in the CR */
3538                         if (code == 0)
3539                             goto test;  /* fill() call worked */
3540                         /*
3541                          * CR at EOF - just fall through
3542                          */
3543                     }
3544                 }
3545             }
3546         }
3547         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3548     }
3549     return 0;
3550 }
3551
3552 void
3553 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3554 {
3555     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3556     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3557     IV flags = PerlIOBase(f)->flags;
3558     if (!b->buf)
3559         PerlIO_get_base(f);
3560     if (!ptr) {
3561         if (c->nl)
3562             ptr = c->nl + 1;
3563         else {
3564             ptr = b->end;
3565             if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3566                 ptr--;
3567         }
3568         ptr -= cnt;
3569     }
3570     else {
3571         /*
3572          * Test code - delete when it works ...
3573          */
3574         STDCHAR *chk;
3575         if (c->nl)
3576             chk = c->nl + 1;
3577         else {
3578             chk = b->end;
3579             if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3580                 chk--;
3581         }
3582         chk -= cnt;
3583
3584         if (ptr != chk) {
3585             dTHX;
3586             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3587                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3588                        b->end, cnt);
3589         }
3590     }
3591     if (c->nl) {
3592         if (ptr > c->nl) {
3593             /*
3594              * They have taken what we lied about
3595              */
3596             *(c->nl) = 0xd;
3597             c->nl = NULL;
3598             ptr++;
3599         }
3600     }
3601     b->ptr = ptr;
3602     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3603 }
3604
3605 SSize_t
3606 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3607 {
3608     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3609         return PerlIOBuf_write(f, vbuf, count);
3610     else {
3611         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3612         const STDCHAR *buf = (const STDCHAR *) vbuf;
3613         const STDCHAR *ebuf = buf + count;
3614         if (!b->buf)
3615             PerlIO_get_base(f);
3616         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3617             return 0;
3618         while (buf < ebuf) {
3619             STDCHAR *eptr = b->buf + b->bufsiz;
3620             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3621             while (buf < ebuf && b->ptr < eptr) {
3622                 if (*buf == '\n') {
3623                     if ((b->ptr + 2) > eptr) {
3624                         /*
3625                          * Not room for both
3626                          */
3627                         PerlIO_flush(f);
3628                         break;
3629                     }
3630                     else {
3631                         *(b->ptr)++ = 0xd;      /* CR */
3632                         *(b->ptr)++ = 0xa;      /* LF */
3633                         buf++;
3634                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3635                             PerlIO_flush(f);
3636                             break;
3637                         }
3638                     }
3639                 }
3640                 else {
3641                     int ch = *buf++;
3642                     *(b->ptr)++ = ch;
3643                 }
3644                 if (b->ptr >= eptr) {
3645                     PerlIO_flush(f);
3646                     break;
3647                 }
3648             }
3649         }
3650         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3651             PerlIO_flush(f);
3652         return (buf - (STDCHAR *) vbuf);
3653     }
3654 }
3655
3656 IV
3657 PerlIOCrlf_flush(PerlIO *f)
3658 {
3659     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3660     if (c->nl) {
3661         *(c->nl) = 0xd;
3662         c->nl = NULL;
3663     }
3664     return PerlIOBuf_flush(f);
3665 }
3666
3667 PerlIO_funcs PerlIO_crlf = {
3668     "crlf",
3669     sizeof(PerlIOCrlf),
3670     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3671     PerlIOCrlf_pushed,
3672     PerlIOBase_noop_ok,         /* popped */
3673     PerlIOBuf_open,
3674     NULL,
3675     PerlIOBase_fileno,
3676     PerlIOBuf_dup,
3677     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3678                                  * ... */
3679     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3680     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3681     PerlIOBuf_seek,
3682     PerlIOBuf_tell,
3683     PerlIOBuf_close,
3684     PerlIOCrlf_flush,
3685     PerlIOBuf_fill,
3686     PerlIOBase_eof,
3687     PerlIOBase_error,
3688     PerlIOBase_clearerr,
3689     PerlIOBase_setlinebuf,
3690     PerlIOBuf_get_base,
3691     PerlIOBuf_bufsiz,
3692     PerlIOBuf_get_ptr,
3693     PerlIOCrlf_get_cnt,
3694     PerlIOCrlf_set_ptrcnt,
3695 };
3696
3697 #ifdef HAS_MMAP
3698 /*--------------------------------------------------------------------------------------*/
3699 /*
3700  * mmap as "buffer" layer
3701  */
3702
3703 typedef struct {
3704     PerlIOBuf base;             /* PerlIOBuf stuff */
3705     Mmap_t mptr;                /* Mapped address */
3706     Size_t len;                 /* mapped length */
3707     STDCHAR *bbuf;              /* malloced buffer if map fails */
3708 } PerlIOMmap;
3709
3710 static size_t page_size = 0;
3711
3712 IV
3713 PerlIOMmap_map(PerlIO *f)
3714 {
3715     dTHX;
3716     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3717     IV flags = PerlIOBase(f)->flags;
3718     IV code = 0;
3719     if (m->len)
3720         abort();
3721     if (flags & PERLIO_F_CANREAD) {
3722         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3723         int fd = PerlIO_fileno(f);
3724         Stat_t st;
3725         code = Fstat(fd, &st);
3726         if (code == 0 && S_ISREG(st.st_mode)) {
3727             SSize_t len = st.st_size - b->posn;
3728             if (len > 0) {
3729                 Off_t posn;
3730                 if (!page_size) {
3731 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3732                     {
3733                         SETERRNO(0, SS$_NORMAL);
3734 #   ifdef _SC_PAGESIZE
3735                         page_size = sysconf(_SC_PAGESIZE);
3736 #   else
3737                         page_size = sysconf(_SC_PAGE_SIZE);
3738 #   endif
3739                         if ((long) page_size < 0) {
3740                             if (errno) {
3741                                 SV *error = ERRSV;
3742                                 char *msg;
3743                                 STRLEN n_a;
3744                                 (void) SvUPGRADE(error, SVt_PV);
3745                                 msg = SvPVx(error, n_a);
3746                                 Perl_croak(aTHX_ "panic: sysconf: %s",
3747                                            msg);
3748                             }
3749                             else
3750                                 Perl_croak(aTHX_
3751                                            "panic: sysconf: pagesize unknown");
3752                         }
3753                     }
3754 #else
3755 #   ifdef HAS_GETPAGESIZE
3756                     page_size = getpagesize();
3757 #   else
3758 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3759                     page_size = PAGESIZE;       /* compiletime, bad */
3760 #       endif
3761 #   endif
3762 #endif
3763                     if ((IV) page_size <= 0)
3764                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3765                                    (IV) page_size);
3766                 }
3767                 if (b->posn < 0) {
3768                     /*
3769                      * This is a hack - should never happen - open should
3770                      * have set it !
3771                      */
3772                     b->posn = PerlIO_tell(PerlIONext(f));
3773                 }
3774                 posn = (b->posn / page_size) * page_size;
3775                 len = st.st_size - posn;
3776                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3777                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3778 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3779                     madvise(m->mptr, len, MADV_SEQUENTIAL);
3780 #endif
3781 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3782                     madvise(m->mptr, len, MADV_WILLNEED);
3783 #endif
3784                     PerlIOBase(f)->flags =
3785                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3786                     b->end = ((STDCHAR *) m->mptr) + len;
3787                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3788                     b->ptr = b->buf;
3789                     m->len = len;
3790                 }
3791                 else {
3792                     b->buf = NULL;
3793                 }
3794             }
3795             else {
3796                 PerlIOBase(f)->flags =
3797                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3798                 b->buf = NULL;
3799                 b->ptr = b->end = b->ptr;
3800                 code = -1;
3801             }
3802         }
3803     }
3804     return code;
3805 }
3806
3807 IV
3808 PerlIOMmap_unmap(PerlIO *f)
3809 {
3810     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3811     PerlIOBuf *b = &m->base;
3812     IV code = 0;
3813     if (m->len) {
3814         if (b->buf) {
3815             code = munmap(m->mptr, m->len);
3816             b->buf = NULL;
3817             m->len = 0;
3818             m->mptr = NULL;
3819             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3820                 code = -1;
3821         }
3822         b->ptr = b->end = b->buf;
3823         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3824     }
3825     return code;
3826 }
3827
3828 STDCHAR *
3829 PerlIOMmap_get_base(PerlIO *f)
3830 {
3831     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3832     PerlIOBuf *b = &m->base;
3833     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3834         /*
3835          * Already have a readbuffer in progress
3836          */
3837         return b->buf;
3838     }
3839     if (b->buf) {
3840         /*
3841          * We have a write buffer or flushed PerlIOBuf read buffer
3842          */
3843         m->bbuf = b->buf;       /* save it in case we need it again */
3844         b->buf = NULL;          /* Clear to trigger below */
3845     }
3846     if (!b->buf) {
3847         PerlIOMmap_map(f);      /* Try and map it */
3848         if (!b->buf) {
3849             /*
3850              * Map did not work - recover PerlIOBuf buffer if we have one
3851              */
3852             b->buf = m->bbuf;
3853         }
3854     }
3855     b->ptr = b->end = b->buf;
3856     if (b->buf)
3857         return b->buf;
3858     return PerlIOBuf_get_base(f);
3859 }
3860
3861 SSize_t
3862 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3863 {
3864     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3865     PerlIOBuf *b = &m->base;
3866     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3867         PerlIO_flush(f);
3868     if (b->ptr && (b->ptr - count) >= b->buf
3869         && memEQ(b->ptr - count, vbuf, count)) {
3870         b->ptr -= count;
3871         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3872         return count;
3873     }
3874     if (m->len) {
3875         /*
3876          * Loose the unwritable mapped buffer
3877          */
3878         PerlIO_flush(f);
3879         /*
3880          * If flush took the "buffer" see if we have one from before
3881          */
3882         if (!b->buf && m->bbuf)
3883             b->buf = m->bbuf;
3884         if (!b->buf) {
3885             PerlIOBuf_get_base(f);
3886             m->bbuf = b->buf;
3887         }
3888     }
3889     return PerlIOBuf_unread(f, vbuf, count);
3890 }
3891
3892 SSize_t
3893 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3894 {
3895     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3896     PerlIOBuf *b = &m->base;
3897     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3898         /*
3899          * No, or wrong sort of, buffer
3900          */
3901         if (m->len) {
3902             if (PerlIOMmap_unmap(f) != 0)
3903                 return 0;
3904         }
3905         /*
3906          * If unmap took the "buffer" see if we have one from before
3907          */
3908         if (!b->buf && m->bbuf)
3909             b->buf = m->bbuf;
3910         if (!b->buf) {
3911             PerlIOBuf_get_base(f);
3912             m->bbuf = b->buf;
3913         }
3914     }
3915     return PerlIOBuf_write(f, vbuf, count);
3916 }
3917
3918 IV
3919 PerlIOMmap_flush(PerlIO *f)
3920 {
3921     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3922     PerlIOBuf *b = &m->base;
3923     IV code = PerlIOBuf_flush(f);
3924     /*
3925      * Now we are "synced" at PerlIOBuf level
3926      */
3927     if (b->buf) {
3928         if (m->len) {
3929             /*
3930              * Unmap the buffer
3931              */
3932             if (PerlIOMmap_unmap(f) != 0)
3933                 code = -1;
3934         }
3935         else {
3936             /*
3937              * We seem to have a PerlIOBuf buffer which was not mapped
3938              * remember it in case we need one later
3939              */
3940             m->bbuf = b->buf;
3941         }
3942     }
3943     return code;
3944 }
3945
3946 IV
3947 PerlIOMmap_fill(PerlIO *f)
3948 {
3949     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3950     IV code = PerlIO_flush(f);
3951     if (code == 0 && !b->buf) {
3952         code = PerlIOMmap_map(f);
3953     }
3954     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3955         code = PerlIOBuf_fill(f);
3956     }
3957     return code;
3958 }
3959
3960 IV
3961 PerlIOMmap_close(PerlIO *f)
3962 {
3963     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3964     PerlIOBuf *b = &m->base;
3965     IV code = PerlIO_flush(f);
3966     if (m->bbuf) {
3967         b->buf = m->bbuf;
3968         m->bbuf = NULL;
3969         b->ptr = b->end = b->buf;
3970     }
3971     if (PerlIOBuf_close(f) != 0)
3972         code = -1;
3973     return code;
3974 }
3975
3976 PerlIO *
3977 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
3978 {
3979  return PerlIOBase_dup(aTHX_ f, o, param);
3980 }
3981
3982
3983 PerlIO_funcs PerlIO_mmap = {
3984     "mmap",
3985     sizeof(PerlIOMmap),
3986     PERLIO_K_BUFFERED,
3987     PerlIOBuf_pushed,
3988     PerlIOBase_noop_ok,
3989     PerlIOBuf_open,
3990     NULL,
3991     PerlIOBase_fileno,
3992     PerlIOMmap_dup,
3993     PerlIOBuf_read,
3994     PerlIOMmap_unread,
3995     PerlIOMmap_write,
3996     PerlIOBuf_seek,
3997     PerlIOBuf_tell,
3998     PerlIOBuf_close,
3999     PerlIOMmap_flush,
4000     PerlIOMmap_fill,
4001     PerlIOBase_eof,
4002     PerlIOBase_error,
4003     PerlIOBase_clearerr,
4004     PerlIOBase_setlinebuf,
4005     PerlIOMmap_get_base,
4006     PerlIOBuf_bufsiz,
4007     PerlIOBuf_get_ptr,
4008     PerlIOBuf_get_cnt,
4009     PerlIOBuf_set_ptrcnt,
4010 };
4011
4012 #endif                          /* HAS_MMAP */
4013
4014 #undef PerlIO_stdin
4015 PerlIO *
4016 PerlIO_stdin(void)
4017 {
4018     dTHX;
4019     if (!PL_perlio) {
4020         PerlIO_stdstreams(aTHX);
4021     }
4022     return &PL_perlio[1];
4023 }
4024
4025 #undef PerlIO_stdout
4026 PerlIO *
4027 PerlIO_stdout(void)
4028 {
4029     dTHX;
4030     if (!PL_perlio) {
4031         PerlIO_stdstreams(aTHX);
4032     }
4033     return &PL_perlio[2];
4034 }
4035
4036 #undef PerlIO_stderr
4037 PerlIO *
4038 PerlIO_stderr(void)
4039 {
4040     dTHX;
4041     if (!PL_perlio) {
4042         PerlIO_stdstreams(aTHX);
4043     }
4044     return &PL_perlio[3];
4045 }
4046
4047 /*--------------------------------------------------------------------------------------*/
4048
4049 #undef PerlIO_getname
4050 char *
4051 PerlIO_getname(PerlIO *f, char *buf)
4052 {
4053     dTHX;
4054     char *name = NULL;
4055 #ifdef VMS
4056     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4057     if (stdio)
4058         name = fgetname(stdio, buf);
4059 #else
4060     Perl_croak(aTHX_ "Don't know how to get file name");
4061 #endif
4062     return name;
4063 }
4064
4065
4066 /*--------------------------------------------------------------------------------------*/
4067 /*
4068  * Functions which can be called on any kind of PerlIO implemented in
4069  * terms of above
4070  */
4071
4072 #undef PerlIO_getc
4073 int
4074 PerlIO_getc(PerlIO *f)
4075 {
4076     STDCHAR buf[1];
4077     SSize_t count = PerlIO_read(f, buf, 1);
4078     if (count == 1) {
4079         return (unsigned char) buf[0];
4080     }
4081     return EOF;
4082 }
4083
4084 #undef PerlIO_ungetc
4085 int
4086 PerlIO_ungetc(PerlIO *f, int ch)
4087 {
4088     if (ch != EOF) {
4089         STDCHAR buf = ch;
4090         if (PerlIO_unread(f, &buf, 1) == 1)
4091             return ch;
4092     }
4093     return EOF;
4094 }
4095
4096 #undef PerlIO_putc
4097 int
4098 PerlIO_putc(PerlIO *f, int ch)
4099 {
4100     STDCHAR buf = ch;
4101     return PerlIO_write(f, &buf, 1);
4102 }
4103
4104 #undef PerlIO_puts
4105 int
4106 PerlIO_puts(PerlIO *f, const char *s)
4107 {
4108     STRLEN len = strlen(s);
4109     return PerlIO_write(f, s, len);
4110 }
4111
4112 #undef PerlIO_rewind
4113 void
4114 PerlIO_rewind(PerlIO *f)
4115 {
4116     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4117     PerlIO_clearerr(f);
4118 }
4119
4120 #undef PerlIO_vprintf
4121 int
4122 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4123 {
4124     dTHX;
4125     SV *sv = newSVpvn("", 0);
4126     char *s;
4127     STRLEN len;
4128     SSize_t wrote;
4129 #ifdef NEED_VA_COPY
4130     va_list apc;
4131     Perl_va_copy(ap, apc);
4132     sv_vcatpvf(sv, fmt, &apc);
4133 #else
4134     sv_vcatpvf(sv, fmt, &ap);
4135 #endif
4136     s = SvPV(sv, len);
4137     wrote = PerlIO_write(f, s, len);
4138     SvREFCNT_dec(sv);
4139     return wrote;
4140 }
4141
4142 #undef PerlIO_printf
4143 int
4144 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4145 {
4146     va_list ap;
4147     int result;
4148     va_start(ap, fmt);
4149     result = PerlIO_vprintf(f, fmt, ap);
4150     va_end(ap);
4151     return result;
4152 }
4153
4154 #undef PerlIO_stdoutf
4155 int
4156 PerlIO_stdoutf(const char *fmt, ...)
4157 {
4158     va_list ap;
4159     int result;
4160     va_start(ap, fmt);
4161     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4162     va_end(ap);
4163     return result;
4164 }
4165
4166 #undef PerlIO_tmpfile
4167 PerlIO *
4168 PerlIO_tmpfile(void)
4169 {
4170     /*
4171      * I have no idea how portable mkstemp() is ...
4172      */
4173 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4174     dTHX;
4175     PerlIO *f = NULL;
4176     FILE *stdio = PerlSIO_tmpfile();
4177     if (stdio) {
4178         PerlIOStdio *s =
4179             PerlIOSelf(PerlIO_push
4180                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4181                         "w+", Nullsv), PerlIOStdio);
4182         s->stdio = stdio;
4183     }
4184     return f;
4185 #else
4186     dTHX;
4187     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4188     int fd = mkstemp(SvPVX(sv));
4189     PerlIO *f = NULL;
4190     if (fd >= 0) {
4191         f = PerlIO_fdopen(fd, "w+");
4192         if (f) {
4193             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4194         }
4195         PerlLIO_unlink(SvPVX(sv));
4196         SvREFCNT_dec(sv);
4197     }
4198     return f;
4199 #endif
4200 }
4201
4202 #undef HAS_FSETPOS
4203 #undef HAS_FGETPOS
4204
4205 #endif                          /* USE_SFIO */
4206 #endif                          /* PERLIO_IS_STDIO */
4207
4208 /*======================================================================================*/
4209 /*
4210  * Now some functions in terms of above which may be needed even if we are
4211  * not in true PerlIO mode
4212  */
4213
4214 #ifndef HAS_FSETPOS
4215 #undef PerlIO_setpos
4216 int
4217 PerlIO_setpos(PerlIO *f, SV *pos)
4218 {
4219     dTHX;
4220     if (SvOK(pos)) {
4221         STRLEN len;
4222         Off_t *posn = (Off_t *) SvPV(pos, len);
4223         if (f && len == sizeof(Off_t))
4224             return PerlIO_seek(f, *posn, SEEK_SET);
4225     }
4226     SETERRNO(EINVAL, SS$_IVCHAN);
4227     return -1;
4228 }
4229 #else
4230 #undef PerlIO_setpos
4231 int
4232 PerlIO_setpos(PerlIO *f, SV *pos)
4233 {
4234     dTHX;
4235     if (SvOK(pos)) {
4236         STRLEN len;
4237         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4238         if (f && len == sizeof(Fpos_t)) {
4239 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4240             return fsetpos64(f, fpos);
4241 #else
4242             return fsetpos(f, fpos);
4243 #endif
4244         }
4245     }
4246     SETERRNO(EINVAL, SS$_IVCHAN);
4247     return -1;
4248 }
4249 #endif
4250
4251 #ifndef HAS_FGETPOS
4252 #undef PerlIO_getpos
4253 int
4254 PerlIO_getpos(PerlIO *f, SV *pos)
4255 {
4256     dTHX;
4257     Off_t posn = PerlIO_tell(f);
4258     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4259     return (posn == (Off_t) - 1) ? -1 : 0;
4260 }
4261 #else
4262 #undef PerlIO_getpos
4263 int
4264 PerlIO_getpos(PerlIO *f, SV *pos)
4265 {
4266     dTHX;
4267     Fpos_t fpos;
4268     int code;
4269 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4270     code = fgetpos64(f, &fpos);
4271 #else
4272     code = fgetpos(f, &fpos);
4273 #endif
4274     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4275     return code;
4276 }
4277 #endif
4278
4279 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4280
4281 int
4282 vprintf(char *pat, char *args)
4283 {
4284     _doprnt(pat, args, stdout);
4285     return 0;                   /* wrong, but perl doesn't use the return
4286                                  * value */
4287 }
4288
4289 int
4290 vfprintf(FILE *fd, char *pat, char *args)
4291 {
4292     _doprnt(pat, args, fd);
4293     return 0;                   /* wrong, but perl doesn't use the return
4294                                  * value */
4295 }
4296
4297 #endif
4298
4299 #ifndef PerlIO_vsprintf
4300 int
4301 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4302 {
4303     int val = vsprintf(s, fmt, ap);
4304     if (n >= 0) {
4305         if (strlen(s) >= (STRLEN) n) {
4306             dTHX;
4307             (void) PerlIO_puts(Perl_error_log,
4308                                "panic: sprintf overflow - memory corrupted!\n");
4309             my_exit(1);
4310         }
4311     }
4312     return val;
4313 }
4314 #endif
4315
4316 #ifndef PerlIO_sprintf
4317 int
4318 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4319 {
4320     va_list ap;
4321     int result;
4322     va_start(ap, fmt);
4323     result = PerlIO_vsprintf(s, n, fmt, ap);
4324     va_end(ap);
4325     return result;
4326 }
4327 #endif
4328
4329
4330
4331
4332