perlio.c

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