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