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