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