perlio.c

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