perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2000, Nick Ing-Simmons
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 #define VOIDUSED 1
  11 #ifdef PERL_MICRO
  12 #   include "uconfig.h"
  13 #else
  14 #   include "config.h"
  15 #endif
  16
  17 #define PERLIO_NOT_STDIO 0
  18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  19 /* #define PerlIO FILE */
  20 #endif
  21 /*
  22  * This file provides those parts of PerlIO abstraction
  23  * which are not #defined in perlio.h.
  24  * Which these are depends on various Configure #ifdef's
  25  */
  26
  27 #include "EXTERN.h"
  28 #define PERL_IN_PERLIO_C
  29 #include "perl.h"
  30
  31 #undef PerlMemShared_calloc
  32 #define PerlMemShared_calloc(x,y) calloc(x,y)
  33 #undef PerlMemShared_free
  34 #define PerlMemShared_free(x) free(x)
  35
  36
  37 #ifndef PERLIO_LAYERS
  38 int
  39 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  40 {
  41  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
  42   {
  43    return 0;
  44   }
  45  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
  46  /* NOTREACHED */
  47  return -1;
  48 }
  49
  50 int
  51 perlsio_binmode(FILE *fp, int iotype, int mode)
  52 {
  53 /* This used to be contents of do_binmode in doio.c */
  54 #ifdef DOSISH
  55 #  if defined(atarist) || defined(__MINT__)
  56     if (!fflush(fp)) {
  57         if (mode & O_BINARY)
  58             ((FILE*)fp)->_flag |= _IOBIN;
  59         else
  60             ((FILE*)fp)->_flag &= ~ _IOBIN;
  61         return 1;
  62     }
  63     return 0;
  64 #  else
  65     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  66 #    if defined(WIN32) && defined(__BORLANDC__)
  67         /* The translation mode of the stream is maintained independent
  68          * of the translation mode of the fd in the Borland RTL (heavy
  69          * digging through their runtime sources reveal).  User has to
  70          * set the mode explicitly for the stream (though they don't
  71          * document this anywhere). GSAR 97-5-24
  72          */
  73         fseek(fp,0L,0);
  74         if (mode & O_BINARY)
  75             fp->flags |= _F_BIN;
  76         else
  77             fp->flags &= ~ _F_BIN;
  78 #    endif
  79         return 1;
  80     }
  81     else
  82         return 0;
  83 #  endif
  84 #else
  85 #  if defined(USEMYBINMODE)
  86     if (my_binmode(fp, iotype, mode) != FALSE)
  87         return 1;
  88     else
  89         return 0;
  90 #  else
  91     return 1;
  92 #  endif
  93 #endif
  94 }
  95
  96 int
  97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
  98 {
  99  return perlsio_binmode(fp,iotype,mode);
 100 }
 101
 102 #endif
 103
 104
 105 #ifdef PERLIO_IS_STDIO
 106
 107 void
 108 PerlIO_init(void)
 109 {
 110  /* Does nothing (yet) except force this file to be included
 111     in perl binary. That allows this file to force inclusion
 112     of other functions that may be required by loadable
 113     extensions e.g. for FileHandle::tmpfile
 114  */
 115 }
 116
 117 #undef PerlIO_tmpfile
 118 PerlIO *
 119 PerlIO_tmpfile(void)
 120 {
 121  return tmpfile();
 122 }
 123
 124 #else /* PERLIO_IS_STDIO */
 125
 126 #ifdef USE_SFIO
 127
 128 #undef HAS_FSETPOS
 129 #undef HAS_FGETPOS
 130
 131 /* This section is just to make sure these functions
 132    get pulled in from libsfio.a
 133 */
 134
 135 #undef PerlIO_tmpfile
 136 PerlIO *
 137 PerlIO_tmpfile(void)
 138 {
 139  return sftmp(0);
 140 }
 141
 142 void
 143 PerlIO_init(void)
 144 {
 145  /* Force this file to be included  in perl binary. Which allows
 146   *  this file to force inclusion  of other functions that may be
 147   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 148   */
 149
 150  /* Hack
 151   * sfio does its own 'autoflush' on stdout in common cases.
 152   * Flush results in a lot of lseek()s to regular files and
 153   * lot of small writes to pipes.
 154   */
 155  sfset(sfstdout,SF_SHARE,0);
 156 }
 157
 158 #else /* USE_SFIO */
 159 /*======================================================================================*/
 160 /* Implement all the PerlIO interface ourselves.
 161  */
 162
 163 #include "perliol.h"
 164
 165 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 166 #ifdef I_UNISTD
 167 #include <unistd.h>
 168 #endif
 169 #ifdef HAS_MMAP
 170 #include <sys/mman.h>
 171 #endif
 172
 173 #include "XSUB.h"
 174
 175 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 176
 177 void
 178 PerlIO_debug(const char *fmt,...)
 179 {
 180  dTHX;
 181  static int dbg = 0;
 182  va_list ap;
 183  va_start(ap,fmt);
 184  if (!dbg)
 185   {
 186    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 187    if (s && *s)
 188     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 189    else
 190     dbg = -1;
 191   }
 192  if (dbg > 0)
 193   {
 194    dTHX;
 195    SV *sv = newSVpvn("",0);
 196    char *s;
 197    STRLEN len;
 198    s = CopFILE(PL_curcop);
 199    if (!s)
 200     s = "(none)";
 201    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 202    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 203
 204    s = SvPV(sv,len);
 205    PerlLIO_write(dbg,s,len);
 206    SvREFCNT_dec(sv);
 207   }
 208  va_end(ap);
 209 }
 210
 211 /*--------------------------------------------------------------------------------------*/
 212
 213 /* Inner level routines */
 214
 215 /* Table of pointers to the PerlIO structs (malloc'ed) */
 216 PerlIO *_perlio      = NULL;
 217 #define PERLIO_TABLE_SIZE 64
 218
 219 PerlIO *
 220 PerlIO_allocate(pTHX)
 221 {
 222  /* Find a free slot in the table, allocating new table as necessary */
 223  PerlIO **last;
 224  PerlIO *f;
 225  last = &_perlio;
 226  while ((f = *last))
 227   {
 228    int i;
 229    last = (PerlIO **)(f);
 230    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 231     {
 232      if (!*++f)
 233       {
 234        return f;
 235       }
 236     }
 237   }
 238  f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
 239  if (!f)
 240   {
 241    return NULL;
 242   }
 243  *last = f;
 244  return f+1;
 245 }
 246
 247 void
 248 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 249 {
 250  PerlIO *table = *tablep;
 251  if (table)
 252   {
 253    int i;
 254    PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
 255    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 256     {
 257      PerlIO *f = table+i;
 258      if (*f)
 259       {
 260        PerlIO_close(f);
 261       }
 262     }
 263    PerlMemShared_free(table);
 264    *tablep = NULL;
 265   }
 266 }
 267
 268 HV *PerlIO_layer_hv;
 269 AV *PerlIO_layer_av;
 270
 271 void
 272 PerlIO_cleanup()
 273 {
 274  dTHX;
 275  PerlIO_cleantable(aTHX_ &_perlio);
 276 }
 277
 278 void
 279 PerlIO_pop(PerlIO *f)
 280 {
 281  dTHX;
 282  PerlIOl *l = *f;
 283  if (l)
 284   {
 285    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 286    (*l->tab->Popped)(f);
 287    *f = l->next;
 288    PerlMemShared_free(l);
 289   }
 290 }
 291
 292 /*--------------------------------------------------------------------------------------*/
 293 /* XS Interface for perl code */
 294
 295 XS(XS_perlio_import)
 296 {
 297  dXSARGS;
 298  GV *gv = CvGV(cv);
 299  char *s = GvNAME(gv);
 300  STRLEN l = GvNAMELEN(gv);
 301  PerlIO_debug("%.*s\n",(int) l,s);
 302  XSRETURN_EMPTY;
 303 }
 304
 305 XS(XS_perlio_unimport)
 306 {
 307  dXSARGS;
 308  GV *gv = CvGV(cv);
 309  char *s = GvNAME(gv);
 310  STRLEN l = GvNAMELEN(gv);
 311  PerlIO_debug("%.*s\n",(int) l,s);
 312  XSRETURN_EMPTY;
 313 }
 314
 315 SV *
 316 PerlIO_find_layer(const char *name, STRLEN len)
 317 {
 318  dTHX;
 319  SV **svp;
 320  SV *sv;
 321  if (len <= 0)
 322   len = strlen(name);
 323  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 324  if (svp && (sv = *svp) && SvROK(sv))
 325   return *svp;
 326  return NULL;
 327 }
 328
 329
 330 static int
 331 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 332 {
 333  if (SvROK(sv))
 334   {
 335    IO *io = GvIOn((GV *)SvRV(sv));
 336    PerlIO *ifp = IoIFP(io);
 337    PerlIO *ofp = IoOFP(io);
 338    AV *av = (AV *) mg->mg_obj;
 339    Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
 340   }
 341  return 0;
 342 }
 343
 344 static int
 345 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 346 {
 347  if (SvROK(sv))
 348   {
 349    IO *io = GvIOn((GV *)SvRV(sv));
 350    PerlIO *ifp = IoIFP(io);
 351    PerlIO *ofp = IoOFP(io);
 352    AV *av = (AV *) mg->mg_obj;
 353    Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
 354   }
 355  return 0;
 356 }
 357
 358 static int
 359 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 360 {
 361  Perl_warn(aTHX_ "clear %"SVf,sv);
 362  return 0;
 363 }
 364
 365 static int
 366 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 367 {
 368  Perl_warn(aTHX_ "free %"SVf,sv);
 369  return 0;
 370 }
 371
 372 MGVTBL perlio_vtab = {
 373  perlio_mg_get,
 374  perlio_mg_set,
 375  NULL, /* len */
 376  NULL,
 377  perlio_mg_free
 378 };
 379
 380 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 381 {
 382  dXSARGS;
 383  SV *sv    = SvRV(ST(1));
 384  AV *av    = newAV();
 385  MAGIC *mg;
 386  int count = 0;
 387  int i;
 388  sv_magic(sv, (SV *)av, '~', NULL, 0);
 389  SvRMAGICAL_off(sv);
 390  mg = mg_find(sv,'~');
 391  mg->mg_virtual = &perlio_vtab;
 392  mg_magical(sv);
 393  Perl_warn(aTHX_ "attrib %"SVf,sv);
 394  for (i=2; i < items; i++)
 395   {
 396    STRLEN len;
 397    const char *name = SvPV(ST(i),len);
 398    SV *layer  = PerlIO_find_layer(name,len);
 399    if (layer)
 400     {
 401      av_push(av,SvREFCNT_inc(layer));
 402     }
 403    else
 404     {
 405      ST(count) = ST(i);
 406      count++;
 407     }
 408   }
 409  SvREFCNT_dec(av);
 410  XSRETURN(count);
 411 }
 412
 413 void
 414 PerlIO_define_layer(PerlIO_funcs *tab)
 415 {
 416  dTHX;
 417  HV *stash = gv_stashpv("perlio::Layer", TRUE);
 418  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 419  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 420 }
 421
 422 PerlIO_funcs *
 423 PerlIO_default_layer(I32 n)
 424 {
 425  dTHX;
 426  SV **svp;
 427  SV *layer;
 428  PerlIO_funcs *tab = &PerlIO_stdio;
 429  int len;
 430  if (!PerlIO_layer_hv)
 431   {
 432    const char *s  = PerlEnv_getenv("PERLIO");
 433    newXS("perlio::import",XS_perlio_import,__FILE__);
 434    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 435 #if 0
 436    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 437 #endif
 438    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 439    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 440    PerlIO_define_layer(&PerlIO_unix);
 441    PerlIO_define_layer(&PerlIO_perlio);
 442    PerlIO_define_layer(&PerlIO_stdio);
 443    PerlIO_define_layer(&PerlIO_crlf);
 444 #ifdef HAS_MMAP
 445    PerlIO_define_layer(&PerlIO_mmap);
 446 #endif
 447    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
 448    if (s)
 449     {
 450      while (*s)
 451       {
 452        while (*s && isSPACE((unsigned char)*s))
 453         s++;
 454        if (*s)
 455         {
 456          const char *e = s;
 457          SV *layer;
 458          while (*e && !isSPACE((unsigned char)*e))
 459           e++;
 460          if (*s == ':')
 461           s++;
 462          layer = PerlIO_find_layer(s,e-s);
 463          if (layer)
 464           {
 465            PerlIO_debug("Pushing %.*s\n",(e-s),s);
 466            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
 467           }
 468          else
 469           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 470          s = e;
 471         }
 472       }
 473     }
 474   }
 475  len  = av_len(PerlIO_layer_av);
 476  if (len < 1)
 477   {
 478    if (O_BINARY != O_TEXT)
 479     {
 480      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
 481     }
 482    else
 483     {
 484      if (PerlIO_stdio.Set_ptrcnt)
 485       {
 486        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
 487       }
 488      else
 489       {
 490        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
 491       }
 492     }
 493    len  = av_len(PerlIO_layer_av);
 494   }
 495  if (n < 0)
 496   n += len+1;
 497  svp = av_fetch(PerlIO_layer_av,n,0);
 498  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 499   {
 500    tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 501   }
 502  /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
 503  return tab;
 504 }
 505
 506 #define PerlIO_default_top() PerlIO_default_layer(-1)
 507 #define PerlIO_default_btm() PerlIO_default_layer(0)
 508
 509 void
 510 PerlIO_stdstreams()
 511 {
 512  if (!_perlio)
 513   {
 514    dTHX;
 515    PerlIO_allocate(aTHX);
 516    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
 517    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
 518    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
 519   }
 520 }
 521
 522 PerlIO *
 523 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 524 {
 525  dTHX;
 526  PerlIOl *l = NULL;
 527  l = PerlMemShared_calloc(tab->size,sizeof(char));
 528  if (l)
 529   {
 530    Zero(l,tab->size,char);
 531    l->next = *f;
 532    l->tab  = tab;
 533    *f      = l;
 534    PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
 535    if ((*l->tab->Pushed)(f,mode) != 0)
 536     {
 537      PerlIO_pop(f);
 538      return NULL;
 539     }
 540   }
 541  return f;
 542 }
 543
 544 int
 545 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 546 {
 547  if (names)
 548   {
 549    const char *s = names;
 550    while (*s)
 551     {
 552      while (isSPACE(*s))
 553       s++;
 554      if (*s == ':')
 555       s++;
 556      if (*s)
 557       {
 558        const char *e = s;
 559        while (*e && *e != ':' && !isSPACE(*e))
 560         e++;
 561        if (e > s)
 562         {
 563          if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
 564           {
 565            /* Pop back to bottom layer */
 566            if (PerlIONext(f))
 567             {
 568              PerlIO_flush(f);
 569              while (PerlIONext(f))
 570               {
 571                PerlIO_pop(f);
 572               }
 573             }
 574           }
 575          else
 576           {
 577            SV *layer = PerlIO_find_layer(s,e-s);
 578            if (layer)
 579             {
 580              PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
 581              if (tab)
 582               {
 583                PerlIO *new = PerlIO_push(f,tab,mode);
 584                if (!new)
 585                 return -1;
 586               }
 587             }
 588            else
 589             Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
 590           }
 591         }
 592        s = e;
 593       }
 594     }
 595   }
 596  return 0;
 597 }
 598
 599
 600
 601 /*--------------------------------------------------------------------------------------*/
 602 /* Given the abstraction above the public API functions */
 603
 604 int
 605 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 606 {
 607  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 608               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 609  if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
 610   {
 611    PerlIO *top = f;
 612    PerlIOl *l;
 613    while (l = *top)
 614     {
 615      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 616       {
 617        PerlIO_flush(top);
 618        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 619        break;
 620       }
 621      top = PerlIONext(top);
 622     }
 623   }
 624  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 625 }
 626
 627 #undef PerlIO__close
 628 int
 629 PerlIO__close(PerlIO *f)
 630 {
 631  return (*PerlIOBase(f)->tab->Close)(f);
 632 }
 633
 634 #undef PerlIO_fdupopen
 635 PerlIO *
 636 PerlIO_fdupopen(pTHX_ PerlIO *f)
 637 {
 638  char buf[8];
 639  int fd = PerlLIO_dup(PerlIO_fileno(f));
 640  PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
 641  if (new)
 642   {
 643    Off_t posn = PerlIO_tell(f);
 644    PerlIO_seek(new,posn,SEEK_SET);
 645   }
 646  return new;
 647 }
 648
 649 #undef PerlIO_close
 650 int
 651 PerlIO_close(PerlIO *f)
 652 {
 653  int code = (*PerlIOBase(f)->tab->Close)(f);
 654  while (*f)
 655   {
 656    PerlIO_pop(f);
 657   }
 658  return code;
 659 }
 660
 661 #undef PerlIO_fileno
 662 int
 663 PerlIO_fileno(PerlIO *f)
 664 {
 665  return (*PerlIOBase(f)->tab->Fileno)(f);
 666 }
 667
 668
 669
 670 #undef PerlIO_fdopen
 671 PerlIO *
 672 PerlIO_fdopen(int fd, const char *mode)
 673 {
 674  PerlIO_funcs *tab = PerlIO_default_top();
 675  if (!_perlio)
 676   PerlIO_stdstreams();
 677  return (*tab->Fdopen)(tab,fd,mode);
 678 }
 679
 680 #undef PerlIO_open
 681 PerlIO *
 682 PerlIO_open(const char *path, const char *mode)
 683 {
 684  PerlIO_funcs *tab = PerlIO_default_top();
 685  if (!_perlio)
 686   PerlIO_stdstreams();
 687  return (*tab->Open)(tab,path,mode);
 688 }
 689
 690 #undef PerlIO_reopen
 691 PerlIO *
 692 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 693 {
 694  if (f)
 695   {
 696    PerlIO_flush(f);
 697    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 698     {
 699      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 700       return f;
 701     }
 702    return NULL;
 703   }
 704  else
 705   return PerlIO_open(path,mode);
 706 }
 707
 708 #undef PerlIO_read
 709 SSize_t
 710 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 711 {
 712  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 713 }
 714
 715 #undef PerlIO_unread
 716 SSize_t
 717 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 718 {
 719  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 720 }
 721
 722 #undef PerlIO_write
 723 SSize_t
 724 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 725 {
 726  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 727 }
 728
 729 #undef PerlIO_seek
 730 int
 731 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 732 {
 733  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 734 }
 735
 736 #undef PerlIO_tell
 737 Off_t
 738 PerlIO_tell(PerlIO *f)
 739 {
 740  return (*PerlIOBase(f)->tab->Tell)(f);
 741 }
 742
 743 #undef PerlIO_flush
 744 int
 745 PerlIO_flush(PerlIO *f)
 746 {
 747  if (f)
 748   {
 749    return (*PerlIOBase(f)->tab->Flush)(f);
 750   }
 751  else
 752   {
 753    PerlIO **table = &_perlio;
 754    int code = 0;
 755    while ((f = *table))
 756     {
 757      int i;
 758      table = (PerlIO **)(f++);
 759      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 760       {
 761        if (*f && PerlIO_flush(f) != 0)
 762         code = -1;
 763        f++;
 764       }
 765     }
 766    return code;
 767   }
 768 }
 769
 770 #undef PerlIO_fill
 771 int
 772 PerlIO_fill(PerlIO *f)
 773 {
 774  return (*PerlIOBase(f)->tab->Fill)(f);
 775 }
 776
 777 #undef PerlIO_isutf8
 778 int
 779 PerlIO_isutf8(PerlIO *f)
 780 {
 781  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 782 }
 783
 784 #undef PerlIO_eof
 785 int
 786 PerlIO_eof(PerlIO *f)
 787 {
 788  return (*PerlIOBase(f)->tab->Eof)(f);
 789 }
 790
 791 #undef PerlIO_error
 792 int
 793 PerlIO_error(PerlIO *f)
 794 {
 795  return (*PerlIOBase(f)->tab->Error)(f);
 796 }
 797
 798 #undef PerlIO_clearerr
 799 void
 800 PerlIO_clearerr(PerlIO *f)
 801 {
 802  if (f && *f)
 803   (*PerlIOBase(f)->tab->Clearerr)(f);
 804 }
 805
 806 #undef PerlIO_setlinebuf
 807 void
 808 PerlIO_setlinebuf(PerlIO *f)
 809 {
 810  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 811 }
 812
 813 #undef PerlIO_has_base
 814 int
 815 PerlIO_has_base(PerlIO *f)
 816 {
 817  if (f && *f)
 818   {
 819    return (PerlIOBase(f)->tab->Get_base != NULL);
 820   }
 821  return 0;
 822 }
 823
 824 #undef PerlIO_fast_gets
 825 int
 826 PerlIO_fast_gets(PerlIO *f)
 827 {
 828  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
 829   {
 830    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 831    return (tab->Set_ptrcnt != NULL);
 832   }
 833  return 0;
 834 }
 835
 836 #undef PerlIO_has_cntptr
 837 int
 838 PerlIO_has_cntptr(PerlIO *f)
 839 {
 840  if (f && *f)
 841   {
 842    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 843    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 844   }
 845  return 0;
 846 }
 847
 848 #undef PerlIO_canset_cnt
 849 int
 850 PerlIO_canset_cnt(PerlIO *f)
 851 {
 852  if (f && *f)
 853   {
 854    PerlIOl *l = PerlIOBase(f);
 855    return (l->tab->Set_ptrcnt != NULL);
 856   }
 857  return 0;
 858 }
 859
 860 #undef PerlIO_get_base
 861 STDCHAR *
 862 PerlIO_get_base(PerlIO *f)
 863 {
 864  return (*PerlIOBase(f)->tab->Get_base)(f);
 865 }
 866
 867 #undef PerlIO_get_bufsiz
 868 int
 869 PerlIO_get_bufsiz(PerlIO *f)
 870 {
 871  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 872 }
 873
 874 #undef PerlIO_get_ptr
 875 STDCHAR *
 876 PerlIO_get_ptr(PerlIO *f)
 877 {
 878  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 879  if (tab->Get_ptr == NULL)
 880   return NULL;
 881  return (*tab->Get_ptr)(f);
 882 }
 883
 884 #undef PerlIO_get_cnt
 885 int
 886 PerlIO_get_cnt(PerlIO *f)
 887 {
 888  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 889  if (tab->Get_cnt == NULL)
 890   return 0;
 891  return (*tab->Get_cnt)(f);
 892 }
 893
 894 #undef PerlIO_set_cnt
 895 void
 896 PerlIO_set_cnt(PerlIO *f,int cnt)
 897 {
 898  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 899 }
 900
 901 #undef PerlIO_set_ptrcnt
 902 void
 903 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 904 {
 905  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 906  if (tab->Set_ptrcnt == NULL)
 907   {
 908    dTHX;
 909    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
 910   }
 911  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 912 }
 913
 914 /*--------------------------------------------------------------------------------------*/
 915 /* "Methods" of the "base class" */
 916
 917 IV
 918 PerlIOBase_fileno(PerlIO *f)
 919 {
 920  return PerlIO_fileno(PerlIONext(f));
 921 }
 922
 923 char *
 924 PerlIO_modestr(PerlIO *f,char *buf)
 925 {
 926  char *s = buf;
 927  IV flags = PerlIOBase(f)->flags;
 928  if (flags & PERLIO_F_APPEND)
 929   {
 930    *s++ = 'a';
 931    if (flags & PERLIO_F_CANREAD)
 932     {
 933      *s++ = '+';
 934     }
 935   }
 936  else if (flags & PERLIO_F_CANREAD)
 937   {
 938    *s++ = 'r';
 939    if (flags & PERLIO_F_CANWRITE)
 940     *s++ = '+';
 941   }
 942  else if (flags & PERLIO_F_CANWRITE)
 943   {
 944    *s++ = 'w';
 945    if (flags & PERLIO_F_CANREAD)
 946     {
 947      *s++ = '+';
 948     }
 949   }
 950 #if O_TEXT != O_BINARY
 951  if (!(flags & PERLIO_F_CRLF))
 952   *s++ = 'b';
 953 #endif
 954  *s = '\0';
 955  return buf;
 956 }
 957
 958 IV
 959 PerlIOBase_pushed(PerlIO *f, const char *mode)
 960 {
 961  PerlIOl *l = PerlIOBase(f);
 962  const char *omode = mode;
 963  char temp[8];
 964  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 965  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 966                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 967  if (tab->Set_ptrcnt != NULL)
 968   l->flags |= PERLIO_F_FASTGETS;
 969  if (mode)
 970   {
 971    switch (*mode++)
 972     {
 973      case 'r':
 974       l->flags |= PERLIO_F_CANREAD;
 975       break;
 976      case 'a':
 977       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 978       break;
 979      case 'w':
 980       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 981       break;
 982      default:
 983       errno = EINVAL;
 984       return -1;
 985     }
 986    while (*mode)
 987     {
 988      switch (*mode++)
 989       {
 990        case '+':
 991         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 992         break;
 993        case 'b':
 994         l->flags &= ~PERLIO_F_CRLF;
 995         break;
 996        case 't':
 997         l->flags |= PERLIO_F_CRLF;
 998         break;
 999       default:
1000        errno = EINVAL;
1001        return -1;
1002       }
1003     }
1004   }
1005  else
1006   {
1007    if (l->next)
1008     {
1009      l->flags |= l->next->flags &
1010                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1011     }
1012   }
1013 #if 0
1014  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1015               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1016               l->flags,PerlIO_modestr(f,temp));
1017 #endif
1018  return 0;
1019 }
1020
1021 IV
1022 PerlIOBase_popped(PerlIO *f)
1023 {
1024  return 0;
1025 }
1026
1027 extern PerlIO_funcs PerlIO_pending;
1028
1029 SSize_t
1030 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1031 {
1032 #if 0
1033  Off_t old = PerlIO_tell(f);
1034  if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1035   {
1036    Off_t new = PerlIO_tell(f);
1037    return old - new;
1038   }
1039  else
1040   {
1041    return 0;
1042   }
1043 #else
1044  PerlIO_push(f,&PerlIO_pending,"r");
1045  return PerlIOBuf_unread(f,vbuf,count);
1046 #endif
1047 }
1048
1049 IV
1050 PerlIOBase_noop_ok(PerlIO *f)
1051 {
1052  return 0;
1053 }
1054
1055 IV
1056 PerlIOBase_noop_fail(PerlIO *f)
1057 {
1058  return -1;
1059 }
1060
1061 IV
1062 PerlIOBase_close(PerlIO *f)
1063 {
1064  IV code = 0;
1065  PerlIO *n = PerlIONext(f);
1066  if (PerlIO_flush(f) != 0)
1067   code = -1;
1068  if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1069   code = -1;
1070  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1071  return code;
1072 }
1073
1074 IV
1075 PerlIOBase_eof(PerlIO *f)
1076 {
1077  if (f && *f)
1078   {
1079    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1080   }
1081  return 1;
1082 }
1083
1084 IV
1085 PerlIOBase_error(PerlIO *f)
1086 {
1087  if (f && *f)
1088   {
1089    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1090   }
1091  return 1;
1092 }
1093
1094 void
1095 PerlIOBase_clearerr(PerlIO *f)
1096 {
1097  if (f && *f)
1098   {
1099    PerlIO *n = PerlIONext(f);
1100    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1101    if (n)
1102     PerlIO_clearerr(n);
1103   }
1104 }
1105
1106 void
1107 PerlIOBase_setlinebuf(PerlIO *f)
1108 {
1109
1110 }
1111
1112 /*--------------------------------------------------------------------------------------*/
1113 /* Bottom-most level for UNIX-like case */
1114
1115 typedef struct
1116 {
1117  struct _PerlIO base;       /* The generic part */
1118  int            fd;         /* UNIX like file descriptor */
1119  int            oflags;     /* open/fcntl flags */
1120 } PerlIOUnix;
1121
1122 int
1123 PerlIOUnix_oflags(const char *mode)
1124 {
1125  int oflags = -1;
1126  switch(*mode)
1127   {
1128    case 'r':
1129     oflags = O_RDONLY;
1130     if (*++mode == '+')
1131      {
1132       oflags = O_RDWR;
1133       mode++;
1134      }
1135     break;
1136
1137    case 'w':
1138     oflags = O_CREAT|O_TRUNC;
1139     if (*++mode == '+')
1140      {
1141       oflags |= O_RDWR;
1142       mode++;
1143      }
1144     else
1145      oflags |= O_WRONLY;
1146     break;
1147
1148    case 'a':
1149     oflags = O_CREAT|O_APPEND;
1150     if (*++mode == '+')
1151      {
1152       oflags |= O_RDWR;
1153       mode++;
1154      }
1155     else
1156      oflags |= O_WRONLY;
1157     break;
1158   }
1159  if (*mode == 'b')
1160   {
1161    oflags |=  O_BINARY;
1162    oflags &= ~O_TEXT;
1163    mode++;
1164   }
1165  else if (*mode == 't')
1166   {
1167    oflags |=  O_TEXT;
1168    oflags &= ~O_BINARY;
1169    mode++;
1170   }
1171  /* Always open in binary mode */
1172  oflags |= O_BINARY;
1173  if (*mode || oflags == -1)
1174   {
1175    errno = EINVAL;
1176    oflags = -1;
1177   }
1178  return oflags;
1179 }
1180
1181 IV
1182 PerlIOUnix_fileno(PerlIO *f)
1183 {
1184  return PerlIOSelf(f,PerlIOUnix)->fd;
1185 }
1186
1187 PerlIO *
1188 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1189 {
1190  dTHX;
1191  PerlIO *f = NULL;
1192  if (*mode == 'I')
1193   mode++;
1194  if (fd >= 0)
1195   {
1196    int oflags = PerlIOUnix_oflags(mode);
1197    if (oflags != -1)
1198     {
1199      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1200      s->fd     = fd;
1201      s->oflags = oflags;
1202      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1203     }
1204   }
1205  return f;
1206 }
1207
1208 PerlIO *
1209 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1210 {
1211  dTHX;
1212  PerlIO *f = NULL;
1213  int oflags = PerlIOUnix_oflags(mode);
1214  if (oflags != -1)
1215   {
1216    int fd = PerlLIO_open3(path,oflags,0666);
1217    if (fd >= 0)
1218     {
1219      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1220      s->fd     = fd;
1221      s->oflags = oflags;
1222      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1223     }
1224   }
1225  return f;
1226 }
1227
1228 int
1229 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1230 {
1231  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1232  int oflags = PerlIOUnix_oflags(mode);
1233  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1234   (*PerlIOBase(f)->tab->Close)(f);
1235  if (oflags != -1)
1236   {
1237    dTHX;
1238    int fd = PerlLIO_open3(path,oflags,0666);
1239    if (fd >= 0)
1240     {
1241      s->fd = fd;
1242      s->oflags = oflags;
1243      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1244      return 0;
1245     }
1246   }
1247  return -1;
1248 }
1249
1250 SSize_t
1251 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1252 {
1253  dTHX;
1254  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1255  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1256   return 0;
1257  while (1)
1258   {
1259    SSize_t len = PerlLIO_read(fd,vbuf,count);
1260    if (len >= 0 || errno != EINTR)
1261     {
1262      if (len < 0)
1263       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1264      else if (len == 0 && count != 0)
1265       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1266      return len;
1267     }
1268   }
1269 }
1270
1271 SSize_t
1272 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1273 {
1274  dTHX;
1275  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1276  while (1)
1277   {
1278    SSize_t len = PerlLIO_write(fd,vbuf,count);
1279    if (len >= 0 || errno != EINTR)
1280     {
1281      if (len < 0)
1282       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1283      return len;
1284     }
1285   }
1286 }
1287
1288 IV
1289 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1290 {
1291  dTHX;
1292  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1293  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1294  return (new == (Off_t) -1) ? -1 : 0;
1295 }
1296
1297 Off_t
1298 PerlIOUnix_tell(PerlIO *f)
1299 {
1300  dTHX;
1301  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1302 }
1303
1304 IV
1305 PerlIOUnix_close(PerlIO *f)
1306 {
1307  dTHX;
1308  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1309  int code = 0;
1310  while (PerlLIO_close(fd) != 0)
1311   {
1312    if (errno != EINTR)
1313     {
1314      code = -1;
1315      break;
1316     }
1317   }
1318  if (code == 0)
1319   {
1320    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1321   }
1322  return code;
1323 }
1324
1325 PerlIO_funcs PerlIO_unix = {
1326  "unix",
1327  sizeof(PerlIOUnix),
1328  PERLIO_K_RAW,
1329  PerlIOUnix_fileno,
1330  PerlIOUnix_fdopen,
1331  PerlIOUnix_open,
1332  PerlIOUnix_reopen,
1333  PerlIOBase_pushed,
1334  PerlIOBase_noop_ok,
1335  PerlIOUnix_read,
1336  PerlIOBase_unread,
1337  PerlIOUnix_write,
1338  PerlIOUnix_seek,
1339  PerlIOUnix_tell,
1340  PerlIOUnix_close,
1341  PerlIOBase_noop_ok,   /* flush */
1342  PerlIOBase_noop_fail, /* fill */
1343  PerlIOBase_eof,
1344  PerlIOBase_error,
1345  PerlIOBase_clearerr,
1346  PerlIOBase_setlinebuf,
1347  NULL, /* get_base */
1348  NULL, /* get_bufsiz */
1349  NULL, /* get_ptr */
1350  NULL, /* get_cnt */
1351  NULL, /* set_ptrcnt */
1352 };
1353
1354 /*--------------------------------------------------------------------------------------*/
1355 /* stdio as a layer */
1356
1357 typedef struct
1358 {
1359  struct _PerlIO base;
1360  FILE *         stdio;      /* The stream */
1361 } PerlIOStdio;
1362
1363 IV
1364 PerlIOStdio_fileno(PerlIO *f)
1365 {
1366  dTHX;
1367  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1368 }
1369
1370 const char *
1371 PerlIOStdio_mode(const char *mode,char *tmode)
1372 {
1373  const char *ret = mode;
1374  if (O_BINARY != O_TEXT)
1375   {
1376    ret = (const char *) tmode;
1377    while (*mode)
1378     {
1379      *tmode++ = *mode++;
1380     }
1381    *tmode++ = 'b';
1382    *tmode = '\0';
1383   }
1384  return ret;
1385 }
1386
1387 PerlIO *
1388 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1389 {
1390  dTHX;
1391  PerlIO *f = NULL;
1392  int init = 0;
1393  char tmode[8];
1394  if (*mode == 'I')
1395   {
1396    init = 1;
1397    mode++;
1398   }
1399  if (fd >= 0)
1400   {
1401    FILE *stdio = NULL;
1402    if (init)
1403     {
1404      switch(fd)
1405       {
1406        case 0:
1407         stdio = PerlSIO_stdin;
1408         break;
1409        case 1:
1410         stdio = PerlSIO_stdout;
1411         break;
1412        case 2:
1413         stdio = PerlSIO_stderr;
1414         break;
1415       }
1416     }
1417    else
1418     {
1419      stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1420     }
1421    if (stdio)
1422     {
1423      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
1424      s->stdio  = stdio;
1425     }
1426   }
1427  return f;
1428 }
1429
1430 #undef PerlIO_importFILE
1431 PerlIO *
1432 PerlIO_importFILE(FILE *stdio, int fl)
1433 {
1434  dTHX;
1435  PerlIO *f = NULL;
1436  if (stdio)
1437   {
1438    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
1439    s->stdio  = stdio;
1440   }
1441  return f;
1442 }
1443
1444 PerlIO *
1445 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1446 {
1447  dTHX;
1448  PerlIO *f = NULL;
1449  FILE *stdio = PerlSIO_fopen(path,mode);
1450  if (stdio)
1451   {
1452    char tmode[8];
1453    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1454                                (mode = PerlIOStdio_mode(mode,tmode))),
1455                                PerlIOStdio);
1456    s->stdio  = stdio;
1457   }
1458  return f;
1459 }
1460
1461 int
1462 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1463 {
1464  dTHX;
1465  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1466  char tmode[8];
1467  FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1468  if (!s->stdio)
1469   return -1;
1470  s->stdio = stdio;
1471  return 0;
1472 }
1473
1474 SSize_t
1475 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1476 {
1477  dTHX;
1478  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1479  SSize_t got = 0;
1480  if (count == 1)
1481   {
1482    STDCHAR *buf = (STDCHAR *) vbuf;
1483    /* Perl is expecting PerlIO_getc() to fill the buffer
1484     * Linux's stdio does not do that for fread()
1485     */
1486    int ch = PerlSIO_fgetc(s);
1487    if (ch != EOF)
1488     {
1489      *buf = ch;
1490      got = 1;
1491     }
1492   }
1493  else
1494   got = PerlSIO_fread(vbuf,1,count,s);
1495  return got;
1496 }
1497
1498 SSize_t
1499 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1500 {
1501  dTHX;
1502  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1503  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1504  SSize_t unread = 0;
1505  while (count > 0)
1506   {
1507    int ch = *buf-- & 0xff;
1508    if (PerlSIO_ungetc(ch,s) != ch)
1509     break;
1510    unread++;
1511    count--;
1512   }
1513  return unread;
1514 }
1515
1516 SSize_t
1517 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1518 {
1519  dTHX;
1520  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1521 }
1522
1523 IV
1524 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1525 {
1526  dTHX;
1527  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1528  return PerlSIO_fseek(stdio,offset,whence);
1529 }
1530
1531 Off_t
1532 PerlIOStdio_tell(PerlIO *f)
1533 {
1534  dTHX;
1535  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1536  return PerlSIO_ftell(stdio);
1537 }
1538
1539 IV
1540 PerlIOStdio_close(PerlIO *f)
1541 {
1542  dTHX;
1543  int optval, optlen = sizeof(int);
1544  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1545  return(
1546    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1547        PerlSIO_fclose(stdio) :
1548        close(PerlIO_fileno(f)));
1549 }
1550
1551 IV
1552 PerlIOStdio_flush(PerlIO *f)
1553 {
1554  dTHX;
1555  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1556  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1557   {
1558    return PerlSIO_fflush(stdio);
1559   }
1560  else
1561   {
1562 #if 0
1563    /* FIXME: This discards ungetc() and pre-read stuff which is
1564       not right if this is just a "sync" from a layer above
1565       Suspect right design is to do _this_ but not have layer above
1566       flush this layer read-to-read
1567     */
1568    /* Not writeable - sync by attempting a seek */
1569    int err = errno;
1570    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1571     errno = err;
1572 #endif
1573   }
1574  return 0;
1575 }
1576
1577 IV
1578 PerlIOStdio_fill(PerlIO *f)
1579 {
1580  dTHX;
1581  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1582  int c;
1583  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1584  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1585   {
1586    if (PerlSIO_fflush(stdio) != 0)
1587     return EOF;
1588   }
1589  c = PerlSIO_fgetc(stdio);
1590  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1591   return EOF;
1592  return 0;
1593 }
1594
1595 IV
1596 PerlIOStdio_eof(PerlIO *f)
1597 {
1598  dTHX;
1599  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1600 }
1601
1602 IV
1603 PerlIOStdio_error(PerlIO *f)
1604 {
1605  dTHX;
1606  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1607 }
1608
1609 void
1610 PerlIOStdio_clearerr(PerlIO *f)
1611 {
1612  dTHX;
1613  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1614 }
1615
1616 void
1617 PerlIOStdio_setlinebuf(PerlIO *f)
1618 {
1619  dTHX;
1620 #ifdef HAS_SETLINEBUF
1621  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1622 #else
1623  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1624 #endif
1625 }
1626
1627 #ifdef FILE_base
1628 STDCHAR *
1629 PerlIOStdio_get_base(PerlIO *f)
1630 {
1631  dTHX;
1632  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1633  return PerlSIO_get_base(stdio);
1634 }
1635
1636 Size_t
1637 PerlIOStdio_get_bufsiz(PerlIO *f)
1638 {
1639  dTHX;
1640  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1641  return PerlSIO_get_bufsiz(stdio);
1642 }
1643 #endif
1644
1645 #ifdef USE_STDIO_PTR
1646 STDCHAR *
1647 PerlIOStdio_get_ptr(PerlIO *f)
1648 {
1649  dTHX;
1650  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1651  return PerlSIO_get_ptr(stdio);
1652 }
1653
1654 SSize_t
1655 PerlIOStdio_get_cnt(PerlIO *f)
1656 {
1657  dTHX;
1658  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1659  return PerlSIO_get_cnt(stdio);
1660 }
1661
1662 void
1663 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1664 {
1665  dTHX;
1666  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1667  if (ptr != NULL)
1668   {
1669 #ifdef STDIO_PTR_LVALUE
1670    PerlSIO_set_ptr(stdio,ptr);
1671 #ifdef STDIO_PTR_LVAL_SETS_CNT
1672    if (PerlSIO_get_cnt(stdio) != (cnt))
1673     {
1674      dTHX;
1675      assert(PerlSIO_get_cnt(stdio) == (cnt));
1676     }
1677 #endif
1678 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1679    /* Setting ptr _does_ change cnt - we are done */
1680    return;
1681 #endif
1682 #else  /* STDIO_PTR_LVALUE */
1683    PerlProc_abort();
1684 #endif /* STDIO_PTR_LVALUE */
1685   }
1686 /* Now (or only) set cnt */
1687 #ifdef STDIO_CNT_LVALUE
1688  PerlSIO_set_cnt(stdio,cnt);
1689 #else  /* STDIO_CNT_LVALUE */
1690 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1691  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1692 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1693  PerlProc_abort();
1694 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1695 #endif /* STDIO_CNT_LVALUE */
1696 }
1697
1698 #endif
1699
1700 PerlIO_funcs PerlIO_stdio = {
1701  "stdio",
1702  sizeof(PerlIOStdio),
1703  PERLIO_K_BUFFERED,
1704  PerlIOStdio_fileno,
1705  PerlIOStdio_fdopen,
1706  PerlIOStdio_open,
1707  PerlIOStdio_reopen,
1708  PerlIOBase_pushed,
1709  PerlIOBase_noop_ok,
1710  PerlIOStdio_read,
1711  PerlIOStdio_unread,
1712  PerlIOStdio_write,
1713  PerlIOStdio_seek,
1714  PerlIOStdio_tell,
1715  PerlIOStdio_close,
1716  PerlIOStdio_flush,
1717  PerlIOStdio_fill,
1718  PerlIOStdio_eof,
1719  PerlIOStdio_error,
1720  PerlIOStdio_clearerr,
1721  PerlIOStdio_setlinebuf,
1722 #ifdef FILE_base
1723  PerlIOStdio_get_base,
1724  PerlIOStdio_get_bufsiz,
1725 #else
1726  NULL,
1727  NULL,
1728 #endif
1729 #ifdef USE_STDIO_PTR
1730  PerlIOStdio_get_ptr,
1731  PerlIOStdio_get_cnt,
1732 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1733  PerlIOStdio_set_ptrcnt
1734 #else  /* STDIO_PTR_LVALUE */
1735  NULL
1736 #endif /* STDIO_PTR_LVALUE */
1737 #else  /* USE_STDIO_PTR */
1738  NULL,
1739  NULL,
1740  NULL
1741 #endif /* USE_STDIO_PTR */
1742 };
1743
1744 #undef PerlIO_exportFILE
1745 FILE *
1746 PerlIO_exportFILE(PerlIO *f, int fl)
1747 {
1748  PerlIO_flush(f);
1749  /* Should really push stdio discipline when we have them */
1750  return fdopen(PerlIO_fileno(f),"r+");
1751 }
1752
1753 #undef PerlIO_findFILE
1754 FILE *
1755 PerlIO_findFILE(PerlIO *f)
1756 {
1757  return PerlIO_exportFILE(f,0);
1758 }
1759
1760 #undef PerlIO_releaseFILE
1761 void
1762 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1763 {
1764 }
1765
1766 /*--------------------------------------------------------------------------------------*/
1767 /* perlio buffer layer */
1768
1769 IV
1770 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1771 {
1772  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1773  b->posn = PerlIO_tell(PerlIONext(f));
1774  return PerlIOBase_pushed(f,mode);
1775 }
1776
1777 PerlIO *
1778 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1779 {
1780  dTHX;
1781  PerlIO_funcs *tab = PerlIO_default_btm();
1782  int init = 0;
1783  PerlIO *f;
1784  if (*mode == 'I')
1785   {
1786    init = 1;
1787    mode++;
1788   }
1789 #if O_BINARY != O_TEXT
1790  /* do something about failing setmode()? --jhi */
1791  PerlLIO_setmode(fd, O_BINARY);
1792 #endif
1793  f = (*tab->Fdopen)(tab,fd,mode);
1794  if (f)
1795   {
1796    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1797    if (init && fd == 2)
1798     {
1799      /* Initial stderr is unbuffered */
1800      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1801     }
1802 #if 0
1803    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1804                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1805 #endif
1806   }
1807  return f;
1808 }
1809
1810 PerlIO *
1811 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1812 {
1813  PerlIO_funcs *tab = PerlIO_default_btm();
1814  PerlIO *f = (*tab->Open)(tab,path,mode);
1815  if (f)
1816   {
1817    PerlIO_push(f,self,mode);
1818   }
1819  return f;
1820 }
1821
1822 int
1823 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1824 {
1825  PerlIO *next = PerlIONext(f);
1826  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1827  if (code = 0)
1828   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1829  return code;
1830 }
1831
1832 /* This "flush" is akin to sfio's sync in that it handles files in either
1833    read or write state
1834 */
1835 IV
1836 PerlIOBuf_flush(PerlIO *f)
1837 {
1838  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1839  int code = 0;
1840  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1841   {
1842    /* write() the buffer */
1843    STDCHAR *p = b->buf;
1844    int count;
1845    PerlIO *n = PerlIONext(f);
1846    while (p < b->ptr)
1847     {
1848      count = PerlIO_write(n,p,b->ptr - p);
1849      if (count > 0)
1850       {
1851        p += count;
1852       }
1853      else if (count < 0 || PerlIO_error(n))
1854       {
1855        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1856        code = -1;
1857        break;
1858       }
1859     }
1860    b->posn += (p - b->buf);
1861   }
1862  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1863   {
1864    /* Note position change */
1865    b->posn += (b->ptr - b->buf);
1866    if (b->ptr < b->end)
1867     {
1868      /* We did not consume all of it */
1869      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1870       {
1871        b->posn = PerlIO_tell(PerlIONext(f));
1872       }
1873     }
1874   }
1875  b->ptr = b->end = b->buf;
1876  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1877  /* FIXME: Is this right for read case ? */
1878  if (PerlIO_flush(PerlIONext(f)) != 0)
1879   code = -1;
1880  return code;
1881 }
1882
1883 IV
1884 PerlIOBuf_fill(PerlIO *f)
1885 {
1886  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1887  PerlIO *n = PerlIONext(f);
1888  SSize_t avail;
1889  /* FIXME: doing the down-stream flush is a bad idea if it causes
1890     pre-read data in stdio buffer to be discarded
1891     but this is too simplistic - as it skips _our_ hosekeeping
1892     and breaks tell tests.
1893  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1894   {
1895   }
1896   */
1897  if (PerlIO_flush(f) != 0)
1898   return -1;
1899
1900  b->ptr = b->end = b->buf;
1901  if (PerlIO_fast_gets(n))
1902   {
1903    /* Layer below is also buffered
1904     * We do _NOT_ want to call its ->Read() because that will loop
1905     * till it gets what we asked for which may hang on a pipe etc.
1906     * Instead take anything it has to hand, or ask it to fill _once_.
1907     */
1908    avail  = PerlIO_get_cnt(n);
1909    if (avail <= 0)
1910     {
1911      avail = PerlIO_fill(n);
1912      if (avail == 0)
1913       avail = PerlIO_get_cnt(n);
1914      else
1915       {
1916        if (!PerlIO_error(n) && PerlIO_eof(n))
1917         avail = 0;
1918       }
1919     }
1920    if (avail > 0)
1921     {
1922      STDCHAR *ptr = PerlIO_get_ptr(n);
1923      SSize_t cnt  = avail;
1924      if (avail > b->bufsiz)
1925       avail = b->bufsiz;
1926      Copy(ptr,b->buf,avail,STDCHAR);
1927      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1928     }
1929   }
1930  else
1931   {
1932    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1933   }
1934  if (avail <= 0)
1935   {
1936    if (avail == 0)
1937     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1938    else
1939     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1940    return -1;
1941   }
1942  b->end      = b->buf+avail;
1943  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1944  return 0;
1945 }
1946
1947 SSize_t
1948 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1949 {
1950  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1951  STDCHAR *buf  = (STDCHAR *) vbuf;
1952  if (f)
1953   {
1954    if (!b->ptr)
1955     PerlIO_get_base(f);
1956    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1957     return 0;
1958    while (count > 0)
1959     {
1960      SSize_t avail = PerlIO_get_cnt(f);
1961      SSize_t take  = (count < avail) ? count : avail;
1962      if (take > 0)
1963       {
1964        STDCHAR *ptr = PerlIO_get_ptr(f);
1965        Copy(ptr,buf,take,STDCHAR);
1966        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1967        count   -= take;
1968        buf     += take;
1969       }
1970      if (count > 0  && avail <= 0)
1971       {
1972        if (PerlIO_fill(f) != 0)
1973         break;
1974       }
1975     }
1976    return (buf - (STDCHAR *) vbuf);
1977   }
1978  return 0;
1979 }
1980
1981 SSize_t
1982 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1983 {
1984  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1985  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1986  SSize_t unread = 0;
1987  SSize_t avail;
1988  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1989   PerlIO_flush(f);
1990  if (!b->buf)
1991   PerlIO_get_base(f);
1992  if (b->buf)
1993   {
1994    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1995     {
1996      avail = (b->ptr - b->buf);
1997     }
1998    else
1999     {
2000      avail = b->bufsiz;
2001      b->end = b->buf + avail;
2002      b->ptr = b->end;
2003      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2004      b->posn -= b->bufsiz;
2005     }
2006    if (avail > (SSize_t) count)
2007     avail = count;
2008    if (avail > 0)
2009     {
2010      b->ptr -= avail;
2011      buf    -= avail;
2012      if (buf != b->ptr)
2013       {
2014        Copy(buf,b->ptr,avail,STDCHAR);
2015       }
2016      count  -= avail;
2017      unread += avail;
2018      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2019     }
2020   }
2021  return unread;
2022 }
2023
2024 SSize_t
2025 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2026 {
2027  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2028  const STDCHAR *buf = (const STDCHAR *) vbuf;
2029  Size_t written = 0;
2030  if (!b->buf)
2031   PerlIO_get_base(f);
2032  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2033   return 0;
2034  while (count > 0)
2035   {
2036    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2037    if ((SSize_t) count < avail)
2038     avail = count;
2039    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2040    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2041     {
2042      while (avail > 0)
2043       {
2044        int ch = *buf++;
2045        *(b->ptr)++ = ch;
2046        count--;
2047        avail--;
2048        written++;
2049        if (ch == '\n')
2050         {
2051          PerlIO_flush(f);
2052          break;
2053         }
2054       }
2055     }
2056    else
2057     {
2058      if (avail)
2059       {
2060        Copy(buf,b->ptr,avail,STDCHAR);
2061        count   -= avail;
2062        buf     += avail;
2063        written += avail;
2064        b->ptr  += avail;
2065       }
2066     }
2067    if (b->ptr >= (b->buf + b->bufsiz))
2068     PerlIO_flush(f);
2069   }
2070  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2071   PerlIO_flush(f);
2072  return written;
2073 }
2074
2075 IV
2076 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2077 {
2078  IV code;
2079  if ((code = PerlIO_flush(f)) == 0)
2080   {
2081    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2082    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2083    code = PerlIO_seek(PerlIONext(f),offset,whence);
2084    if (code == 0)
2085     {
2086      b->posn = PerlIO_tell(PerlIONext(f));
2087     }
2088   }
2089  return code;
2090 }
2091
2092 Off_t
2093 PerlIOBuf_tell(PerlIO *f)
2094 {
2095  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2096  Off_t posn = b->posn;
2097  if (b->buf)
2098   posn += (b->ptr - b->buf);
2099  return posn;
2100 }
2101
2102 IV
2103 PerlIOBuf_close(PerlIO *f)
2104 {
2105  dTHX;
2106  IV code = PerlIOBase_close(f);
2107  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2108  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2109   {
2110    PerlMemShared_free(b->buf);
2111   }
2112  b->buf = NULL;
2113  b->ptr = b->end = b->buf;
2114  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2115  return code;
2116 }
2117
2118 void
2119 PerlIOBuf_setlinebuf(PerlIO *f)
2120 {
2121  if (f)
2122   {
2123    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2124   }
2125 }
2126
2127 STDCHAR *
2128 PerlIOBuf_get_ptr(PerlIO *f)
2129 {
2130  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2131  if (!b->buf)
2132   PerlIO_get_base(f);
2133  return b->ptr;
2134 }
2135
2136 SSize_t
2137 PerlIOBuf_get_cnt(PerlIO *f)
2138 {
2139  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2140  if (!b->buf)
2141   PerlIO_get_base(f);
2142  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2143   return (b->end - b->ptr);
2144  return 0;
2145 }
2146
2147 STDCHAR *
2148 PerlIOBuf_get_base(PerlIO *f)
2149 {
2150  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2151  if (!b->buf)
2152   {
2153    dTHX;
2154    if (!b->bufsiz)
2155     b->bufsiz = 4096;
2156    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2157    if (!b->buf)
2158     {
2159      b->buf = (STDCHAR *)&b->oneword;
2160      b->bufsiz = sizeof(b->oneword);
2161     }
2162    b->ptr = b->buf;
2163    b->end = b->ptr;
2164   }
2165  return b->buf;
2166 }
2167
2168 Size_t
2169 PerlIOBuf_bufsiz(PerlIO *f)
2170 {
2171  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2172  if (!b->buf)
2173   PerlIO_get_base(f);
2174  return (b->end - b->buf);
2175 }
2176
2177 void
2178 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2179 {
2180  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2181  if (!b->buf)
2182   PerlIO_get_base(f);
2183  b->ptr = ptr;
2184  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2185   {
2186    dTHX;
2187    assert(PerlIO_get_cnt(f) == cnt);
2188    assert(b->ptr >= b->buf);
2189   }
2190  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2191 }
2192
2193 PerlIO_funcs PerlIO_perlio = {
2194  "perlio",
2195  sizeof(PerlIOBuf),
2196  PERLIO_K_BUFFERED,
2197  PerlIOBase_fileno,
2198  PerlIOBuf_fdopen,
2199  PerlIOBuf_open,
2200  PerlIOBuf_reopen,
2201  PerlIOBuf_pushed,
2202  PerlIOBase_noop_ok,
2203  PerlIOBuf_read,
2204  PerlIOBuf_unread,
2205  PerlIOBuf_write,
2206  PerlIOBuf_seek,
2207  PerlIOBuf_tell,
2208  PerlIOBuf_close,
2209  PerlIOBuf_flush,
2210  PerlIOBuf_fill,
2211  PerlIOBase_eof,
2212  PerlIOBase_error,
2213  PerlIOBase_clearerr,
2214  PerlIOBuf_setlinebuf,
2215  PerlIOBuf_get_base,
2216  PerlIOBuf_bufsiz,
2217  PerlIOBuf_get_ptr,
2218  PerlIOBuf_get_cnt,
2219  PerlIOBuf_set_ptrcnt,
2220 };
2221
2222 /*--------------------------------------------------------------------------------------*/
2223 /* Temp layer to hold unread chars when cannot do it any other way */
2224
2225 IV
2226 PerlIOPending_fill(PerlIO *f)
2227 {
2228  /* Should never happen */
2229  PerlIO_flush(f);
2230  return 0;
2231 }
2232
2233 IV
2234 PerlIOPending_close(PerlIO *f)
2235 {
2236  /* A tad tricky - flush pops us, then we close new top */
2237  PerlIO_flush(f);
2238  return PerlIO_close(f);
2239 }
2240
2241 IV
2242 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2243 {
2244  /* A tad tricky - flush pops us, then we seek new top */
2245  PerlIO_flush(f);
2246  return PerlIO_seek(f,offset,whence);
2247 }
2248
2249
2250 IV
2251 PerlIOPending_flush(PerlIO *f)
2252 {
2253  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2254  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2255   {
2256    dTHX;
2257    PerlMemShared_free(b->buf);
2258    b->buf = NULL;
2259   }
2260  PerlIO_pop(f);
2261  return 0;
2262 }
2263
2264 void
2265 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2266 {
2267  if (cnt <= 0)
2268   {
2269    PerlIO_flush(f);
2270   }
2271  else
2272   {
2273    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2274   }
2275 }
2276
2277 IV
2278 PerlIOPending_pushed(PerlIO *f,const char *mode)
2279 {
2280  IV code    = PerlIOBuf_pushed(f,mode);
2281  PerlIOl *l = PerlIOBase(f);
2282  /* Our PerlIO_fast_gets must match what we are pushed on,
2283     or sv_gets() etc. get muddled when it changes mid-string
2284     when we auto-pop.
2285   */
2286  l->flags   = (l->flags & ~PERLIO_F_FASTGETS) |
2287               (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2288  return code;
2289 }
2290
2291 SSize_t
2292 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2293 {
2294  SSize_t avail = PerlIO_get_cnt(f);
2295  SSize_t got   = 0;
2296  if (count < avail)
2297   avail = count;
2298  if (avail > 0)
2299   got = PerlIOBuf_read(f,vbuf,avail);
2300  if (got < count)
2301   got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2302  return got;
2303 }
2304
2305
2306 PerlIO_funcs PerlIO_pending = {
2307  "pending",
2308  sizeof(PerlIOBuf),
2309  PERLIO_K_BUFFERED,
2310  PerlIOBase_fileno,
2311  NULL,
2312  NULL,
2313  NULL,
2314  PerlIOPending_pushed,
2315  PerlIOBase_noop_ok,
2316  PerlIOPending_read,
2317  PerlIOBuf_unread,
2318  PerlIOBuf_write,
2319  PerlIOPending_seek,
2320  PerlIOBuf_tell,
2321  PerlIOPending_close,
2322  PerlIOPending_flush,
2323  PerlIOPending_fill,
2324  PerlIOBase_eof,
2325  PerlIOBase_error,
2326  PerlIOBase_clearerr,
2327  PerlIOBuf_setlinebuf,
2328  PerlIOBuf_get_base,
2329  PerlIOBuf_bufsiz,
2330  PerlIOBuf_get_ptr,
2331  PerlIOBuf_get_cnt,
2332  PerlIOPending_set_ptrcnt,
2333 };
2334
2335
2336
2337 /*--------------------------------------------------------------------------------------*/
2338 /* crlf - translation
2339    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2340    to hand back a line at a time and keeping a record of which nl we "lied" about.
2341    On write translate "\n" to CR,LF
2342  */
2343
2344 typedef struct
2345 {
2346  PerlIOBuf      base;         /* PerlIOBuf stuff */
2347  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2348 } PerlIOCrlf;
2349
2350 IV
2351 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2352 {
2353  IV code;
2354  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2355  code = PerlIOBuf_pushed(f,mode);
2356 #if 0
2357  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2358               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2359               PerlIOBase(f)->flags);
2360 #endif
2361  return code;
2362 }
2363
2364
2365 SSize_t
2366 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2367 {
2368  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2369  if (c->nl)
2370   {
2371    *(c->nl) = 0xd;
2372    c->nl = NULL;
2373   }
2374  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2375   return PerlIOBuf_unread(f,vbuf,count);
2376  else
2377   {
2378    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2379    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2380    SSize_t unread = 0;
2381    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2382     PerlIO_flush(f);
2383    if (!b->buf)
2384     PerlIO_get_base(f);
2385    if (b->buf)
2386     {
2387      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2388       {
2389        b->end = b->ptr = b->buf + b->bufsiz;
2390        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2391        b->posn -= b->bufsiz;
2392       }
2393      while (count > 0 && b->ptr > b->buf)
2394       {
2395        int ch = *--buf;
2396        if (ch == '\n')
2397         {
2398          if (b->ptr - 2 >= b->buf)
2399           {
2400            *--(b->ptr) = 0xa;
2401            *--(b->ptr) = 0xd;
2402            unread++;
2403            count--;
2404           }
2405          else
2406           {
2407            buf++;
2408            break;
2409           }
2410         }
2411        else
2412         {
2413          *--(b->ptr) = ch;
2414          unread++;
2415          count--;
2416         }
2417       }
2418     }
2419    return unread;
2420   }
2421 }
2422
2423 SSize_t
2424 PerlIOCrlf_get_cnt(PerlIO *f)
2425 {
2426  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2427  if (!b->buf)
2428   PerlIO_get_base(f);
2429  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2430   {
2431    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2432    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2433     {
2434      STDCHAR *nl   = b->ptr;
2435     scan:
2436      while (nl < b->end && *nl != 0xd)
2437       nl++;
2438      if (nl < b->end && *nl == 0xd)
2439       {
2440      test:
2441        if (nl+1 < b->end)
2442         {
2443          if (nl[1] == 0xa)
2444           {
2445            *nl   = '\n';
2446            c->nl = nl;
2447           }
2448          else
2449           {
2450            /* Not CR,LF but just CR */
2451            nl++;
2452            goto scan;
2453           }
2454         }
2455        else
2456         {
2457          /* Blast - found CR as last char in buffer */
2458          if (b->ptr < nl)
2459           {
2460            /* They may not care, defer work as long as possible */
2461            return (nl - b->ptr);
2462           }
2463          else
2464           {
2465            int code;
2466            dTHX;
2467            b->ptr++;               /* say we have read it as far as flush() is concerned */
2468            b->buf++;               /* Leave space an front of buffer */
2469            b->bufsiz--;            /* Buffer is thus smaller */
2470            code = PerlIO_fill(f);  /* Fetch some more */
2471            b->bufsiz++;            /* Restore size for next time */
2472            b->buf--;               /* Point at space */
2473            b->ptr = nl = b->buf;   /* Which is what we hand off */
2474            b->posn--;              /* Buffer starts here */
2475            *nl = 0xd;              /* Fill in the CR */
2476            if (code == 0)
2477             goto test;             /* fill() call worked */
2478            /* CR at EOF - just fall through */
2479           }
2480         }
2481       }
2482     }
2483    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2484   }
2485  return 0;
2486 }
2487
2488 void
2489 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2490 {
2491  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2492  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2493  IV flags = PerlIOBase(f)->flags;
2494  if (!b->buf)
2495   PerlIO_get_base(f);
2496  if (!ptr)
2497   {
2498    if (c->nl)
2499     ptr = c->nl+1;
2500    else
2501     {
2502      ptr = b->end;
2503      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2504       ptr--;
2505     }
2506    ptr -= cnt;
2507   }
2508  else
2509   {
2510    /* Test code - delete when it works ... */
2511    STDCHAR *chk;
2512    if (c->nl)
2513     chk = c->nl+1;
2514    else
2515     {
2516      chk = b->end;
2517      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2518       chk--;
2519     }
2520    chk -= cnt;
2521
2522    if (ptr != chk)
2523     {
2524      dTHX;
2525      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2526                 ptr, chk, flags, c->nl, b->end, cnt);
2527     }
2528   }
2529  if (c->nl)
2530   {
2531    if (ptr > c->nl)
2532     {
2533      /* They have taken what we lied about */
2534      *(c->nl) = 0xd;
2535      c->nl = NULL;
2536      ptr++;
2537     }
2538   }
2539  b->ptr = ptr;
2540  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2541 }
2542
2543 SSize_t
2544 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2545 {
2546  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2547   return PerlIOBuf_write(f,vbuf,count);
2548  else
2549   {
2550    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2551    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2552    const STDCHAR *ebuf = buf+count;
2553    if (!b->buf)
2554     PerlIO_get_base(f);
2555    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2556     return 0;
2557    while (buf < ebuf)
2558     {
2559      STDCHAR *eptr = b->buf+b->bufsiz;
2560      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2561      while (buf < ebuf && b->ptr < eptr)
2562       {
2563        if (*buf == '\n')
2564         {
2565          if ((b->ptr + 2) > eptr)
2566           {
2567            /* Not room for both */
2568            PerlIO_flush(f);
2569            break;
2570           }
2571          else
2572           {
2573            *(b->ptr)++ = 0xd; /* CR */
2574            *(b->ptr)++ = 0xa; /* LF */
2575            buf++;
2576            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2577             {
2578              PerlIO_flush(f);
2579              break;
2580             }
2581           }
2582         }
2583        else
2584         {
2585          int ch = *buf++;
2586          *(b->ptr)++ = ch;
2587         }
2588        if (b->ptr >= eptr)
2589         {
2590          PerlIO_flush(f);
2591          break;
2592         }
2593       }
2594     }
2595    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2596     PerlIO_flush(f);
2597    return (buf - (STDCHAR *) vbuf);
2598   }
2599 }
2600
2601 IV
2602 PerlIOCrlf_flush(PerlIO *f)
2603 {
2604  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2605  if (c->nl)
2606   {
2607    *(c->nl) = 0xd;
2608    c->nl = NULL;
2609   }
2610  return PerlIOBuf_flush(f);
2611 }
2612
2613 PerlIO_funcs PerlIO_crlf = {
2614  "crlf",
2615  sizeof(PerlIOCrlf),
2616  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2617  PerlIOBase_fileno,
2618  PerlIOBuf_fdopen,
2619  PerlIOBuf_open,
2620  PerlIOBuf_reopen,
2621  PerlIOCrlf_pushed,
2622  PerlIOBase_noop_ok,   /* popped */
2623  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2624  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2625  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2626  PerlIOBuf_seek,
2627  PerlIOBuf_tell,
2628  PerlIOBuf_close,
2629  PerlIOCrlf_flush,
2630  PerlIOBuf_fill,
2631  PerlIOBase_eof,
2632  PerlIOBase_error,
2633  PerlIOBase_clearerr,
2634  PerlIOBuf_setlinebuf,
2635  PerlIOBuf_get_base,
2636  PerlIOBuf_bufsiz,
2637  PerlIOBuf_get_ptr,
2638  PerlIOCrlf_get_cnt,
2639  PerlIOCrlf_set_ptrcnt,
2640 };
2641
2642 #ifdef HAS_MMAP
2643 /*--------------------------------------------------------------------------------------*/
2644 /* mmap as "buffer" layer */
2645
2646 typedef struct
2647 {
2648  PerlIOBuf      base;         /* PerlIOBuf stuff */
2649  Mmap_t         mptr;        /* Mapped address */
2650  Size_t         len;          /* mapped length */
2651  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2652 } PerlIOMmap;
2653
2654 static size_t page_size = 0;
2655
2656 IV
2657 PerlIOMmap_map(PerlIO *f)
2658 {
2659  dTHX;
2660  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2661  PerlIOBuf  *b = &m->base;
2662  IV flags = PerlIOBase(f)->flags;
2663  IV code  = 0;
2664  if (m->len)
2665   abort();
2666  if (flags & PERLIO_F_CANREAD)
2667   {
2668    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2669    int fd   = PerlIO_fileno(f);
2670    struct stat st;
2671    code = fstat(fd,&st);
2672    if (code == 0 && S_ISREG(st.st_mode))
2673     {
2674      SSize_t len = st.st_size - b->posn;
2675      if (len > 0)
2676       {
2677        Off_t posn;
2678        if (!page_size) {
2679 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2680            {
2681                SETERRNO(0,SS$_NORMAL);
2682 #   ifdef _SC_PAGESIZE
2683                page_size = sysconf(_SC_PAGESIZE);
2684 #   else
2685                page_size = sysconf(_SC_PAGE_SIZE);
2686 #   endif
2687                if ((long)page_size < 0) {
2688                    if (errno) {
2689                        SV *error = ERRSV;
2690                        char *msg;
2691                        STRLEN n_a;
2692                        (void)SvUPGRADE(error, SVt_PV);
2693                        msg = SvPVx(error, n_a);
2694                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2695                    }
2696                    else
2697                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2698                }
2699            }
2700 #else
2701 #   ifdef HAS_GETPAGESIZE
2702         page_size = getpagesize();
2703 #   else
2704 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2705         page_size = PAGESIZE; /* compiletime, bad */
2706 #       endif
2707 #   endif
2708 #endif
2709         if ((IV)page_size <= 0)
2710             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2711        }
2712        if (b->posn < 0)
2713         {
2714          /* This is a hack - should never happen - open should have set it ! */
2715          b->posn = PerlIO_tell(PerlIONext(f));
2716         }
2717        posn = (b->posn / page_size) * page_size;
2718        len  = st.st_size - posn;
2719        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2720        if (m->mptr && m->mptr != (Mmap_t) -1)
2721         {
2722 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2723          madvise(m->mptr, len, MADV_SEQUENTIAL);
2724 #endif
2725          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2726          b->end  = ((STDCHAR *)m->mptr) + len;
2727          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2728          b->ptr  = b->buf;
2729          m->len  = len;
2730         }
2731        else
2732         {
2733          b->buf = NULL;
2734         }
2735       }
2736      else
2737       {
2738        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2739        b->buf = NULL;
2740        b->ptr = b->end = b->ptr;
2741        code = -1;
2742       }
2743     }
2744   }
2745  return code;
2746 }
2747
2748 IV
2749 PerlIOMmap_unmap(PerlIO *f)
2750 {
2751  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2752  PerlIOBuf  *b = &m->base;
2753  IV code = 0;
2754  if (m->len)
2755   {
2756    if (b->buf)
2757     {
2758      code = munmap(m->mptr, m->len);
2759      b->buf  = NULL;
2760      m->len  = 0;
2761      m->mptr = NULL;
2762      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2763       code = -1;
2764     }
2765    b->ptr = b->end = b->buf;
2766    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2767   }
2768  return code;
2769 }
2770
2771 STDCHAR *
2772 PerlIOMmap_get_base(PerlIO *f)
2773 {
2774  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2775  PerlIOBuf  *b = &m->base;
2776  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2777   {
2778    /* Already have a readbuffer in progress */
2779    return b->buf;
2780   }
2781  if (b->buf)
2782   {
2783    /* We have a write buffer or flushed PerlIOBuf read buffer */
2784    m->bbuf = b->buf;  /* save it in case we need it again */
2785    b->buf  = NULL;    /* Clear to trigger below */
2786   }
2787  if (!b->buf)
2788   {
2789    PerlIOMmap_map(f);     /* Try and map it */
2790    if (!b->buf)
2791     {
2792      /* Map did not work - recover PerlIOBuf buffer if we have one */
2793      b->buf = m->bbuf;
2794     }
2795   }
2796  b->ptr  = b->end = b->buf;
2797  if (b->buf)
2798   return b->buf;
2799  return PerlIOBuf_get_base(f);
2800 }
2801
2802 SSize_t
2803 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2804 {
2805  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2806  PerlIOBuf  *b = &m->base;
2807  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2808   PerlIO_flush(f);
2809  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2810   {
2811    b->ptr -= count;
2812    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2813    return count;
2814   }
2815  if (m->len)
2816   {
2817    /* Loose the unwritable mapped buffer */
2818    PerlIO_flush(f);
2819    /* If flush took the "buffer" see if we have one from before */
2820    if (!b->buf && m->bbuf)
2821     b->buf = m->bbuf;
2822    if (!b->buf)
2823     {
2824      PerlIOBuf_get_base(f);
2825      m->bbuf = b->buf;
2826     }
2827   }
2828 return PerlIOBuf_unread(f,vbuf,count);
2829 }
2830
2831 SSize_t
2832 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2833 {
2834  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2835  PerlIOBuf  *b = &m->base;
2836  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2837   {
2838    /* No, or wrong sort of, buffer */
2839    if (m->len)
2840     {
2841      if (PerlIOMmap_unmap(f) != 0)
2842       return 0;
2843     }
2844    /* If unmap took the "buffer" see if we have one from before */
2845    if (!b->buf && m->bbuf)
2846     b->buf = m->bbuf;
2847    if (!b->buf)
2848     {
2849      PerlIOBuf_get_base(f);
2850      m->bbuf = b->buf;
2851     }
2852   }
2853  return PerlIOBuf_write(f,vbuf,count);
2854 }
2855
2856 IV
2857 PerlIOMmap_flush(PerlIO *f)
2858 {
2859  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2860  PerlIOBuf  *b = &m->base;
2861  IV code = PerlIOBuf_flush(f);
2862  /* Now we are "synced" at PerlIOBuf level */
2863  if (b->buf)
2864   {
2865    if (m->len)
2866     {
2867      /* Unmap the buffer */
2868      if (PerlIOMmap_unmap(f) != 0)
2869       code = -1;
2870     }
2871    else
2872     {
2873      /* We seem to have a PerlIOBuf buffer which was not mapped
2874       * remember it in case we need one later
2875       */
2876      m->bbuf = b->buf;
2877     }
2878   }
2879  return code;
2880 }
2881
2882 IV
2883 PerlIOMmap_fill(PerlIO *f)
2884 {
2885  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2886  IV code = PerlIO_flush(f);
2887  if (code == 0 && !b->buf)
2888   {
2889    code = PerlIOMmap_map(f);
2890   }
2891  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2892   {
2893    code = PerlIOBuf_fill(f);
2894   }
2895  return code;
2896 }
2897
2898 IV
2899 PerlIOMmap_close(PerlIO *f)
2900 {
2901  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2902  PerlIOBuf  *b = &m->base;
2903  IV code = PerlIO_flush(f);
2904  if (m->bbuf)
2905   {
2906    b->buf  = m->bbuf;
2907    m->bbuf = NULL;
2908    b->ptr  = b->end = b->buf;
2909   }
2910  if (PerlIOBuf_close(f) != 0)
2911   code = -1;
2912  return code;
2913 }
2914
2915
2916 PerlIO_funcs PerlIO_mmap = {
2917  "mmap",
2918  sizeof(PerlIOMmap),
2919  PERLIO_K_BUFFERED,
2920  PerlIOBase_fileno,
2921  PerlIOBuf_fdopen,
2922  PerlIOBuf_open,
2923  PerlIOBuf_reopen,
2924  PerlIOBuf_pushed,
2925  PerlIOBase_noop_ok,
2926  PerlIOBuf_read,
2927  PerlIOMmap_unread,
2928  PerlIOMmap_write,
2929  PerlIOBuf_seek,
2930  PerlIOBuf_tell,
2931  PerlIOBuf_close,
2932  PerlIOMmap_flush,
2933  PerlIOMmap_fill,
2934  PerlIOBase_eof,
2935  PerlIOBase_error,
2936  PerlIOBase_clearerr,
2937  PerlIOBuf_setlinebuf,
2938  PerlIOMmap_get_base,
2939  PerlIOBuf_bufsiz,
2940  PerlIOBuf_get_ptr,
2941  PerlIOBuf_get_cnt,
2942  PerlIOBuf_set_ptrcnt,
2943 };
2944
2945 #endif /* HAS_MMAP */
2946
2947 void
2948 PerlIO_init(void)
2949 {
2950  if (!_perlio)
2951   {
2952    atexit(&PerlIO_cleanup);
2953   }
2954 }
2955
2956 #undef PerlIO_stdin
2957 PerlIO *
2958 PerlIO_stdin(void)
2959 {
2960  if (!_perlio)
2961   PerlIO_stdstreams();
2962  return &_perlio[1];
2963 }
2964
2965 #undef PerlIO_stdout
2966 PerlIO *
2967 PerlIO_stdout(void)
2968 {
2969  if (!_perlio)
2970   PerlIO_stdstreams();
2971  return &_perlio[2];
2972 }
2973
2974 #undef PerlIO_stderr
2975 PerlIO *
2976 PerlIO_stderr(void)
2977 {
2978  if (!_perlio)
2979   PerlIO_stdstreams();
2980  return &_perlio[3];
2981 }
2982
2983 /*--------------------------------------------------------------------------------------*/
2984
2985 #undef PerlIO_getname
2986 char *
2987 PerlIO_getname(PerlIO *f, char *buf)
2988 {
2989  dTHX;
2990  Perl_croak(aTHX_ "Don't know how to get file name");
2991  return NULL;
2992 }
2993
2994
2995 /*--------------------------------------------------------------------------------------*/
2996 /* Functions which can be called on any kind of PerlIO implemented
2997    in terms of above
2998 */
2999
3000 #undef PerlIO_getc
3001 int
3002 PerlIO_getc(PerlIO *f)
3003 {
3004  STDCHAR buf[1];
3005  SSize_t count = PerlIO_read(f,buf,1);
3006  if (count == 1)
3007   {
3008    return (unsigned char) buf[0];
3009   }
3010  return EOF;
3011 }
3012
3013 #undef PerlIO_ungetc
3014 int
3015 PerlIO_ungetc(PerlIO *f, int ch)
3016 {
3017  if (ch != EOF)
3018   {
3019    STDCHAR buf = ch;
3020    if (PerlIO_unread(f,&buf,1) == 1)
3021     return ch;
3022   }
3023  return EOF;
3024 }
3025
3026 #undef PerlIO_putc
3027 int
3028 PerlIO_putc(PerlIO *f, int ch)
3029 {
3030  STDCHAR buf = ch;
3031  return PerlIO_write(f,&buf,1);
3032 }
3033
3034 #undef PerlIO_puts
3035 int
3036 PerlIO_puts(PerlIO *f, const char *s)
3037 {
3038  STRLEN len = strlen(s);
3039  return PerlIO_write(f,s,len);
3040 }
3041
3042 #undef PerlIO_rewind
3043 void
3044 PerlIO_rewind(PerlIO *f)
3045 {
3046  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3047  PerlIO_clearerr(f);
3048 }
3049
3050 #undef PerlIO_vprintf
3051 int
3052 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3053 {
3054  dTHX;
3055  SV *sv = newSVpvn("",0);
3056  char *s;
3057  STRLEN len;
3058 #ifdef NEED_VA_COPY
3059  va_list apc;
3060  Perl_va_copy(ap, apc);
3061  sv_vcatpvf(sv, fmt, &apc);
3062 #else
3063  sv_vcatpvf(sv, fmt, &ap);
3064 #endif
3065  s = SvPV(sv,len);
3066  return PerlIO_write(f,s,len);
3067 }
3068
3069 #undef PerlIO_printf
3070 int
3071 PerlIO_printf(PerlIO *f,const char *fmt,...)
3072 {
3073  va_list ap;
3074  int result;
3075  va_start(ap,fmt);
3076  result = PerlIO_vprintf(f,fmt,ap);
3077  va_end(ap);
3078  return result;
3079 }
3080
3081 #undef PerlIO_stdoutf
3082 int
3083 PerlIO_stdoutf(const char *fmt,...)
3084 {
3085  va_list ap;
3086  int result;
3087  va_start(ap,fmt);
3088  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3089  va_end(ap);
3090  return result;
3091 }
3092
3093 #undef PerlIO_tmpfile
3094 PerlIO *
3095 PerlIO_tmpfile(void)
3096 {
3097  /* I have no idea how portable mkstemp() is ... */
3098 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3099  dTHX;
3100  PerlIO *f = NULL;
3101  FILE *stdio = PerlSIO_tmpfile();
3102  if (stdio)
3103   {
3104    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3105    s->stdio  = stdio;
3106   }
3107  return f;
3108 #else
3109  dTHX;
3110  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3111  int fd = mkstemp(SvPVX(sv));
3112  PerlIO *f = NULL;
3113  if (fd >= 0)
3114   {
3115    f = PerlIO_fdopen(fd,"w+");
3116    if (f)
3117     {
3118      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3119     }
3120    PerlLIO_unlink(SvPVX(sv));
3121    SvREFCNT_dec(sv);
3122   }
3123  return f;
3124 #endif
3125 }
3126
3127 #undef HAS_FSETPOS
3128 #undef HAS_FGETPOS
3129
3130 #endif /* USE_SFIO */
3131 #endif /* PERLIO_IS_STDIO */
3132
3133 /*======================================================================================*/
3134 /* Now some functions in terms of above which may be needed even if
3135    we are not in true PerlIO mode
3136  */
3137
3138 #ifndef HAS_FSETPOS
3139 #undef PerlIO_setpos
3140 int
3141 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3142 {
3143  return PerlIO_seek(f,*pos,0);
3144 }
3145 #else
3146 #ifndef PERLIO_IS_STDIO
3147 #undef PerlIO_setpos
3148 int
3149 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3150 {
3151 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3152  return fsetpos64(f, pos);
3153 #else
3154  return fsetpos(f, pos);
3155 #endif
3156 }
3157 #endif
3158 #endif
3159
3160 #ifndef HAS_FGETPOS
3161 #undef PerlIO_getpos
3162 int
3163 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3164 {
3165  *pos = PerlIO_tell(f);
3166  return *pos == -1 ? -1 : 0;
3167 }
3168 #else
3169 #ifndef PERLIO_IS_STDIO
3170 #undef PerlIO_getpos
3171 int
3172 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3173 {
3174 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3175  return fgetpos64(f, pos);
3176 #else
3177  return fgetpos(f, pos);
3178 #endif
3179 }
3180 #endif
3181 #endif
3182
3183 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3184
3185 int
3186 vprintf(char *pat, char *args)
3187 {
3188     _doprnt(pat, args, stdout);
3189     return 0;           /* wrong, but perl doesn't use the return value */
3190 }
3191
3192 int
3193 vfprintf(FILE *fd, char *pat, char *args)
3194 {
3195     _doprnt(pat, args, fd);
3196     return 0;           /* wrong, but perl doesn't use the return value */
3197 }
3198
3199 #endif
3200
3201 #ifndef PerlIO_vsprintf
3202 int
3203 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3204 {
3205  int val = vsprintf(s, fmt, ap);
3206  if (n >= 0)
3207   {
3208    if (strlen(s) >= (STRLEN)n)
3209     {
3210      dTHX;
3211      (void)PerlIO_puts(Perl_error_log,
3212                        "panic: sprintf overflow - memory corrupted!\n");
3213      my_exit(1);
3214     }
3215   }
3216  return val;
3217 }
3218 #endif
3219
3220 #ifndef PerlIO_sprintf
3221 int
3222 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3223 {
3224  va_list ap;
3225  int result;
3226  va_start(ap,fmt);
3227  result = PerlIO_vsprintf(s, n, fmt, ap);
3228  va_end(ap);
3229  return result;
3230 }
3231 #endif
3232
3233