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 ((SSize_t) 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  Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1302  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1303 }
1304
1305 IV
1306 PerlIOUnix_close(PerlIO *f)
1307 {
1308  dTHX;
1309  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1310  int code = 0;
1311  while (PerlLIO_close(fd) != 0)
1312   {
1313    if (errno != EINTR)
1314     {
1315      code = -1;
1316      break;
1317     }
1318   }
1319  if (code == 0)
1320   {
1321    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1322   }
1323  return code;
1324 }
1325
1326 PerlIO_funcs PerlIO_unix = {
1327  "unix",
1328  sizeof(PerlIOUnix),
1329  PERLIO_K_RAW,
1330  PerlIOUnix_fileno,
1331  PerlIOUnix_fdopen,
1332  PerlIOUnix_open,
1333  PerlIOUnix_reopen,
1334  PerlIOBase_pushed,
1335  PerlIOBase_noop_ok,
1336  PerlIOUnix_read,
1337  PerlIOBase_unread,
1338  PerlIOUnix_write,
1339  PerlIOUnix_seek,
1340  PerlIOUnix_tell,
1341  PerlIOUnix_close,
1342  PerlIOBase_noop_ok,   /* flush */
1343  PerlIOBase_noop_fail, /* fill */
1344  PerlIOBase_eof,
1345  PerlIOBase_error,
1346  PerlIOBase_clearerr,
1347  PerlIOBase_setlinebuf,
1348  NULL, /* get_base */
1349  NULL, /* get_bufsiz */
1350  NULL, /* get_ptr */
1351  NULL, /* get_cnt */
1352  NULL, /* set_ptrcnt */
1353 };
1354
1355 /*--------------------------------------------------------------------------------------*/
1356 /* stdio as a layer */
1357
1358 typedef struct
1359 {
1360  struct _PerlIO base;
1361  FILE *         stdio;      /* The stream */
1362 } PerlIOStdio;
1363
1364 IV
1365 PerlIOStdio_fileno(PerlIO *f)
1366 {
1367  dTHX;
1368  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1369 }
1370
1371 char *
1372 PerlIOStdio_mode(const char *mode,char *tmode)
1373 {
1374  char *ret = tmode;
1375  while (*mode)
1376   {
1377    *tmode++ = *mode++;
1378   }
1379  if (O_BINARY != O_TEXT)
1380   {
1381    *tmode++ = 'b';
1382   }
1383  *tmode = '\0';
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 #ifdef HAS_SOCKET
1544  int optval, optlen = sizeof(int);
1545 #endif
1546  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1547  return(
1548 #ifdef HAS_SOCKET
1549    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1550        PerlSIO_fclose(stdio) :
1551        close(PerlIO_fileno(f))
1552 #else
1553    PerlSIO_fclose(stdio)
1554 #endif
1555      );
1556
1557 }
1558
1559 IV
1560 PerlIOStdio_flush(PerlIO *f)
1561 {
1562  dTHX;
1563  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1564  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1565   {
1566    return PerlSIO_fflush(stdio);
1567   }
1568  else
1569   {
1570 #if 0
1571    /* FIXME: This discards ungetc() and pre-read stuff which is
1572       not right if this is just a "sync" from a layer above
1573       Suspect right design is to do _this_ but not have layer above
1574       flush this layer read-to-read
1575     */
1576    /* Not writeable - sync by attempting a seek */
1577    int err = errno;
1578    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1579     errno = err;
1580 #endif
1581   }
1582  return 0;
1583 }
1584
1585 IV
1586 PerlIOStdio_fill(PerlIO *f)
1587 {
1588  dTHX;
1589  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1590  int c;
1591  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1592  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1593   {
1594    if (PerlSIO_fflush(stdio) != 0)
1595     return EOF;
1596   }
1597  c = PerlSIO_fgetc(stdio);
1598  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1599   return EOF;
1600  return 0;
1601 }
1602
1603 IV
1604 PerlIOStdio_eof(PerlIO *f)
1605 {
1606  dTHX;
1607  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1608 }
1609
1610 IV
1611 PerlIOStdio_error(PerlIO *f)
1612 {
1613  dTHX;
1614  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1615 }
1616
1617 void
1618 PerlIOStdio_clearerr(PerlIO *f)
1619 {
1620  dTHX;
1621  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1622 }
1623
1624 void
1625 PerlIOStdio_setlinebuf(PerlIO *f)
1626 {
1627  dTHX;
1628 #ifdef HAS_SETLINEBUF
1629  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1630 #else
1631  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1632 #endif
1633 }
1634
1635 #ifdef FILE_base
1636 STDCHAR *
1637 PerlIOStdio_get_base(PerlIO *f)
1638 {
1639  dTHX;
1640  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1641  return PerlSIO_get_base(stdio);
1642 }
1643
1644 Size_t
1645 PerlIOStdio_get_bufsiz(PerlIO *f)
1646 {
1647  dTHX;
1648  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1649  return PerlSIO_get_bufsiz(stdio);
1650 }
1651 #endif
1652
1653 #ifdef USE_STDIO_PTR
1654 STDCHAR *
1655 PerlIOStdio_get_ptr(PerlIO *f)
1656 {
1657  dTHX;
1658  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1659  return PerlSIO_get_ptr(stdio);
1660 }
1661
1662 SSize_t
1663 PerlIOStdio_get_cnt(PerlIO *f)
1664 {
1665  dTHX;
1666  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1667  return PerlSIO_get_cnt(stdio);
1668 }
1669
1670 void
1671 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1672 {
1673  dTHX;
1674  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1675  if (ptr != NULL)
1676   {
1677 #ifdef STDIO_PTR_LVALUE
1678    PerlSIO_set_ptr(stdio,ptr);
1679 #ifdef STDIO_PTR_LVAL_SETS_CNT
1680    if (PerlSIO_get_cnt(stdio) != (cnt))
1681     {
1682      dTHX;
1683      assert(PerlSIO_get_cnt(stdio) == (cnt));
1684     }
1685 #endif
1686 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1687    /* Setting ptr _does_ change cnt - we are done */
1688    return;
1689 #endif
1690 #else  /* STDIO_PTR_LVALUE */
1691    PerlProc_abort();
1692 #endif /* STDIO_PTR_LVALUE */
1693   }
1694 /* Now (or only) set cnt */
1695 #ifdef STDIO_CNT_LVALUE
1696  PerlSIO_set_cnt(stdio,cnt);
1697 #else  /* STDIO_CNT_LVALUE */
1698 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1699  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1700 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1701  PerlProc_abort();
1702 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1703 #endif /* STDIO_CNT_LVALUE */
1704 }
1705
1706 #endif
1707
1708 PerlIO_funcs PerlIO_stdio = {
1709  "stdio",
1710  sizeof(PerlIOStdio),
1711  PERLIO_K_BUFFERED,
1712  PerlIOStdio_fileno,
1713  PerlIOStdio_fdopen,
1714  PerlIOStdio_open,
1715  PerlIOStdio_reopen,
1716  PerlIOBase_pushed,
1717  PerlIOBase_noop_ok,
1718  PerlIOStdio_read,
1719  PerlIOStdio_unread,
1720  PerlIOStdio_write,
1721  PerlIOStdio_seek,
1722  PerlIOStdio_tell,
1723  PerlIOStdio_close,
1724  PerlIOStdio_flush,
1725  PerlIOStdio_fill,
1726  PerlIOStdio_eof,
1727  PerlIOStdio_error,
1728  PerlIOStdio_clearerr,
1729  PerlIOStdio_setlinebuf,
1730 #ifdef FILE_base
1731  PerlIOStdio_get_base,
1732  PerlIOStdio_get_bufsiz,
1733 #else
1734  NULL,
1735  NULL,
1736 #endif
1737 #ifdef USE_STDIO_PTR
1738  PerlIOStdio_get_ptr,
1739  PerlIOStdio_get_cnt,
1740 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1741  PerlIOStdio_set_ptrcnt
1742 #else  /* STDIO_PTR_LVALUE */
1743  NULL
1744 #endif /* STDIO_PTR_LVALUE */
1745 #else  /* USE_STDIO_PTR */
1746  NULL,
1747  NULL,
1748  NULL
1749 #endif /* USE_STDIO_PTR */
1750 };
1751
1752 #undef PerlIO_exportFILE
1753 FILE *
1754 PerlIO_exportFILE(PerlIO *f, int fl)
1755 {
1756  PerlIO_flush(f);
1757  /* Should really push stdio discipline when we have them */
1758  return fdopen(PerlIO_fileno(f),"r+");
1759 }
1760
1761 #undef PerlIO_findFILE
1762 FILE *
1763 PerlIO_findFILE(PerlIO *f)
1764 {
1765  return PerlIO_exportFILE(f,0);
1766 }
1767
1768 #undef PerlIO_releaseFILE
1769 void
1770 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1771 {
1772 }
1773
1774 /*--------------------------------------------------------------------------------------*/
1775 /* perlio buffer layer */
1776
1777 IV
1778 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1779 {
1780  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1781  b->posn = PerlIO_tell(PerlIONext(f));
1782  return PerlIOBase_pushed(f,mode);
1783 }
1784
1785 PerlIO *
1786 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1787 {
1788  dTHX;
1789  PerlIO_funcs *tab = PerlIO_default_btm();
1790  int init = 0;
1791  PerlIO *f;
1792  if (*mode == 'I')
1793   {
1794    init = 1;
1795    mode++;
1796   }
1797 #if O_BINARY != O_TEXT
1798  /* do something about failing setmode()? --jhi */
1799  PerlLIO_setmode(fd, O_BINARY);
1800 #endif
1801  f = (*tab->Fdopen)(tab,fd,mode);
1802  if (f)
1803   {
1804    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1805    if (init && fd == 2)
1806     {
1807      /* Initial stderr is unbuffered */
1808      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1809     }
1810 #if 0
1811    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1812                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1813 #endif
1814   }
1815  return f;
1816 }
1817
1818 PerlIO *
1819 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1820 {
1821  PerlIO_funcs *tab = PerlIO_default_btm();
1822  PerlIO *f = (*tab->Open)(tab,path,mode);
1823  if (f)
1824   {
1825    PerlIO_push(f,self,mode);
1826   }
1827  return f;
1828 }
1829
1830 int
1831 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1832 {
1833  PerlIO *next = PerlIONext(f);
1834  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1835  if (code = 0)
1836   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1837  return code;
1838 }
1839
1840 /* This "flush" is akin to sfio's sync in that it handles files in either
1841    read or write state
1842 */
1843 IV
1844 PerlIOBuf_flush(PerlIO *f)
1845 {
1846  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1847  int code = 0;
1848  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1849   {
1850    /* write() the buffer */
1851    STDCHAR *p = b->buf;
1852    int count;
1853    PerlIO *n = PerlIONext(f);
1854    while (p < b->ptr)
1855     {
1856      count = PerlIO_write(n,p,b->ptr - p);
1857      if (count > 0)
1858       {
1859        p += count;
1860       }
1861      else if (count < 0 || PerlIO_error(n))
1862       {
1863        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1864        code = -1;
1865        break;
1866       }
1867     }
1868    b->posn += (p - b->buf);
1869   }
1870  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1871   {
1872    /* Note position change */
1873    b->posn += (b->ptr - b->buf);
1874    if (b->ptr < b->end)
1875     {
1876      /* We did not consume all of it */
1877      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1878       {
1879        b->posn = PerlIO_tell(PerlIONext(f));
1880       }
1881     }
1882   }
1883  b->ptr = b->end = b->buf;
1884  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1885  /* FIXME: Is this right for read case ? */
1886  if (PerlIO_flush(PerlIONext(f)) != 0)
1887   code = -1;
1888  return code;
1889 }
1890
1891 IV
1892 PerlIOBuf_fill(PerlIO *f)
1893 {
1894  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1895  PerlIO *n = PerlIONext(f);
1896  SSize_t avail;
1897  /* FIXME: doing the down-stream flush is a bad idea if it causes
1898     pre-read data in stdio buffer to be discarded
1899     but this is too simplistic - as it skips _our_ hosekeeping
1900     and breaks tell tests.
1901  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1902   {
1903   }
1904   */
1905  if (PerlIO_flush(f) != 0)
1906   return -1;
1907
1908  b->ptr = b->end = b->buf;
1909  if (PerlIO_fast_gets(n))
1910   {
1911    /* Layer below is also buffered
1912     * We do _NOT_ want to call its ->Read() because that will loop
1913     * till it gets what we asked for which may hang on a pipe etc.
1914     * Instead take anything it has to hand, or ask it to fill _once_.
1915     */
1916    avail  = PerlIO_get_cnt(n);
1917    if (avail <= 0)
1918     {
1919      avail = PerlIO_fill(n);
1920      if (avail == 0)
1921       avail = PerlIO_get_cnt(n);
1922      else
1923       {
1924        if (!PerlIO_error(n) && PerlIO_eof(n))
1925         avail = 0;
1926       }
1927     }
1928    if (avail > 0)
1929     {
1930      STDCHAR *ptr = PerlIO_get_ptr(n);
1931      SSize_t cnt  = avail;
1932      if (avail > b->bufsiz)
1933       avail = b->bufsiz;
1934      Copy(ptr,b->buf,avail,STDCHAR);
1935      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1936     }
1937   }
1938  else
1939   {
1940    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1941   }
1942  if (avail <= 0)
1943   {
1944    if (avail == 0)
1945     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1946    else
1947     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1948    return -1;
1949   }
1950  b->end      = b->buf+avail;
1951  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1952  return 0;
1953 }
1954
1955 SSize_t
1956 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1957 {
1958  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1959  STDCHAR *buf  = (STDCHAR *) vbuf;
1960  if (f)
1961   {
1962    if (!b->ptr)
1963     PerlIO_get_base(f);
1964    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1965     return 0;
1966    while (count > 0)
1967     {
1968      SSize_t avail = PerlIO_get_cnt(f);
1969      SSize_t take  = (count < avail) ? count : avail;
1970      if (take > 0)
1971       {
1972        STDCHAR *ptr = PerlIO_get_ptr(f);
1973        Copy(ptr,buf,take,STDCHAR);
1974        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1975        count   -= take;
1976        buf     += take;
1977       }
1978      if (count > 0  && avail <= 0)
1979       {
1980        if (PerlIO_fill(f) != 0)
1981         break;
1982       }
1983     }
1984    return (buf - (STDCHAR *) vbuf);
1985   }
1986  return 0;
1987 }
1988
1989 SSize_t
1990 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1991 {
1992  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1993  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1994  SSize_t unread = 0;
1995  SSize_t avail;
1996  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1997   PerlIO_flush(f);
1998  if (!b->buf)
1999   PerlIO_get_base(f);
2000  if (b->buf)
2001   {
2002    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2003     {
2004      avail = (b->ptr - b->buf);
2005     }
2006    else
2007     {
2008      avail = b->bufsiz;
2009      b->end = b->buf + avail;
2010      b->ptr = b->end;
2011      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2012      b->posn -= b->bufsiz;
2013     }
2014    if (avail > (SSize_t) count)
2015     avail = count;
2016    if (avail > 0)
2017     {
2018      b->ptr -= avail;
2019      buf    -= avail;
2020      if (buf != b->ptr)
2021       {
2022        Copy(buf,b->ptr,avail,STDCHAR);
2023       }
2024      count  -= avail;
2025      unread += avail;
2026      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2027     }
2028   }
2029  return unread;
2030 }
2031
2032 SSize_t
2033 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2034 {
2035  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2036  const STDCHAR *buf = (const STDCHAR *) vbuf;
2037  Size_t written = 0;
2038  if (!b->buf)
2039   PerlIO_get_base(f);
2040  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2041   return 0;
2042  while (count > 0)
2043   {
2044    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2045    if ((SSize_t) count < avail)
2046     avail = count;
2047    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2048    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2049     {
2050      while (avail > 0)
2051       {
2052        int ch = *buf++;
2053        *(b->ptr)++ = ch;
2054        count--;
2055        avail--;
2056        written++;
2057        if (ch == '\n')
2058         {
2059          PerlIO_flush(f);
2060          break;
2061         }
2062       }
2063     }
2064    else
2065     {
2066      if (avail)
2067       {
2068        Copy(buf,b->ptr,avail,STDCHAR);
2069        count   -= avail;
2070        buf     += avail;
2071        written += avail;
2072        b->ptr  += avail;
2073       }
2074     }
2075    if (b->ptr >= (b->buf + b->bufsiz))
2076     PerlIO_flush(f);
2077   }
2078  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2079   PerlIO_flush(f);
2080  return written;
2081 }
2082
2083 IV
2084 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2085 {
2086  IV code;
2087  if ((code = PerlIO_flush(f)) == 0)
2088   {
2089    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2090    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2091    code = PerlIO_seek(PerlIONext(f),offset,whence);
2092    if (code == 0)
2093     {
2094      b->posn = PerlIO_tell(PerlIONext(f));
2095     }
2096   }
2097  return code;
2098 }
2099
2100 Off_t
2101 PerlIOBuf_tell(PerlIO *f)
2102 {
2103  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2104  Off_t posn = b->posn;
2105  if (b->buf)
2106   posn += (b->ptr - b->buf);
2107  return posn;
2108 }
2109
2110 IV
2111 PerlIOBuf_close(PerlIO *f)
2112 {
2113  dTHX;
2114  IV code = PerlIOBase_close(f);
2115  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2116  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2117   {
2118    PerlMemShared_free(b->buf);
2119   }
2120  b->buf = NULL;
2121  b->ptr = b->end = b->buf;
2122  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2123  return code;
2124 }
2125
2126 void
2127 PerlIOBuf_setlinebuf(PerlIO *f)
2128 {
2129  if (f)
2130   {
2131    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2132   }
2133 }
2134
2135 STDCHAR *
2136 PerlIOBuf_get_ptr(PerlIO *f)
2137 {
2138  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2139  if (!b->buf)
2140   PerlIO_get_base(f);
2141  return b->ptr;
2142 }
2143
2144 SSize_t
2145 PerlIOBuf_get_cnt(PerlIO *f)
2146 {
2147  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2148  if (!b->buf)
2149   PerlIO_get_base(f);
2150  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2151   return (b->end - b->ptr);
2152  return 0;
2153 }
2154
2155 STDCHAR *
2156 PerlIOBuf_get_base(PerlIO *f)
2157 {
2158  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2159  if (!b->buf)
2160   {
2161    dTHX;
2162    if (!b->bufsiz)
2163     b->bufsiz = 4096;
2164    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2165    if (!b->buf)
2166     {
2167      b->buf = (STDCHAR *)&b->oneword;
2168      b->bufsiz = sizeof(b->oneword);
2169     }
2170    b->ptr = b->buf;
2171    b->end = b->ptr;
2172   }
2173  return b->buf;
2174 }
2175
2176 Size_t
2177 PerlIOBuf_bufsiz(PerlIO *f)
2178 {
2179  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2180  if (!b->buf)
2181   PerlIO_get_base(f);
2182  return (b->end - b->buf);
2183 }
2184
2185 void
2186 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2187 {
2188  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2189  if (!b->buf)
2190   PerlIO_get_base(f);
2191  b->ptr = ptr;
2192  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2193   {
2194    dTHX;
2195    assert(PerlIO_get_cnt(f) == cnt);
2196    assert(b->ptr >= b->buf);
2197   }
2198  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2199 }
2200
2201 PerlIO_funcs PerlIO_perlio = {
2202  "perlio",
2203  sizeof(PerlIOBuf),
2204  PERLIO_K_BUFFERED,
2205  PerlIOBase_fileno,
2206  PerlIOBuf_fdopen,
2207  PerlIOBuf_open,
2208  PerlIOBuf_reopen,
2209  PerlIOBuf_pushed,
2210  PerlIOBase_noop_ok,
2211  PerlIOBuf_read,
2212  PerlIOBuf_unread,
2213  PerlIOBuf_write,
2214  PerlIOBuf_seek,
2215  PerlIOBuf_tell,
2216  PerlIOBuf_close,
2217  PerlIOBuf_flush,
2218  PerlIOBuf_fill,
2219  PerlIOBase_eof,
2220  PerlIOBase_error,
2221  PerlIOBase_clearerr,
2222  PerlIOBuf_setlinebuf,
2223  PerlIOBuf_get_base,
2224  PerlIOBuf_bufsiz,
2225  PerlIOBuf_get_ptr,
2226  PerlIOBuf_get_cnt,
2227  PerlIOBuf_set_ptrcnt,
2228 };
2229
2230 /*--------------------------------------------------------------------------------------*/
2231 /* Temp layer to hold unread chars when cannot do it any other way */
2232
2233 IV
2234 PerlIOPending_fill(PerlIO *f)
2235 {
2236  /* Should never happen */
2237  PerlIO_flush(f);
2238  return 0;
2239 }
2240
2241 IV
2242 PerlIOPending_close(PerlIO *f)
2243 {
2244  /* A tad tricky - flush pops us, then we close new top */
2245  PerlIO_flush(f);
2246  return PerlIO_close(f);
2247 }
2248
2249 IV
2250 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2251 {
2252  /* A tad tricky - flush pops us, then we seek new top */
2253  PerlIO_flush(f);
2254  return PerlIO_seek(f,offset,whence);
2255 }
2256
2257
2258 IV
2259 PerlIOPending_flush(PerlIO *f)
2260 {
2261  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2262  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2263   {
2264    dTHX;
2265    PerlMemShared_free(b->buf);
2266    b->buf = NULL;
2267   }
2268  PerlIO_pop(f);
2269  return 0;
2270 }
2271
2272 void
2273 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2274 {
2275  if (cnt <= 0)
2276   {
2277    PerlIO_flush(f);
2278   }
2279  else
2280   {
2281    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2282   }
2283 }
2284
2285 IV
2286 PerlIOPending_pushed(PerlIO *f,const char *mode)
2287 {
2288  IV code    = PerlIOBuf_pushed(f,mode);
2289  PerlIOl *l = PerlIOBase(f);
2290  /* Our PerlIO_fast_gets must match what we are pushed on,
2291     or sv_gets() etc. get muddled when it changes mid-string
2292     when we auto-pop.
2293   */
2294  l->flags   = (l->flags & ~PERLIO_F_FASTGETS) |
2295               (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2296  return code;
2297 }
2298
2299 SSize_t
2300 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2301 {
2302  SSize_t avail = PerlIO_get_cnt(f);
2303  SSize_t got   = 0;
2304  if (count < avail)
2305   avail = count;
2306  if (avail > 0)
2307   got = PerlIOBuf_read(f,vbuf,avail);
2308  if (got < count)
2309   got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2310  return got;
2311 }
2312
2313
2314 PerlIO_funcs PerlIO_pending = {
2315  "pending",
2316  sizeof(PerlIOBuf),
2317  PERLIO_K_BUFFERED,
2318  PerlIOBase_fileno,
2319  NULL,
2320  NULL,
2321  NULL,
2322  PerlIOPending_pushed,
2323  PerlIOBase_noop_ok,
2324  PerlIOPending_read,
2325  PerlIOBuf_unread,
2326  PerlIOBuf_write,
2327  PerlIOPending_seek,
2328  PerlIOBuf_tell,
2329  PerlIOPending_close,
2330  PerlIOPending_flush,
2331  PerlIOPending_fill,
2332  PerlIOBase_eof,
2333  PerlIOBase_error,
2334  PerlIOBase_clearerr,
2335  PerlIOBuf_setlinebuf,
2336  PerlIOBuf_get_base,
2337  PerlIOBuf_bufsiz,
2338  PerlIOBuf_get_ptr,
2339  PerlIOBuf_get_cnt,
2340  PerlIOPending_set_ptrcnt,
2341 };
2342
2343
2344
2345 /*--------------------------------------------------------------------------------------*/
2346 /* crlf - translation
2347    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2348    to hand back a line at a time and keeping a record of which nl we "lied" about.
2349    On write translate "\n" to CR,LF
2350  */
2351
2352 typedef struct
2353 {
2354  PerlIOBuf      base;         /* PerlIOBuf stuff */
2355  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2356 } PerlIOCrlf;
2357
2358 IV
2359 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2360 {
2361  IV code;
2362  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2363  code = PerlIOBuf_pushed(f,mode);
2364 #if 0
2365  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2366               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2367               PerlIOBase(f)->flags);
2368 #endif
2369  return code;
2370 }
2371
2372
2373 SSize_t
2374 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2375 {
2376  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2377  if (c->nl)
2378   {
2379    *(c->nl) = 0xd;
2380    c->nl = NULL;
2381   }
2382  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2383   return PerlIOBuf_unread(f,vbuf,count);
2384  else
2385   {
2386    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2387    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2388    SSize_t unread = 0;
2389    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2390     PerlIO_flush(f);
2391    if (!b->buf)
2392     PerlIO_get_base(f);
2393    if (b->buf)
2394     {
2395      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2396       {
2397        b->end = b->ptr = b->buf + b->bufsiz;
2398        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2399        b->posn -= b->bufsiz;
2400       }
2401      while (count > 0 && b->ptr > b->buf)
2402       {
2403        int ch = *--buf;
2404        if (ch == '\n')
2405         {
2406          if (b->ptr - 2 >= b->buf)
2407           {
2408            *--(b->ptr) = 0xa;
2409            *--(b->ptr) = 0xd;
2410            unread++;
2411            count--;
2412           }
2413          else
2414           {
2415            buf++;
2416            break;
2417           }
2418         }
2419        else
2420         {
2421          *--(b->ptr) = ch;
2422          unread++;
2423          count--;
2424         }
2425       }
2426     }
2427    return unread;
2428   }
2429 }
2430
2431 SSize_t
2432 PerlIOCrlf_get_cnt(PerlIO *f)
2433 {
2434  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2435  if (!b->buf)
2436   PerlIO_get_base(f);
2437  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2438   {
2439    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2440    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2441     {
2442      STDCHAR *nl   = b->ptr;
2443     scan:
2444      while (nl < b->end && *nl != 0xd)
2445       nl++;
2446      if (nl < b->end && *nl == 0xd)
2447       {
2448      test:
2449        if (nl+1 < b->end)
2450         {
2451          if (nl[1] == 0xa)
2452           {
2453            *nl   = '\n';
2454            c->nl = nl;
2455           }
2456          else
2457           {
2458            /* Not CR,LF but just CR */
2459            nl++;
2460            goto scan;
2461           }
2462         }
2463        else
2464         {
2465          /* Blast - found CR as last char in buffer */
2466          if (b->ptr < nl)
2467           {
2468            /* They may not care, defer work as long as possible */
2469            return (nl - b->ptr);
2470           }
2471          else
2472           {
2473            int code;
2474            dTHX;
2475            b->ptr++;               /* say we have read it as far as flush() is concerned */
2476            b->buf++;               /* Leave space an front of buffer */
2477            b->bufsiz--;            /* Buffer is thus smaller */
2478            code = PerlIO_fill(f);  /* Fetch some more */
2479            b->bufsiz++;            /* Restore size for next time */
2480            b->buf--;               /* Point at space */
2481            b->ptr = nl = b->buf;   /* Which is what we hand off */
2482            b->posn--;              /* Buffer starts here */
2483            *nl = 0xd;              /* Fill in the CR */
2484            if (code == 0)
2485             goto test;             /* fill() call worked */
2486            /* CR at EOF - just fall through */
2487           }
2488         }
2489       }
2490     }
2491    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2492   }
2493  return 0;
2494 }
2495
2496 void
2497 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2498 {
2499  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2500  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2501  IV flags = PerlIOBase(f)->flags;
2502  if (!b->buf)
2503   PerlIO_get_base(f);
2504  if (!ptr)
2505   {
2506    if (c->nl)
2507     ptr = c->nl+1;
2508    else
2509     {
2510      ptr = b->end;
2511      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2512       ptr--;
2513     }
2514    ptr -= cnt;
2515   }
2516  else
2517   {
2518    /* Test code - delete when it works ... */
2519    STDCHAR *chk;
2520    if (c->nl)
2521     chk = c->nl+1;
2522    else
2523     {
2524      chk = b->end;
2525      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2526       chk--;
2527     }
2528    chk -= cnt;
2529
2530    if (ptr != chk)
2531     {
2532      dTHX;
2533      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2534                 ptr, chk, flags, c->nl, b->end, cnt);
2535     }
2536   }
2537  if (c->nl)
2538   {
2539    if (ptr > c->nl)
2540     {
2541      /* They have taken what we lied about */
2542      *(c->nl) = 0xd;
2543      c->nl = NULL;
2544      ptr++;
2545     }
2546   }
2547  b->ptr = ptr;
2548  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2549 }
2550
2551 SSize_t
2552 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2553 {
2554  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2555   return PerlIOBuf_write(f,vbuf,count);
2556  else
2557   {
2558    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2559    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2560    const STDCHAR *ebuf = buf+count;
2561    if (!b->buf)
2562     PerlIO_get_base(f);
2563    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2564     return 0;
2565    while (buf < ebuf)
2566     {
2567      STDCHAR *eptr = b->buf+b->bufsiz;
2568      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2569      while (buf < ebuf && b->ptr < eptr)
2570       {
2571        if (*buf == '\n')
2572         {
2573          if ((b->ptr + 2) > eptr)
2574           {
2575            /* Not room for both */
2576            PerlIO_flush(f);
2577            break;
2578           }
2579          else
2580           {
2581            *(b->ptr)++ = 0xd; /* CR */
2582            *(b->ptr)++ = 0xa; /* LF */
2583            buf++;
2584            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2585             {
2586              PerlIO_flush(f);
2587              break;
2588             }
2589           }
2590         }
2591        else
2592         {
2593          int ch = *buf++;
2594          *(b->ptr)++ = ch;
2595         }
2596        if (b->ptr >= eptr)
2597         {
2598          PerlIO_flush(f);
2599          break;
2600         }
2601       }
2602     }
2603    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2604     PerlIO_flush(f);
2605    return (buf - (STDCHAR *) vbuf);
2606   }
2607 }
2608
2609 IV
2610 PerlIOCrlf_flush(PerlIO *f)
2611 {
2612  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2613  if (c->nl)
2614   {
2615    *(c->nl) = 0xd;
2616    c->nl = NULL;
2617   }
2618  return PerlIOBuf_flush(f);
2619 }
2620
2621 PerlIO_funcs PerlIO_crlf = {
2622  "crlf",
2623  sizeof(PerlIOCrlf),
2624  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2625  PerlIOBase_fileno,
2626  PerlIOBuf_fdopen,
2627  PerlIOBuf_open,
2628  PerlIOBuf_reopen,
2629  PerlIOCrlf_pushed,
2630  PerlIOBase_noop_ok,   /* popped */
2631  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2632  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2633  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2634  PerlIOBuf_seek,
2635  PerlIOBuf_tell,
2636  PerlIOBuf_close,
2637  PerlIOCrlf_flush,
2638  PerlIOBuf_fill,
2639  PerlIOBase_eof,
2640  PerlIOBase_error,
2641  PerlIOBase_clearerr,
2642  PerlIOBuf_setlinebuf,
2643  PerlIOBuf_get_base,
2644  PerlIOBuf_bufsiz,
2645  PerlIOBuf_get_ptr,
2646  PerlIOCrlf_get_cnt,
2647  PerlIOCrlf_set_ptrcnt,
2648 };
2649
2650 #ifdef HAS_MMAP
2651 /*--------------------------------------------------------------------------------------*/
2652 /* mmap as "buffer" layer */
2653
2654 typedef struct
2655 {
2656  PerlIOBuf      base;         /* PerlIOBuf stuff */
2657  Mmap_t         mptr;        /* Mapped address */
2658  Size_t         len;          /* mapped length */
2659  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2660 } PerlIOMmap;
2661
2662 static size_t page_size = 0;
2663
2664 IV
2665 PerlIOMmap_map(PerlIO *f)
2666 {
2667  dTHX;
2668  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2669  PerlIOBuf  *b = &m->base;
2670  IV flags = PerlIOBase(f)->flags;
2671  IV code  = 0;
2672  if (m->len)
2673   abort();
2674  if (flags & PERLIO_F_CANREAD)
2675   {
2676    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2677    int fd   = PerlIO_fileno(f);
2678    struct stat st;
2679    code = fstat(fd,&st);
2680    if (code == 0 && S_ISREG(st.st_mode))
2681     {
2682      SSize_t len = st.st_size - b->posn;
2683      if (len > 0)
2684       {
2685        Off_t posn;
2686        if (!page_size) {
2687 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2688            {
2689                SETERRNO(0,SS$_NORMAL);
2690 #   ifdef _SC_PAGESIZE
2691                page_size = sysconf(_SC_PAGESIZE);
2692 #   else
2693                page_size = sysconf(_SC_PAGE_SIZE);
2694 #   endif
2695                if ((long)page_size < 0) {
2696                    if (errno) {
2697                        SV *error = ERRSV;
2698                        char *msg;
2699                        STRLEN n_a;
2700                        (void)SvUPGRADE(error, SVt_PV);
2701                        msg = SvPVx(error, n_a);
2702                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2703                    }
2704                    else
2705                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2706                }
2707            }
2708 #else
2709 #   ifdef HAS_GETPAGESIZE
2710         page_size = getpagesize();
2711 #   else
2712 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2713         page_size = PAGESIZE; /* compiletime, bad */
2714 #       endif
2715 #   endif
2716 #endif
2717         if ((IV)page_size <= 0)
2718             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2719        }
2720        if (b->posn < 0)
2721         {
2722          /* This is a hack - should never happen - open should have set it ! */
2723          b->posn = PerlIO_tell(PerlIONext(f));
2724         }
2725        posn = (b->posn / page_size) * page_size;
2726        len  = st.st_size - posn;
2727        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2728        if (m->mptr && m->mptr != (Mmap_t) -1)
2729         {
2730 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2731          madvise(m->mptr, len, MADV_SEQUENTIAL);
2732 #endif
2733          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2734          b->end  = ((STDCHAR *)m->mptr) + len;
2735          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2736          b->ptr  = b->buf;
2737          m->len  = len;
2738         }
2739        else
2740         {
2741          b->buf = NULL;
2742         }
2743       }
2744      else
2745       {
2746        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2747        b->buf = NULL;
2748        b->ptr = b->end = b->ptr;
2749        code = -1;
2750       }
2751     }
2752   }
2753  return code;
2754 }
2755
2756 IV
2757 PerlIOMmap_unmap(PerlIO *f)
2758 {
2759  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2760  PerlIOBuf  *b = &m->base;
2761  IV code = 0;
2762  if (m->len)
2763   {
2764    if (b->buf)
2765     {
2766      code = munmap(m->mptr, m->len);
2767      b->buf  = NULL;
2768      m->len  = 0;
2769      m->mptr = NULL;
2770      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2771       code = -1;
2772     }
2773    b->ptr = b->end = b->buf;
2774    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2775   }
2776  return code;
2777 }
2778
2779 STDCHAR *
2780 PerlIOMmap_get_base(PerlIO *f)
2781 {
2782  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2783  PerlIOBuf  *b = &m->base;
2784  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2785   {
2786    /* Already have a readbuffer in progress */
2787    return b->buf;
2788   }
2789  if (b->buf)
2790   {
2791    /* We have a write buffer or flushed PerlIOBuf read buffer */
2792    m->bbuf = b->buf;  /* save it in case we need it again */
2793    b->buf  = NULL;    /* Clear to trigger below */
2794   }
2795  if (!b->buf)
2796   {
2797    PerlIOMmap_map(f);     /* Try and map it */
2798    if (!b->buf)
2799     {
2800      /* Map did not work - recover PerlIOBuf buffer if we have one */
2801      b->buf = m->bbuf;
2802     }
2803   }
2804  b->ptr  = b->end = b->buf;
2805  if (b->buf)
2806   return b->buf;
2807  return PerlIOBuf_get_base(f);
2808 }
2809
2810 SSize_t
2811 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2812 {
2813  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2814  PerlIOBuf  *b = &m->base;
2815  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2816   PerlIO_flush(f);
2817  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2818   {
2819    b->ptr -= count;
2820    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2821    return count;
2822   }
2823  if (m->len)
2824   {
2825    /* Loose the unwritable mapped buffer */
2826    PerlIO_flush(f);
2827    /* If flush took the "buffer" see if we have one from before */
2828    if (!b->buf && m->bbuf)
2829     b->buf = m->bbuf;
2830    if (!b->buf)
2831     {
2832      PerlIOBuf_get_base(f);
2833      m->bbuf = b->buf;
2834     }
2835   }
2836 return PerlIOBuf_unread(f,vbuf,count);
2837 }
2838
2839 SSize_t
2840 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2841 {
2842  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2843  PerlIOBuf  *b = &m->base;
2844  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2845   {
2846    /* No, or wrong sort of, buffer */
2847    if (m->len)
2848     {
2849      if (PerlIOMmap_unmap(f) != 0)
2850       return 0;
2851     }
2852    /* If unmap took the "buffer" see if we have one from before */
2853    if (!b->buf && m->bbuf)
2854     b->buf = m->bbuf;
2855    if (!b->buf)
2856     {
2857      PerlIOBuf_get_base(f);
2858      m->bbuf = b->buf;
2859     }
2860   }
2861  return PerlIOBuf_write(f,vbuf,count);
2862 }
2863
2864 IV
2865 PerlIOMmap_flush(PerlIO *f)
2866 {
2867  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2868  PerlIOBuf  *b = &m->base;
2869  IV code = PerlIOBuf_flush(f);
2870  /* Now we are "synced" at PerlIOBuf level */
2871  if (b->buf)
2872   {
2873    if (m->len)
2874     {
2875      /* Unmap the buffer */
2876      if (PerlIOMmap_unmap(f) != 0)
2877       code = -1;
2878     }
2879    else
2880     {
2881      /* We seem to have a PerlIOBuf buffer which was not mapped
2882       * remember it in case we need one later
2883       */
2884      m->bbuf = b->buf;
2885     }
2886   }
2887  return code;
2888 }
2889
2890 IV
2891 PerlIOMmap_fill(PerlIO *f)
2892 {
2893  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2894  IV code = PerlIO_flush(f);
2895  if (code == 0 && !b->buf)
2896   {
2897    code = PerlIOMmap_map(f);
2898   }
2899  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2900   {
2901    code = PerlIOBuf_fill(f);
2902   }
2903  return code;
2904 }
2905
2906 IV
2907 PerlIOMmap_close(PerlIO *f)
2908 {
2909  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2910  PerlIOBuf  *b = &m->base;
2911  IV code = PerlIO_flush(f);
2912  if (m->bbuf)
2913   {
2914    b->buf  = m->bbuf;
2915    m->bbuf = NULL;
2916    b->ptr  = b->end = b->buf;
2917   }
2918  if (PerlIOBuf_close(f) != 0)
2919   code = -1;
2920  return code;
2921 }
2922
2923
2924 PerlIO_funcs PerlIO_mmap = {
2925  "mmap",
2926  sizeof(PerlIOMmap),
2927  PERLIO_K_BUFFERED,
2928  PerlIOBase_fileno,
2929  PerlIOBuf_fdopen,
2930  PerlIOBuf_open,
2931  PerlIOBuf_reopen,
2932  PerlIOBuf_pushed,
2933  PerlIOBase_noop_ok,
2934  PerlIOBuf_read,
2935  PerlIOMmap_unread,
2936  PerlIOMmap_write,
2937  PerlIOBuf_seek,
2938  PerlIOBuf_tell,
2939  PerlIOBuf_close,
2940  PerlIOMmap_flush,
2941  PerlIOMmap_fill,
2942  PerlIOBase_eof,
2943  PerlIOBase_error,
2944  PerlIOBase_clearerr,
2945  PerlIOBuf_setlinebuf,
2946  PerlIOMmap_get_base,
2947  PerlIOBuf_bufsiz,
2948  PerlIOBuf_get_ptr,
2949  PerlIOBuf_get_cnt,
2950  PerlIOBuf_set_ptrcnt,
2951 };
2952
2953 #endif /* HAS_MMAP */
2954
2955 void
2956 PerlIO_init(void)
2957 {
2958  if (!_perlio)
2959   {
2960 #ifndef WIN32
2961    atexit(&PerlIO_cleanup);
2962 #endif
2963   }
2964 }
2965
2966 #undef PerlIO_stdin
2967 PerlIO *
2968 PerlIO_stdin(void)
2969 {
2970  if (!_perlio)
2971   PerlIO_stdstreams();
2972  return &_perlio[1];
2973 }
2974
2975 #undef PerlIO_stdout
2976 PerlIO *
2977 PerlIO_stdout(void)
2978 {
2979  if (!_perlio)
2980   PerlIO_stdstreams();
2981  return &_perlio[2];
2982 }
2983
2984 #undef PerlIO_stderr
2985 PerlIO *
2986 PerlIO_stderr(void)
2987 {
2988  if (!_perlio)
2989   PerlIO_stdstreams();
2990  return &_perlio[3];
2991 }
2992
2993 /*--------------------------------------------------------------------------------------*/
2994
2995 #undef PerlIO_getname
2996 char *
2997 PerlIO_getname(PerlIO *f, char *buf)
2998 {
2999  dTHX;
3000  Perl_croak(aTHX_ "Don't know how to get file name");
3001  return NULL;
3002 }
3003
3004
3005 /*--------------------------------------------------------------------------------------*/
3006 /* Functions which can be called on any kind of PerlIO implemented
3007    in terms of above
3008 */
3009
3010 #undef PerlIO_getc
3011 int
3012 PerlIO_getc(PerlIO *f)
3013 {
3014  STDCHAR buf[1];
3015  SSize_t count = PerlIO_read(f,buf,1);
3016  if (count == 1)
3017   {
3018    return (unsigned char) buf[0];
3019   }
3020  return EOF;
3021 }
3022
3023 #undef PerlIO_ungetc
3024 int
3025 PerlIO_ungetc(PerlIO *f, int ch)
3026 {
3027  if (ch != EOF)
3028   {
3029    STDCHAR buf = ch;
3030    if (PerlIO_unread(f,&buf,1) == 1)
3031     return ch;
3032   }
3033  return EOF;
3034 }
3035
3036 #undef PerlIO_putc
3037 int
3038 PerlIO_putc(PerlIO *f, int ch)
3039 {
3040  STDCHAR buf = ch;
3041  return PerlIO_write(f,&buf,1);
3042 }
3043
3044 #undef PerlIO_puts
3045 int
3046 PerlIO_puts(PerlIO *f, const char *s)
3047 {
3048  STRLEN len = strlen(s);
3049  return PerlIO_write(f,s,len);
3050 }
3051
3052 #undef PerlIO_rewind
3053 void
3054 PerlIO_rewind(PerlIO *f)
3055 {
3056  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3057  PerlIO_clearerr(f);
3058 }
3059
3060 #undef PerlIO_vprintf
3061 int
3062 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3063 {
3064  dTHX;
3065  SV *sv = newSVpvn("",0);
3066  char *s;
3067  STRLEN len;
3068 #ifdef NEED_VA_COPY
3069  va_list apc;
3070  Perl_va_copy(ap, apc);
3071  sv_vcatpvf(sv, fmt, &apc);
3072 #else
3073  sv_vcatpvf(sv, fmt, &ap);
3074 #endif
3075  s = SvPV(sv,len);
3076  return PerlIO_write(f,s,len);
3077 }
3078
3079 #undef PerlIO_printf
3080 int
3081 PerlIO_printf(PerlIO *f,const char *fmt,...)
3082 {
3083  va_list ap;
3084  int result;
3085  va_start(ap,fmt);
3086  result = PerlIO_vprintf(f,fmt,ap);
3087  va_end(ap);
3088  return result;
3089 }
3090
3091 #undef PerlIO_stdoutf
3092 int
3093 PerlIO_stdoutf(const char *fmt,...)
3094 {
3095  va_list ap;
3096  int result;
3097  va_start(ap,fmt);
3098  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3099  va_end(ap);
3100  return result;
3101 }
3102
3103 #undef PerlIO_tmpfile
3104 PerlIO *
3105 PerlIO_tmpfile(void)
3106 {
3107  /* I have no idea how portable mkstemp() is ... */
3108 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3109  dTHX;
3110  PerlIO *f = NULL;
3111  FILE *stdio = PerlSIO_tmpfile();
3112  if (stdio)
3113   {
3114    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3115    s->stdio  = stdio;
3116   }
3117  return f;
3118 #else
3119  dTHX;
3120  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3121  int fd = mkstemp(SvPVX(sv));
3122  PerlIO *f = NULL;
3123  if (fd >= 0)
3124   {
3125    f = PerlIO_fdopen(fd,"w+");
3126    if (f)
3127     {
3128      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3129     }
3130    PerlLIO_unlink(SvPVX(sv));
3131    SvREFCNT_dec(sv);
3132   }
3133  return f;
3134 #endif
3135 }
3136
3137 #undef HAS_FSETPOS
3138 #undef HAS_FGETPOS
3139
3140 #endif /* USE_SFIO */
3141 #endif /* PERLIO_IS_STDIO */
3142
3143 /*======================================================================================*/
3144 /* Now some functions in terms of above which may be needed even if
3145    we are not in true PerlIO mode
3146  */
3147
3148 #ifndef HAS_FSETPOS
3149 #undef PerlIO_setpos
3150 int
3151 PerlIO_setpos(PerlIO *f, SV *pos)
3152 {
3153  dTHX;
3154  if (SvOK(pos))
3155   {
3156    STRLEN len;
3157    Off_t *posn = (Off_t *) SvPV(pos,len);
3158    if (f && len == sizeof(Off_t))
3159     return PerlIO_seek(f,*posn,SEEK_SET);
3160   }
3161  errno = EINVAL;
3162  return -1;
3163 }
3164 #else
3165 #undef PerlIO_setpos
3166 int
3167 PerlIO_setpos(PerlIO *f, SV *pos)
3168 {
3169  dTHX;
3170  if (SvOK(pos))
3171   {
3172    STRLEN len;
3173    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3174    if (f && len == sizeof(Fpos_t))
3175     {
3176 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3177      return fsetpos64(f, fpos);
3178 #else
3179      return fsetpos(f, fpos);
3180 #endif
3181     }
3182   }
3183  errno = EINVAL;
3184  return -1;
3185 }
3186 #endif
3187
3188 #ifndef HAS_FGETPOS
3189 #undef PerlIO_getpos
3190 int
3191 PerlIO_getpos(PerlIO *f, SV *pos)
3192 {
3193  dTHX;
3194  Off_t posn = PerlIO_tell(f);
3195  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3196  return (posn == (Off_t)-1) ? -1 : 0;
3197 }
3198 #else
3199 #undef PerlIO_getpos
3200 int
3201 PerlIO_getpos(PerlIO *f, SV *pos)
3202 {
3203  dTHX;
3204  Fpos_t fpos;
3205  int code;
3206 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3207  code = fgetpos64(f, &fpos);
3208 #else
3209  code = fgetpos(f, &fpos);
3210 #endif
3211  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3212  return code;
3213 }
3214 #endif
3215
3216 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3217
3218 int
3219 vprintf(char *pat, char *args)
3220 {
3221     _doprnt(pat, args, stdout);
3222     return 0;           /* wrong, but perl doesn't use the return value */
3223 }
3224
3225 int
3226 vfprintf(FILE *fd, char *pat, char *args)
3227 {
3228     _doprnt(pat, args, fd);
3229     return 0;           /* wrong, but perl doesn't use the return value */
3230 }
3231
3232 #endif
3233
3234 #ifndef PerlIO_vsprintf
3235 int
3236 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3237 {
3238  int val = vsprintf(s, fmt, ap);
3239  if (n >= 0)
3240   {
3241    if (strlen(s) >= (STRLEN)n)
3242     {
3243      dTHX;
3244      (void)PerlIO_puts(Perl_error_log,
3245                        "panic: sprintf overflow - memory corrupted!\n");
3246      my_exit(1);
3247     }
3248   }
3249  return val;
3250 }
3251 #endif
3252
3253 #ifndef PerlIO_sprintf
3254 int
3255 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3256 {
3257  va_list ap;
3258  int result;
3259  va_start(ap,fmt);
3260  result = PerlIO_vsprintf(s, n, fmt, ap);
3261  va_end(ap);
3262  return result;
3263 }
3264 #endif
3265
3266