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