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