perlio.c

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