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