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