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