perlio.c

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