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    PERL_ASYNC_CHECK();
1283   }
1284 }
1285
1286 SSize_t
1287 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1288 {
1289  dTHX;
1290  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1291  while (1)
1292   {
1293    SSize_t len = PerlLIO_write(fd,vbuf,count);
1294    if (len >= 0 || errno != EINTR)
1295     {
1296      if (len < 0)
1297       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1298      return len;
1299     }
1300    PERL_ASYNC_CHECK();
1301   }
1302 }
1303
1304 IV
1305 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1306 {
1307  dTHX;
1308  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1309  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1310  return (new == (Off_t) -1) ? -1 : 0;
1311 }
1312
1313 Off_t
1314 PerlIOUnix_tell(PerlIO *f)
1315 {
1316  dTHX;
1317  Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1318  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1319 }
1320
1321 IV
1322 PerlIOUnix_close(PerlIO *f)
1323 {
1324  dTHX;
1325  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1326  int code = 0;
1327  while (PerlLIO_close(fd) != 0)
1328   {
1329    if (errno != EINTR)
1330     {
1331      code = -1;
1332      break;
1333     }
1334    PERL_ASYNC_CHECK();
1335   }
1336  if (code == 0)
1337   {
1338    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1339   }
1340  return code;
1341 }
1342
1343 PerlIO_funcs PerlIO_unix = {
1344  "unix",
1345  sizeof(PerlIOUnix),
1346  PERLIO_K_RAW,
1347  PerlIOUnix_fileno,
1348  PerlIOUnix_fdopen,
1349  PerlIOUnix_open,
1350  PerlIOUnix_reopen,
1351  PerlIOBase_pushed,
1352  PerlIOBase_noop_ok,
1353  PerlIOUnix_read,
1354  PerlIOBase_unread,
1355  PerlIOUnix_write,
1356  PerlIOUnix_seek,
1357  PerlIOUnix_tell,
1358  PerlIOUnix_close,
1359  PerlIOBase_noop_ok,   /* flush */
1360  PerlIOBase_noop_fail, /* fill */
1361  PerlIOBase_eof,
1362  PerlIOBase_error,
1363  PerlIOBase_clearerr,
1364  PerlIOBase_setlinebuf,
1365  NULL, /* get_base */
1366  NULL, /* get_bufsiz */
1367  NULL, /* get_ptr */
1368  NULL, /* get_cnt */
1369  NULL, /* set_ptrcnt */
1370 };
1371
1372 /*--------------------------------------------------------------------------------------*/
1373 /* stdio as a layer */
1374
1375 typedef struct
1376 {
1377  struct _PerlIO base;
1378  FILE *         stdio;      /* The stream */
1379 } PerlIOStdio;
1380
1381 IV
1382 PerlIOStdio_fileno(PerlIO *f)
1383 {
1384  dTHX;
1385  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1386 }
1387
1388 char *
1389 PerlIOStdio_mode(const char *mode,char *tmode)
1390 {
1391  char *ret = tmode;
1392  while (*mode)
1393   {
1394    *tmode++ = *mode++;
1395   }
1396  if (O_BINARY != O_TEXT)
1397   {
1398    *tmode++ = 'b';
1399   }
1400  *tmode = '\0';
1401  return ret;
1402 }
1403
1404 PerlIO *
1405 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1406 {
1407  dTHX;
1408  PerlIO *f = NULL;
1409  int init = 0;
1410  char tmode[8];
1411  if (*mode == 'I')
1412   {
1413    init = 1;
1414    mode++;
1415   }
1416  if (fd >= 0)
1417   {
1418    FILE *stdio = NULL;
1419    if (init)
1420     {
1421      switch(fd)
1422       {
1423        case 0:
1424         stdio = PerlSIO_stdin;
1425         break;
1426        case 1:
1427         stdio = PerlSIO_stdout;
1428         break;
1429        case 2:
1430         stdio = PerlSIO_stderr;
1431         break;
1432       }
1433     }
1434    else
1435     {
1436      stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1437     }
1438    if (stdio)
1439     {
1440      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1441      s->stdio  = stdio;
1442     }
1443   }
1444  return f;
1445 }
1446
1447 #undef PerlIO_importFILE
1448 PerlIO *
1449 PerlIO_importFILE(FILE *stdio, int fl)
1450 {
1451  dTHX;
1452  PerlIO *f = NULL;
1453  if (stdio)
1454   {
1455    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1456    s->stdio  = stdio;
1457   }
1458  return f;
1459 }
1460
1461 PerlIO *
1462 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1463 {
1464  dTHX;
1465  PerlIO *f = NULL;
1466  FILE *stdio = PerlSIO_fopen(path,mode);
1467  if (stdio)
1468   {
1469    char tmode[8];
1470    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1471                                (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1472                                PerlIOStdio);
1473    s->stdio  = stdio;
1474   }
1475  return f;
1476 }
1477
1478 int
1479 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1480 {
1481  dTHX;
1482  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1483  char tmode[8];
1484  FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1485  if (!s->stdio)
1486   return -1;
1487  s->stdio = stdio;
1488  return 0;
1489 }
1490
1491 SSize_t
1492 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1493 {
1494  dTHX;
1495  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1496  SSize_t got = 0;
1497  if (count == 1)
1498   {
1499    STDCHAR *buf = (STDCHAR *) vbuf;
1500    /* Perl is expecting PerlIO_getc() to fill the buffer
1501     * Linux's stdio does not do that for fread()
1502     */
1503    int ch = PerlSIO_fgetc(s);
1504    if (ch != EOF)
1505     {
1506      *buf = ch;
1507      got = 1;
1508     }
1509   }
1510  else
1511   got = PerlSIO_fread(vbuf,1,count,s);
1512  return got;
1513 }
1514
1515 SSize_t
1516 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1517 {
1518  dTHX;
1519  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1520  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1521  SSize_t unread = 0;
1522  while (count > 0)
1523   {
1524    int ch = *buf-- & 0xff;
1525    if (PerlSIO_ungetc(ch,s) != ch)
1526     break;
1527    unread++;
1528    count--;
1529   }
1530  return unread;
1531 }
1532
1533 SSize_t
1534 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1535 {
1536  dTHX;
1537  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1538 }
1539
1540 IV
1541 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1542 {
1543  dTHX;
1544  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1545  return PerlSIO_fseek(stdio,offset,whence);
1546 }
1547
1548 Off_t
1549 PerlIOStdio_tell(PerlIO *f)
1550 {
1551  dTHX;
1552  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1553  return PerlSIO_ftell(stdio);
1554 }
1555
1556 IV
1557 PerlIOStdio_close(PerlIO *f)
1558 {
1559  dTHX;
1560 #ifdef HAS_SOCKET
1561  int optval, optlen = sizeof(int);
1562 #endif
1563  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1564  return(
1565 #ifdef HAS_SOCKET
1566    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1567        PerlSIO_fclose(stdio) :
1568        close(PerlIO_fileno(f))
1569 #else
1570    PerlSIO_fclose(stdio)
1571 #endif
1572      );
1573
1574 }
1575
1576 IV
1577 PerlIOStdio_flush(PerlIO *f)
1578 {
1579  dTHX;
1580  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1581  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1582   {
1583    return PerlSIO_fflush(stdio);
1584   }
1585  else
1586   {
1587 #if 0
1588    /* FIXME: This discards ungetc() and pre-read stuff which is
1589       not right if this is just a "sync" from a layer above
1590       Suspect right design is to do _this_ but not have layer above
1591       flush this layer read-to-read
1592     */
1593    /* Not writeable - sync by attempting a seek */
1594    int err = errno;
1595    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1596     errno = err;
1597 #endif
1598   }
1599  return 0;
1600 }
1601
1602 IV
1603 PerlIOStdio_fill(PerlIO *f)
1604 {
1605  dTHX;
1606  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1607  int c;
1608  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1609  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1610   {
1611    if (PerlSIO_fflush(stdio) != 0)
1612     return EOF;
1613   }
1614  c = PerlSIO_fgetc(stdio);
1615  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1616   return EOF;
1617  return 0;
1618 }
1619
1620 IV
1621 PerlIOStdio_eof(PerlIO *f)
1622 {
1623  dTHX;
1624  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1625 }
1626
1627 IV
1628 PerlIOStdio_error(PerlIO *f)
1629 {
1630  dTHX;
1631  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1632 }
1633
1634 void
1635 PerlIOStdio_clearerr(PerlIO *f)
1636 {
1637  dTHX;
1638  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1639 }
1640
1641 void
1642 PerlIOStdio_setlinebuf(PerlIO *f)
1643 {
1644  dTHX;
1645 #ifdef HAS_SETLINEBUF
1646  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1647 #else
1648  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1649 #endif
1650 }
1651
1652 #ifdef FILE_base
1653 STDCHAR *
1654 PerlIOStdio_get_base(PerlIO *f)
1655 {
1656  dTHX;
1657  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1658  return PerlSIO_get_base(stdio);
1659 }
1660
1661 Size_t
1662 PerlIOStdio_get_bufsiz(PerlIO *f)
1663 {
1664  dTHX;
1665  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1666  return PerlSIO_get_bufsiz(stdio);
1667 }
1668 #endif
1669
1670 #ifdef USE_STDIO_PTR
1671 STDCHAR *
1672 PerlIOStdio_get_ptr(PerlIO *f)
1673 {
1674  dTHX;
1675  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1676  return PerlSIO_get_ptr(stdio);
1677 }
1678
1679 SSize_t
1680 PerlIOStdio_get_cnt(PerlIO *f)
1681 {
1682  dTHX;
1683  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1684  return PerlSIO_get_cnt(stdio);
1685 }
1686
1687 void
1688 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1689 {
1690  dTHX;
1691  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1692  if (ptr != NULL)
1693   {
1694 #ifdef STDIO_PTR_LVALUE
1695    PerlSIO_set_ptr(stdio,ptr);
1696 #ifdef STDIO_PTR_LVAL_SETS_CNT
1697    if (PerlSIO_get_cnt(stdio) != (cnt))
1698     {
1699      dTHX;
1700      assert(PerlSIO_get_cnt(stdio) == (cnt));
1701     }
1702 #endif
1703 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1704    /* Setting ptr _does_ change cnt - we are done */
1705    return;
1706 #endif
1707 #else  /* STDIO_PTR_LVALUE */
1708    PerlProc_abort();
1709 #endif /* STDIO_PTR_LVALUE */
1710   }
1711 /* Now (or only) set cnt */
1712 #ifdef STDIO_CNT_LVALUE
1713  PerlSIO_set_cnt(stdio,cnt);
1714 #else  /* STDIO_CNT_LVALUE */
1715 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1716  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1717 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1718  PerlProc_abort();
1719 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1720 #endif /* STDIO_CNT_LVALUE */
1721 }
1722
1723 #endif
1724
1725 PerlIO_funcs PerlIO_stdio = {
1726  "stdio",
1727  sizeof(PerlIOStdio),
1728  PERLIO_K_BUFFERED,
1729  PerlIOStdio_fileno,
1730  PerlIOStdio_fdopen,
1731  PerlIOStdio_open,
1732  PerlIOStdio_reopen,
1733  PerlIOBase_pushed,
1734  PerlIOBase_noop_ok,
1735  PerlIOStdio_read,
1736  PerlIOStdio_unread,
1737  PerlIOStdio_write,
1738  PerlIOStdio_seek,
1739  PerlIOStdio_tell,
1740  PerlIOStdio_close,
1741  PerlIOStdio_flush,
1742  PerlIOStdio_fill,
1743  PerlIOStdio_eof,
1744  PerlIOStdio_error,
1745  PerlIOStdio_clearerr,
1746  PerlIOStdio_setlinebuf,
1747 #ifdef FILE_base
1748  PerlIOStdio_get_base,
1749  PerlIOStdio_get_bufsiz,
1750 #else
1751  NULL,
1752  NULL,
1753 #endif
1754 #ifdef USE_STDIO_PTR
1755  PerlIOStdio_get_ptr,
1756  PerlIOStdio_get_cnt,
1757 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1758  PerlIOStdio_set_ptrcnt
1759 #else  /* STDIO_PTR_LVALUE */
1760  NULL
1761 #endif /* STDIO_PTR_LVALUE */
1762 #else  /* USE_STDIO_PTR */
1763  NULL,
1764  NULL,
1765  NULL
1766 #endif /* USE_STDIO_PTR */
1767 };
1768
1769 #undef PerlIO_exportFILE
1770 FILE *
1771 PerlIO_exportFILE(PerlIO *f, int fl)
1772 {
1773  FILE *stdio;
1774  PerlIO_flush(f);
1775  stdio = fdopen(PerlIO_fileno(f),"r+");
1776  if (stdio)
1777   {
1778    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1779    s->stdio  = stdio;
1780   }
1781  return stdio;
1782 }
1783
1784 #undef PerlIO_findFILE
1785 FILE *
1786 PerlIO_findFILE(PerlIO *f)
1787 {
1788  PerlIOl *l = *f;
1789  while (l)
1790   {
1791    if (l->tab == &PerlIO_stdio)
1792     {
1793      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
1794      return s->stdio;
1795     }
1796    l = *PerlIONext(&l);
1797   }
1798  return PerlIO_exportFILE(f,0);
1799 }
1800
1801 #undef PerlIO_releaseFILE
1802 void
1803 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1804 {
1805 }
1806
1807 /*--------------------------------------------------------------------------------------*/
1808 /* perlio buffer layer */
1809
1810 IV
1811 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1812 {
1813  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1814  b->posn = PerlIO_tell(PerlIONext(f));
1815  return PerlIOBase_pushed(f,mode,arg,len);
1816 }
1817
1818 PerlIO *
1819 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1820 {
1821  dTHX;
1822  PerlIO_funcs *tab = PerlIO_default_btm();
1823  int init = 0;
1824  PerlIO *f;
1825  if (*mode == 'I')
1826   {
1827    init = 1;
1828    mode++;
1829   }
1830 #if O_BINARY != O_TEXT
1831  /* do something about failing setmode()? --jhi */
1832  PerlLIO_setmode(fd, O_BINARY);
1833 #endif
1834  f = (*tab->Fdopen)(tab,fd,mode);
1835  if (f)
1836   {
1837    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1838    if (init && fd == 2)
1839     {
1840      /* Initial stderr is unbuffered */
1841      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1842     }
1843 #if 0
1844    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1845                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1846 #endif
1847   }
1848  return f;
1849 }
1850
1851 PerlIO *
1852 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1853 {
1854  PerlIO_funcs *tab = PerlIO_default_btm();
1855  PerlIO *f = (*tab->Open)(tab,path,mode);
1856  if (f)
1857   {
1858    PerlIO_push(f,self,mode,Nullch,0);
1859   }
1860  return f;
1861 }
1862
1863 int
1864 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1865 {
1866  PerlIO *next = PerlIONext(f);
1867  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1868  if (code = 0)
1869   code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
1870  return code;
1871 }
1872
1873 /* This "flush" is akin to sfio's sync in that it handles files in either
1874    read or write state
1875 */
1876 IV
1877 PerlIOBuf_flush(PerlIO *f)
1878 {
1879  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1880  int code = 0;
1881  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1882   {
1883    /* write() the buffer */
1884    STDCHAR *buf = b->buf;
1885    STDCHAR *p = buf;
1886    int count;
1887    PerlIO *n = PerlIONext(f);
1888    while (p < b->ptr)
1889     {
1890      count = PerlIO_write(n,p,b->ptr - p);
1891      if (count > 0)
1892       {
1893        p += count;
1894       }
1895      else if (count < 0 || PerlIO_error(n))
1896       {
1897        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1898        code = -1;
1899        break;
1900       }
1901     }
1902    b->posn += (p - buf);
1903   }
1904  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1905   {
1906    STDCHAR *buf = PerlIO_get_base(f);
1907    /* Note position change */
1908    b->posn += (b->ptr - buf);
1909    if (b->ptr < b->end)
1910     {
1911      /* We did not consume all of it */
1912      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1913       {
1914        b->posn = PerlIO_tell(PerlIONext(f));
1915       }
1916     }
1917   }
1918  b->ptr = b->end = b->buf;
1919  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1920  /* FIXME: Is this right for read case ? */
1921  if (PerlIO_flush(PerlIONext(f)) != 0)
1922   code = -1;
1923  return code;
1924 }
1925
1926 IV
1927 PerlIOBuf_fill(PerlIO *f)
1928 {
1929  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1930  PerlIO *n = PerlIONext(f);
1931  SSize_t avail;
1932  /* FIXME: doing the down-stream flush is a bad idea if it causes
1933     pre-read data in stdio buffer to be discarded
1934     but this is too simplistic - as it skips _our_ hosekeeping
1935     and breaks tell tests.
1936  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1937   {
1938   }
1939   */
1940  if (PerlIO_flush(f) != 0)
1941   return -1;
1942
1943  if (!b->buf)
1944   PerlIO_get_base(f); /* allocate via vtable */
1945
1946  b->ptr = b->end = b->buf;
1947  if (PerlIO_fast_gets(n))
1948   {
1949    /* Layer below is also buffered
1950     * We do _NOT_ want to call its ->Read() because that will loop
1951     * till it gets what we asked for which may hang on a pipe etc.
1952     * Instead take anything it has to hand, or ask it to fill _once_.
1953     */
1954    avail  = PerlIO_get_cnt(n);
1955    if (avail <= 0)
1956     {
1957      avail = PerlIO_fill(n);
1958      if (avail == 0)
1959       avail = PerlIO_get_cnt(n);
1960      else
1961       {
1962        if (!PerlIO_error(n) && PerlIO_eof(n))
1963         avail = 0;
1964       }
1965     }
1966    if (avail > 0)
1967     {
1968      STDCHAR *ptr = PerlIO_get_ptr(n);
1969      SSize_t cnt  = avail;
1970      if (avail > b->bufsiz)
1971       avail = b->bufsiz;
1972      Copy(ptr,b->buf,avail,STDCHAR);
1973      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1974     }
1975   }
1976  else
1977   {
1978    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1979   }
1980  if (avail <= 0)
1981   {
1982    if (avail == 0)
1983     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1984    else
1985     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1986    return -1;
1987   }
1988  b->end      = b->buf+avail;
1989  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1990  return 0;
1991 }
1992
1993 SSize_t
1994 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1995 {
1996  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1997  STDCHAR *buf  = (STDCHAR *) vbuf;
1998  if (f)
1999   {
2000    if (!b->ptr)
2001     PerlIO_get_base(f);
2002    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2003     return 0;
2004    while (count > 0)
2005     {
2006      SSize_t avail = PerlIO_get_cnt(f);
2007      SSize_t take  = (count < avail) ? count : avail;
2008      if (take > 0)
2009       {
2010        STDCHAR *ptr = PerlIO_get_ptr(f);
2011        Copy(ptr,buf,take,STDCHAR);
2012        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2013        count   -= take;
2014        buf     += take;
2015       }
2016      if (count > 0  && avail <= 0)
2017       {
2018        if (PerlIO_fill(f) != 0)
2019         break;
2020       }
2021     }
2022    return (buf - (STDCHAR *) vbuf);
2023   }
2024  return 0;
2025 }
2026
2027 SSize_t
2028 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2029 {
2030  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2031  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2032  SSize_t unread = 0;
2033  SSize_t avail;
2034  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2035   PerlIO_flush(f);
2036  if (!b->buf)
2037   PerlIO_get_base(f);
2038  if (b->buf)
2039   {
2040    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2041     {
2042      avail = (b->ptr - b->buf);
2043     }
2044    else
2045     {
2046      avail = b->bufsiz;
2047      b->end = b->buf + avail;
2048      b->ptr = b->end;
2049      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2050      b->posn -= b->bufsiz;
2051     }
2052    if (avail > (SSize_t) count)
2053     avail = count;
2054    if (avail > 0)
2055     {
2056      b->ptr -= avail;
2057      buf    -= avail;
2058      if (buf != b->ptr)
2059       {
2060        Copy(buf,b->ptr,avail,STDCHAR);
2061       }
2062      count  -= avail;
2063      unread += avail;
2064      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2065     }
2066   }
2067  return unread;
2068 }
2069
2070 SSize_t
2071 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2072 {
2073  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2074  const STDCHAR *buf = (const STDCHAR *) vbuf;
2075  Size_t written = 0;
2076  if (!b->buf)
2077   PerlIO_get_base(f);
2078  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2079   return 0;
2080  while (count > 0)
2081   {
2082    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2083    if ((SSize_t) count < avail)
2084     avail = count;
2085    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2086    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2087     {
2088      while (avail > 0)
2089       {
2090        int ch = *buf++;
2091        *(b->ptr)++ = ch;
2092        count--;
2093        avail--;
2094        written++;
2095        if (ch == '\n')
2096         {
2097          PerlIO_flush(f);
2098          break;
2099         }
2100       }
2101     }
2102    else
2103     {
2104      if (avail)
2105       {
2106        Copy(buf,b->ptr,avail,STDCHAR);
2107        count   -= avail;
2108        buf     += avail;
2109        written += avail;
2110        b->ptr  += avail;
2111       }
2112     }
2113    if (b->ptr >= (b->buf + b->bufsiz))
2114     PerlIO_flush(f);
2115   }
2116  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2117   PerlIO_flush(f);
2118  return written;
2119 }
2120
2121 IV
2122 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2123 {
2124  IV code;
2125  if ((code = PerlIO_flush(f)) == 0)
2126   {
2127    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2128    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2129    code = PerlIO_seek(PerlIONext(f),offset,whence);
2130    if (code == 0)
2131     {
2132      b->posn = PerlIO_tell(PerlIONext(f));
2133     }
2134   }
2135  return code;
2136 }
2137
2138 Off_t
2139 PerlIOBuf_tell(PerlIO *f)
2140 {
2141  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2142  Off_t posn = b->posn;
2143  if (b->buf)
2144   posn += (b->ptr - b->buf);
2145  return posn;
2146 }
2147
2148 IV
2149 PerlIOBuf_close(PerlIO *f)
2150 {
2151  dTHX;
2152  IV code = PerlIOBase_close(f);
2153  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2154  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2155   {
2156    PerlMemShared_free(b->buf);
2157   }
2158  b->buf = NULL;
2159  b->ptr = b->end = b->buf;
2160  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2161  return code;
2162 }
2163
2164 void
2165 PerlIOBuf_setlinebuf(PerlIO *f)
2166 {
2167  if (f)
2168   {
2169    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2170   }
2171 }
2172
2173 STDCHAR *
2174 PerlIOBuf_get_ptr(PerlIO *f)
2175 {
2176  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2177  if (!b->buf)
2178   PerlIO_get_base(f);
2179  return b->ptr;
2180 }
2181
2182 SSize_t
2183 PerlIOBuf_get_cnt(PerlIO *f)
2184 {
2185  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2186  if (!b->buf)
2187   PerlIO_get_base(f);
2188  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2189   return (b->end - b->ptr);
2190  return 0;
2191 }
2192
2193 STDCHAR *
2194 PerlIOBuf_get_base(PerlIO *f)
2195 {
2196  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2197  if (!b->buf)
2198   {
2199    dTHX;
2200    if (!b->bufsiz)
2201     b->bufsiz = 4096;
2202    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2203    if (!b->buf)
2204     {
2205      b->buf = (STDCHAR *)&b->oneword;
2206      b->bufsiz = sizeof(b->oneword);
2207     }
2208    b->ptr = b->buf;
2209    b->end = b->ptr;
2210   }
2211  return b->buf;
2212 }
2213
2214 Size_t
2215 PerlIOBuf_bufsiz(PerlIO *f)
2216 {
2217  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2218  if (!b->buf)
2219   PerlIO_get_base(f);
2220  return (b->end - b->buf);
2221 }
2222
2223 void
2224 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2225 {
2226  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2227  if (!b->buf)
2228   PerlIO_get_base(f);
2229  b->ptr = ptr;
2230  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2231   {
2232    dTHX;
2233    assert(PerlIO_get_cnt(f) == cnt);
2234    assert(b->ptr >= b->buf);
2235   }
2236  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2237 }
2238
2239 PerlIO_funcs PerlIO_perlio = {
2240  "perlio",
2241  sizeof(PerlIOBuf),
2242  PERLIO_K_BUFFERED,
2243  PerlIOBase_fileno,
2244  PerlIOBuf_fdopen,
2245  PerlIOBuf_open,
2246  PerlIOBuf_reopen,
2247  PerlIOBuf_pushed,
2248  PerlIOBase_noop_ok,
2249  PerlIOBuf_read,
2250  PerlIOBuf_unread,
2251  PerlIOBuf_write,
2252  PerlIOBuf_seek,
2253  PerlIOBuf_tell,
2254  PerlIOBuf_close,
2255  PerlIOBuf_flush,
2256  PerlIOBuf_fill,
2257  PerlIOBase_eof,
2258  PerlIOBase_error,
2259  PerlIOBase_clearerr,
2260  PerlIOBuf_setlinebuf,
2261  PerlIOBuf_get_base,
2262  PerlIOBuf_bufsiz,
2263  PerlIOBuf_get_ptr,
2264  PerlIOBuf_get_cnt,
2265  PerlIOBuf_set_ptrcnt,
2266 };
2267
2268 /*--------------------------------------------------------------------------------------*/
2269 /* Temp layer to hold unread chars when cannot do it any other way */
2270
2271 IV
2272 PerlIOPending_fill(PerlIO *f)
2273 {
2274  /* Should never happen */
2275  PerlIO_flush(f);
2276  return 0;
2277 }
2278
2279 IV
2280 PerlIOPending_close(PerlIO *f)
2281 {
2282  /* A tad tricky - flush pops us, then we close new top */
2283  PerlIO_flush(f);
2284  return PerlIO_close(f);
2285 }
2286
2287 IV
2288 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2289 {
2290  /* A tad tricky - flush pops us, then we seek new top */
2291  PerlIO_flush(f);
2292  return PerlIO_seek(f,offset,whence);
2293 }
2294
2295
2296 IV
2297 PerlIOPending_flush(PerlIO *f)
2298 {
2299  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2300  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2301   {
2302    dTHX;
2303    PerlMemShared_free(b->buf);
2304    b->buf = NULL;
2305   }
2306  PerlIO_pop(f);
2307  return 0;
2308 }
2309
2310 void
2311 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2312 {
2313  if (cnt <= 0)
2314   {
2315    PerlIO_flush(f);
2316   }
2317  else
2318   {
2319    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2320   }
2321 }
2322
2323 IV
2324 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2325 {
2326  IV code    = PerlIOBase_pushed(f,mode,arg,len);
2327  PerlIOl *l = PerlIOBase(f);
2328  /* Our PerlIO_fast_gets must match what we are pushed on,
2329     or sv_gets() etc. get muddled when it changes mid-string
2330     when we auto-pop.
2331   */
2332  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2333               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2334  return code;
2335 }
2336
2337 SSize_t
2338 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2339 {
2340  SSize_t avail = PerlIO_get_cnt(f);
2341  SSize_t got   = 0;
2342  if (count < avail)
2343   avail = count;
2344  if (avail > 0)
2345   got = PerlIOBuf_read(f,vbuf,avail);
2346  if (got < count)
2347   got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2348  return got;
2349 }
2350
2351
2352 PerlIO_funcs PerlIO_pending = {
2353  "pending",
2354  sizeof(PerlIOBuf),
2355  PERLIO_K_BUFFERED,
2356  PerlIOBase_fileno,
2357  NULL,
2358  NULL,
2359  NULL,
2360  PerlIOPending_pushed,
2361  PerlIOBase_noop_ok,
2362  PerlIOPending_read,
2363  PerlIOBuf_unread,
2364  PerlIOBuf_write,
2365  PerlIOPending_seek,
2366  PerlIOBuf_tell,
2367  PerlIOPending_close,
2368  PerlIOPending_flush,
2369  PerlIOPending_fill,
2370  PerlIOBase_eof,
2371  PerlIOBase_error,
2372  PerlIOBase_clearerr,
2373  PerlIOBuf_setlinebuf,
2374  PerlIOBuf_get_base,
2375  PerlIOBuf_bufsiz,
2376  PerlIOBuf_get_ptr,
2377  PerlIOBuf_get_cnt,
2378  PerlIOPending_set_ptrcnt,
2379 };
2380
2381
2382
2383 /*--------------------------------------------------------------------------------------*/
2384 /* crlf - translation
2385    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2386    to hand back a line at a time and keeping a record of which nl we "lied" about.
2387    On write translate "\n" to CR,LF
2388  */
2389
2390 typedef struct
2391 {
2392  PerlIOBuf      base;         /* PerlIOBuf stuff */
2393  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2394 } PerlIOCrlf;
2395
2396 IV
2397 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2398 {
2399  IV code;
2400  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2401  code = PerlIOBuf_pushed(f,mode,arg,len);
2402 #if 0
2403  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2404               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2405               PerlIOBase(f)->flags);
2406 #endif
2407  return code;
2408 }
2409
2410
2411 SSize_t
2412 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2413 {
2414  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2415  if (c->nl)
2416   {
2417    *(c->nl) = 0xd;
2418    c->nl = NULL;
2419   }
2420  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2421   return PerlIOBuf_unread(f,vbuf,count);
2422  else
2423   {
2424    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2425    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2426    SSize_t unread = 0;
2427    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2428     PerlIO_flush(f);
2429    if (!b->buf)
2430     PerlIO_get_base(f);
2431    if (b->buf)
2432     {
2433      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2434       {
2435        b->end = b->ptr = b->buf + b->bufsiz;
2436        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2437        b->posn -= b->bufsiz;
2438       }
2439      while (count > 0 && b->ptr > b->buf)
2440       {
2441        int ch = *--buf;
2442        if (ch == '\n')
2443         {
2444          if (b->ptr - 2 >= b->buf)
2445           {
2446            *--(b->ptr) = 0xa;
2447            *--(b->ptr) = 0xd;
2448            unread++;
2449            count--;
2450           }
2451          else
2452           {
2453            buf++;
2454            break;
2455           }
2456         }
2457        else
2458         {
2459          *--(b->ptr) = ch;
2460          unread++;
2461          count--;
2462         }
2463       }
2464     }
2465    return unread;
2466   }
2467 }
2468
2469 SSize_t
2470 PerlIOCrlf_get_cnt(PerlIO *f)
2471 {
2472  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2473  if (!b->buf)
2474   PerlIO_get_base(f);
2475  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2476   {
2477    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2478    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2479     {
2480      STDCHAR *nl   = b->ptr;
2481     scan:
2482      while (nl < b->end && *nl != 0xd)
2483       nl++;
2484      if (nl < b->end && *nl == 0xd)
2485       {
2486      test:
2487        if (nl+1 < b->end)
2488         {
2489          if (nl[1] == 0xa)
2490           {
2491            *nl   = '\n';
2492            c->nl = nl;
2493           }
2494          else
2495           {
2496            /* Not CR,LF but just CR */
2497            nl++;
2498            goto scan;
2499           }
2500         }
2501        else
2502         {
2503          /* Blast - found CR as last char in buffer */
2504          if (b->ptr < nl)
2505           {
2506            /* They may not care, defer work as long as possible */
2507            return (nl - b->ptr);
2508           }
2509          else
2510           {
2511            int code;
2512            dTHX;
2513            b->ptr++;               /* say we have read it as far as flush() is concerned */
2514            b->buf++;               /* Leave space an front of buffer */
2515            b->bufsiz--;            /* Buffer is thus smaller */
2516            code = PerlIO_fill(f);  /* Fetch some more */
2517            b->bufsiz++;            /* Restore size for next time */
2518            b->buf--;               /* Point at space */
2519            b->ptr = nl = b->buf;   /* Which is what we hand off */
2520            b->posn--;              /* Buffer starts here */
2521            *nl = 0xd;              /* Fill in the CR */
2522            if (code == 0)
2523             goto test;             /* fill() call worked */
2524            /* CR at EOF - just fall through */
2525           }
2526         }
2527       }
2528     }
2529    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2530   }
2531  return 0;
2532 }
2533
2534 void
2535 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2536 {
2537  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2538  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2539  IV flags = PerlIOBase(f)->flags;
2540  if (!b->buf)
2541   PerlIO_get_base(f);
2542  if (!ptr)
2543   {
2544    if (c->nl)
2545     ptr = c->nl+1;
2546    else
2547     {
2548      ptr = b->end;
2549      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2550       ptr--;
2551     }
2552    ptr -= cnt;
2553   }
2554  else
2555   {
2556    /* Test code - delete when it works ... */
2557    STDCHAR *chk;
2558    if (c->nl)
2559     chk = c->nl+1;
2560    else
2561     {
2562      chk = b->end;
2563      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2564       chk--;
2565     }
2566    chk -= cnt;
2567
2568    if (ptr != chk)
2569     {
2570      dTHX;
2571      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2572                 ptr, chk, flags, c->nl, b->end, cnt);
2573     }
2574   }
2575  if (c->nl)
2576   {
2577    if (ptr > c->nl)
2578     {
2579      /* They have taken what we lied about */
2580      *(c->nl) = 0xd;
2581      c->nl = NULL;
2582      ptr++;
2583     }
2584   }
2585  b->ptr = ptr;
2586  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2587 }
2588
2589 SSize_t
2590 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2591 {
2592  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2593   return PerlIOBuf_write(f,vbuf,count);
2594  else
2595   {
2596    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2597    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2598    const STDCHAR *ebuf = buf+count;
2599    if (!b->buf)
2600     PerlIO_get_base(f);
2601    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2602     return 0;
2603    while (buf < ebuf)
2604     {
2605      STDCHAR *eptr = b->buf+b->bufsiz;
2606      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2607      while (buf < ebuf && b->ptr < eptr)
2608       {
2609        if (*buf == '\n')
2610         {
2611          if ((b->ptr + 2) > eptr)
2612           {
2613            /* Not room for both */
2614            PerlIO_flush(f);
2615            break;
2616           }
2617          else
2618           {
2619            *(b->ptr)++ = 0xd; /* CR */
2620            *(b->ptr)++ = 0xa; /* LF */
2621            buf++;
2622            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2623             {
2624              PerlIO_flush(f);
2625              break;
2626             }
2627           }
2628         }
2629        else
2630         {
2631          int ch = *buf++;
2632          *(b->ptr)++ = ch;
2633         }
2634        if (b->ptr >= eptr)
2635         {
2636          PerlIO_flush(f);
2637          break;
2638         }
2639       }
2640     }
2641    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2642     PerlIO_flush(f);
2643    return (buf - (STDCHAR *) vbuf);
2644   }
2645 }
2646
2647 IV
2648 PerlIOCrlf_flush(PerlIO *f)
2649 {
2650  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2651  if (c->nl)
2652   {
2653    *(c->nl) = 0xd;
2654    c->nl = NULL;
2655   }
2656  return PerlIOBuf_flush(f);
2657 }
2658
2659 PerlIO_funcs PerlIO_crlf = {
2660  "crlf",
2661  sizeof(PerlIOCrlf),
2662  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2663  PerlIOBase_fileno,
2664  PerlIOBuf_fdopen,
2665  PerlIOBuf_open,
2666  PerlIOBuf_reopen,
2667  PerlIOCrlf_pushed,
2668  PerlIOBase_noop_ok,   /* popped */
2669  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2670  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2671  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2672  PerlIOBuf_seek,
2673  PerlIOBuf_tell,
2674  PerlIOBuf_close,
2675  PerlIOCrlf_flush,
2676  PerlIOBuf_fill,
2677  PerlIOBase_eof,
2678  PerlIOBase_error,
2679  PerlIOBase_clearerr,
2680  PerlIOBuf_setlinebuf,
2681  PerlIOBuf_get_base,
2682  PerlIOBuf_bufsiz,
2683  PerlIOBuf_get_ptr,
2684  PerlIOCrlf_get_cnt,
2685  PerlIOCrlf_set_ptrcnt,
2686 };
2687
2688 #ifdef HAS_MMAP
2689 /*--------------------------------------------------------------------------------------*/
2690 /* mmap as "buffer" layer */
2691
2692 typedef struct
2693 {
2694  PerlIOBuf      base;         /* PerlIOBuf stuff */
2695  Mmap_t         mptr;        /* Mapped address */
2696  Size_t         len;          /* mapped length */
2697  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2698 } PerlIOMmap;
2699
2700 static size_t page_size = 0;
2701
2702 IV
2703 PerlIOMmap_map(PerlIO *f)
2704 {
2705  dTHX;
2706  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2707  PerlIOBuf  *b = &m->base;
2708  IV flags = PerlIOBase(f)->flags;
2709  IV code  = 0;
2710  if (m->len)
2711   abort();
2712  if (flags & PERLIO_F_CANREAD)
2713   {
2714    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2715    int fd   = PerlIO_fileno(f);
2716    struct stat st;
2717    code = fstat(fd,&st);
2718    if (code == 0 && S_ISREG(st.st_mode))
2719     {
2720      SSize_t len = st.st_size - b->posn;
2721      if (len > 0)
2722       {
2723        Off_t posn;
2724        if (!page_size) {
2725 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2726            {
2727                SETERRNO(0,SS$_NORMAL);
2728 #   ifdef _SC_PAGESIZE
2729                page_size = sysconf(_SC_PAGESIZE);
2730 #   else
2731                page_size = sysconf(_SC_PAGE_SIZE);
2732 #   endif
2733                if ((long)page_size < 0) {
2734                    if (errno) {
2735                        SV *error = ERRSV;
2736                        char *msg;
2737                        STRLEN n_a;
2738                        (void)SvUPGRADE(error, SVt_PV);
2739                        msg = SvPVx(error, n_a);
2740                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2741                    }
2742                    else
2743                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2744                }
2745            }
2746 #else
2747 #   ifdef HAS_GETPAGESIZE
2748         page_size = getpagesize();
2749 #   else
2750 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2751         page_size = PAGESIZE; /* compiletime, bad */
2752 #       endif
2753 #   endif
2754 #endif
2755         if ((IV)page_size <= 0)
2756             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2757        }
2758        if (b->posn < 0)
2759         {
2760          /* This is a hack - should never happen - open should have set it ! */
2761          b->posn = PerlIO_tell(PerlIONext(f));
2762         }
2763        posn = (b->posn / page_size) * page_size;
2764        len  = st.st_size - posn;
2765        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2766        if (m->mptr && m->mptr != (Mmap_t) -1)
2767         {
2768 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2769          madvise(m->mptr, len, MADV_SEQUENTIAL);
2770 #endif
2771 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2772          madvise(m->mptr, len, MADV_WILLNEED);
2773 #endif
2774          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2775          b->end  = ((STDCHAR *)m->mptr) + len;
2776          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2777          b->ptr  = b->buf;
2778          m->len  = len;
2779         }
2780        else
2781         {
2782          b->buf = NULL;
2783         }
2784       }
2785      else
2786       {
2787        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2788        b->buf = NULL;
2789        b->ptr = b->end = b->ptr;
2790        code = -1;
2791       }
2792     }
2793   }
2794  return code;
2795 }
2796
2797 IV
2798 PerlIOMmap_unmap(PerlIO *f)
2799 {
2800  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2801  PerlIOBuf  *b = &m->base;
2802  IV code = 0;
2803  if (m->len)
2804   {
2805    if (b->buf)
2806     {
2807      code = munmap(m->mptr, m->len);
2808      b->buf  = NULL;
2809      m->len  = 0;
2810      m->mptr = NULL;
2811      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2812       code = -1;
2813     }
2814    b->ptr = b->end = b->buf;
2815    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2816   }
2817  return code;
2818 }
2819
2820 STDCHAR *
2821 PerlIOMmap_get_base(PerlIO *f)
2822 {
2823  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2824  PerlIOBuf  *b = &m->base;
2825  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2826   {
2827    /* Already have a readbuffer in progress */
2828    return b->buf;
2829   }
2830  if (b->buf)
2831   {
2832    /* We have a write buffer or flushed PerlIOBuf read buffer */
2833    m->bbuf = b->buf;  /* save it in case we need it again */
2834    b->buf  = NULL;    /* Clear to trigger below */
2835   }
2836  if (!b->buf)
2837   {
2838    PerlIOMmap_map(f);     /* Try and map it */
2839    if (!b->buf)
2840     {
2841      /* Map did not work - recover PerlIOBuf buffer if we have one */
2842      b->buf = m->bbuf;
2843     }
2844   }
2845  b->ptr  = b->end = b->buf;
2846  if (b->buf)
2847   return b->buf;
2848  return PerlIOBuf_get_base(f);
2849 }
2850
2851 SSize_t
2852 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2853 {
2854  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2855  PerlIOBuf  *b = &m->base;
2856  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2857   PerlIO_flush(f);
2858  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2859   {
2860    b->ptr -= count;
2861    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2862    return count;
2863   }
2864  if (m->len)
2865   {
2866    /* Loose the unwritable mapped buffer */
2867    PerlIO_flush(f);
2868    /* If flush took the "buffer" see if we have one from before */
2869    if (!b->buf && m->bbuf)
2870     b->buf = m->bbuf;
2871    if (!b->buf)
2872     {
2873      PerlIOBuf_get_base(f);
2874      m->bbuf = b->buf;
2875     }
2876   }
2877 return PerlIOBuf_unread(f,vbuf,count);
2878 }
2879
2880 SSize_t
2881 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2882 {
2883  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2884  PerlIOBuf  *b = &m->base;
2885  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2886   {
2887    /* No, or wrong sort of, buffer */
2888    if (m->len)
2889     {
2890      if (PerlIOMmap_unmap(f) != 0)
2891       return 0;
2892     }
2893    /* If unmap took the "buffer" see if we have one from before */
2894    if (!b->buf && m->bbuf)
2895     b->buf = m->bbuf;
2896    if (!b->buf)
2897     {
2898      PerlIOBuf_get_base(f);
2899      m->bbuf = b->buf;
2900     }
2901   }
2902  return PerlIOBuf_write(f,vbuf,count);
2903 }
2904
2905 IV
2906 PerlIOMmap_flush(PerlIO *f)
2907 {
2908  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2909  PerlIOBuf  *b = &m->base;
2910  IV code = PerlIOBuf_flush(f);
2911  /* Now we are "synced" at PerlIOBuf level */
2912  if (b->buf)
2913   {
2914    if (m->len)
2915     {
2916      /* Unmap the buffer */
2917      if (PerlIOMmap_unmap(f) != 0)
2918       code = -1;
2919     }
2920    else
2921     {
2922      /* We seem to have a PerlIOBuf buffer which was not mapped
2923       * remember it in case we need one later
2924       */
2925      m->bbuf = b->buf;
2926     }
2927   }
2928  return code;
2929 }
2930
2931 IV
2932 PerlIOMmap_fill(PerlIO *f)
2933 {
2934  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2935  IV code = PerlIO_flush(f);
2936  if (code == 0 && !b->buf)
2937   {
2938    code = PerlIOMmap_map(f);
2939   }
2940  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2941   {
2942    code = PerlIOBuf_fill(f);
2943   }
2944  return code;
2945 }
2946
2947 IV
2948 PerlIOMmap_close(PerlIO *f)
2949 {
2950  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2951  PerlIOBuf  *b = &m->base;
2952  IV code = PerlIO_flush(f);
2953  if (m->bbuf)
2954   {
2955    b->buf  = m->bbuf;
2956    m->bbuf = NULL;
2957    b->ptr  = b->end = b->buf;
2958   }
2959  if (PerlIOBuf_close(f) != 0)
2960   code = -1;
2961  return code;
2962 }
2963
2964
2965 PerlIO_funcs PerlIO_mmap = {
2966  "mmap",
2967  sizeof(PerlIOMmap),
2968  PERLIO_K_BUFFERED,
2969  PerlIOBase_fileno,
2970  PerlIOBuf_fdopen,
2971  PerlIOBuf_open,
2972  PerlIOBuf_reopen,
2973  PerlIOBuf_pushed,
2974  PerlIOBase_noop_ok,
2975  PerlIOBuf_read,
2976  PerlIOMmap_unread,
2977  PerlIOMmap_write,
2978  PerlIOBuf_seek,
2979  PerlIOBuf_tell,
2980  PerlIOBuf_close,
2981  PerlIOMmap_flush,
2982  PerlIOMmap_fill,
2983  PerlIOBase_eof,
2984  PerlIOBase_error,
2985  PerlIOBase_clearerr,
2986  PerlIOBuf_setlinebuf,
2987  PerlIOMmap_get_base,
2988  PerlIOBuf_bufsiz,
2989  PerlIOBuf_get_ptr,
2990  PerlIOBuf_get_cnt,
2991  PerlIOBuf_set_ptrcnt,
2992 };
2993
2994 #endif /* HAS_MMAP */
2995
2996 void
2997 PerlIO_init(void)
2998 {
2999  if (!_perlio)
3000   {
3001 #ifndef WIN32
3002    atexit(&PerlIO_cleanup);
3003 #endif
3004   }
3005 }
3006
3007 #undef PerlIO_stdin
3008 PerlIO *
3009 PerlIO_stdin(void)
3010 {
3011  if (!_perlio)
3012   PerlIO_stdstreams();
3013  return &_perlio[1];
3014 }
3015
3016 #undef PerlIO_stdout
3017 PerlIO *
3018 PerlIO_stdout(void)
3019 {
3020  if (!_perlio)
3021   PerlIO_stdstreams();
3022  return &_perlio[2];
3023 }
3024
3025 #undef PerlIO_stderr
3026 PerlIO *
3027 PerlIO_stderr(void)
3028 {
3029  if (!_perlio)
3030   PerlIO_stdstreams();
3031  return &_perlio[3];
3032 }
3033
3034 /*--------------------------------------------------------------------------------------*/
3035
3036 #undef PerlIO_getname
3037 char *
3038 PerlIO_getname(PerlIO *f, char *buf)
3039 {
3040  dTHX;
3041  Perl_croak(aTHX_ "Don't know how to get file name");
3042  return NULL;
3043 }
3044
3045
3046 /*--------------------------------------------------------------------------------------*/
3047 /* Functions which can be called on any kind of PerlIO implemented
3048    in terms of above
3049 */
3050
3051 #undef PerlIO_getc
3052 int
3053 PerlIO_getc(PerlIO *f)
3054 {
3055  STDCHAR buf[1];
3056  SSize_t count = PerlIO_read(f,buf,1);
3057  if (count == 1)
3058   {
3059    return (unsigned char) buf[0];
3060   }
3061  return EOF;
3062 }
3063
3064 #undef PerlIO_ungetc
3065 int
3066 PerlIO_ungetc(PerlIO *f, int ch)
3067 {
3068  if (ch != EOF)
3069   {
3070    STDCHAR buf = ch;
3071    if (PerlIO_unread(f,&buf,1) == 1)
3072     return ch;
3073   }
3074  return EOF;
3075 }
3076
3077 #undef PerlIO_putc
3078 int
3079 PerlIO_putc(PerlIO *f, int ch)
3080 {
3081  STDCHAR buf = ch;
3082  return PerlIO_write(f,&buf,1);
3083 }
3084
3085 #undef PerlIO_puts
3086 int
3087 PerlIO_puts(PerlIO *f, const char *s)
3088 {
3089  STRLEN len = strlen(s);
3090  return PerlIO_write(f,s,len);
3091 }
3092
3093 #undef PerlIO_rewind
3094 void
3095 PerlIO_rewind(PerlIO *f)
3096 {
3097  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3098  PerlIO_clearerr(f);
3099 }
3100
3101 #undef PerlIO_vprintf
3102 int
3103 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3104 {
3105  dTHX;
3106  SV *sv = newSVpvn("",0);
3107  char *s;
3108  STRLEN len;
3109 #ifdef NEED_VA_COPY
3110  va_list apc;
3111  Perl_va_copy(ap, apc);
3112  sv_vcatpvf(sv, fmt, &apc);
3113 #else
3114  sv_vcatpvf(sv, fmt, &ap);
3115 #endif
3116  s = SvPV(sv,len);
3117  return PerlIO_write(f,s,len);
3118 }
3119
3120 #undef PerlIO_printf
3121 int
3122 PerlIO_printf(PerlIO *f,const char *fmt,...)
3123 {
3124  va_list ap;
3125  int result;
3126  va_start(ap,fmt);
3127  result = PerlIO_vprintf(f,fmt,ap);
3128  va_end(ap);
3129  return result;
3130 }
3131
3132 #undef PerlIO_stdoutf
3133 int
3134 PerlIO_stdoutf(const char *fmt,...)
3135 {
3136  va_list ap;
3137  int result;
3138  va_start(ap,fmt);
3139  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3140  va_end(ap);
3141  return result;
3142 }
3143
3144 #undef PerlIO_tmpfile
3145 PerlIO *
3146 PerlIO_tmpfile(void)
3147 {
3148  /* I have no idea how portable mkstemp() is ... */
3149 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3150  dTHX;
3151  PerlIO *f = NULL;
3152  FILE *stdio = PerlSIO_tmpfile();
3153  if (stdio)
3154   {
3155    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3156    s->stdio  = stdio;
3157   }
3158  return f;
3159 #else
3160  dTHX;
3161  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3162  int fd = mkstemp(SvPVX(sv));
3163  PerlIO *f = NULL;
3164  if (fd >= 0)
3165   {
3166    f = PerlIO_fdopen(fd,"w+");
3167    if (f)
3168     {
3169      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3170     }
3171    PerlLIO_unlink(SvPVX(sv));
3172    SvREFCNT_dec(sv);
3173   }
3174  return f;
3175 #endif
3176 }
3177
3178 #undef HAS_FSETPOS
3179 #undef HAS_FGETPOS
3180
3181 #endif /* USE_SFIO */
3182 #endif /* PERLIO_IS_STDIO */
3183
3184 /*======================================================================================*/
3185 /* Now some functions in terms of above which may be needed even if
3186    we are not in true PerlIO mode
3187  */
3188
3189 #ifndef HAS_FSETPOS
3190 #undef PerlIO_setpos
3191 int
3192 PerlIO_setpos(PerlIO *f, SV *pos)
3193 {
3194  dTHX;
3195  if (SvOK(pos))
3196   {
3197    STRLEN len;
3198    Off_t *posn = (Off_t *) SvPV(pos,len);
3199    if (f && len == sizeof(Off_t))
3200     return PerlIO_seek(f,*posn,SEEK_SET);
3201   }
3202  errno = EINVAL;
3203  return -1;
3204 }
3205 #else
3206 #undef PerlIO_setpos
3207 int
3208 PerlIO_setpos(PerlIO *f, SV *pos)
3209 {
3210  dTHX;
3211  if (SvOK(pos))
3212   {
3213    STRLEN len;
3214    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3215    if (f && len == sizeof(Fpos_t))
3216     {
3217 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3218      return fsetpos64(f, fpos);
3219 #else
3220      return fsetpos(f, fpos);
3221 #endif
3222     }
3223   }
3224  errno = EINVAL;
3225  return -1;
3226 }
3227 #endif
3228
3229 #ifndef HAS_FGETPOS
3230 #undef PerlIO_getpos
3231 int
3232 PerlIO_getpos(PerlIO *f, SV *pos)
3233 {
3234  dTHX;
3235  Off_t posn = PerlIO_tell(f);
3236  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3237  return (posn == (Off_t)-1) ? -1 : 0;
3238 }
3239 #else
3240 #undef PerlIO_getpos
3241 int
3242 PerlIO_getpos(PerlIO *f, SV *pos)
3243 {
3244  dTHX;
3245  Fpos_t fpos;
3246  int code;
3247 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3248  code = fgetpos64(f, &fpos);
3249 #else
3250  code = fgetpos(f, &fpos);
3251 #endif
3252  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3253  return code;
3254 }
3255 #endif
3256
3257 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3258
3259 int
3260 vprintf(char *pat, char *args)
3261 {
3262     _doprnt(pat, args, stdout);
3263     return 0;           /* wrong, but perl doesn't use the return value */
3264 }
3265
3266 int
3267 vfprintf(FILE *fd, char *pat, char *args)
3268 {
3269     _doprnt(pat, args, fd);
3270     return 0;           /* wrong, but perl doesn't use the return value */
3271 }
3272
3273 #endif
3274
3275 #ifndef PerlIO_vsprintf
3276 int
3277 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3278 {
3279  int val = vsprintf(s, fmt, ap);
3280  if (n >= 0)
3281   {
3282    if (strlen(s) >= (STRLEN)n)
3283     {
3284      dTHX;
3285      (void)PerlIO_puts(Perl_error_log,
3286                        "panic: sprintf overflow - memory corrupted!\n");
3287      my_exit(1);
3288     }
3289   }
3290  return val;
3291 }
3292 #endif
3293
3294 #ifndef PerlIO_sprintf
3295 int
3296 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3297 {
3298  va_list ap;
3299  int result;
3300  va_start(ap,fmt);
3301  result = PerlIO_vsprintf(s, n, fmt, ap);
3302  va_end(ap);
3303  return result;
3304 }
3305 #endif
3306
3307