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  if (*mode || oflags == -1)
 954   {
 955    errno = EINVAL;
 956    oflags = -1;
 957   }
 958  return oflags;
 959 }
 960
 961 IV
 962 PerlIOUnix_fileno(PerlIO *f)
 963 {
 964  return PerlIOSelf(f,PerlIOUnix)->fd;
 965 }
 966
 967 PerlIO *
 968 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 969 {
 970  PerlIO *f = NULL;
 971  if (*mode == 'I')
 972   mode++;
 973  if (fd >= 0)
 974   {
 975    int oflags = PerlIOUnix_oflags(mode);
 976    if (oflags != -1)
 977     {
 978      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 979      s->fd     = fd;
 980      s->oflags = oflags;
 981      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 982     }
 983   }
 984  return f;
 985 }
 986
 987 PerlIO *
 988 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
 989 {
 990  PerlIO *f = NULL;
 991  int oflags = PerlIOUnix_oflags(mode);
 992  if (oflags != -1)
 993   {
 994    int fd = PerlLIO_open3(path,oflags,0666);
 995    if (fd >= 0)
 996     {
 997      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 998      s->fd     = fd;
 999      s->oflags = oflags;
1000      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1001     }
1002   }
1003  return f;
1004 }
1005
1006 int
1007 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1008 {
1009  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1010  int oflags = PerlIOUnix_oflags(mode);
1011  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1012   (*PerlIOBase(f)->tab->Close)(f);
1013  if (oflags != -1)
1014   {
1015    int fd = PerlLIO_open3(path,oflags,0666);
1016    if (fd >= 0)
1017     {
1018      s->fd = fd;
1019      s->oflags = oflags;
1020      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1021      return 0;
1022     }
1023   }
1024  return -1;
1025 }
1026
1027 SSize_t
1028 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1029 {
1030  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1031  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1032   return 0;
1033  while (1)
1034   {
1035    SSize_t len = PerlLIO_read(fd,vbuf,count);
1036    if (len >= 0 || errno != EINTR)
1037     {
1038      if (len < 0)
1039       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1040      else if (len == 0 && count != 0)
1041       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1042      return len;
1043     }
1044   }
1045 }
1046
1047 SSize_t
1048 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1049 {
1050  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1051  while (1)
1052   {
1053    SSize_t len = PerlLIO_write(fd,vbuf,count);
1054    if (len >= 0 || errno != EINTR)
1055     {
1056      if (len < 0)
1057       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1058      return len;
1059     }
1060   }
1061 }
1062
1063 IV
1064 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1065 {
1066  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1067  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1068  return (new == (Off_t) -1) ? -1 : 0;
1069 }
1070
1071 Off_t
1072 PerlIOUnix_tell(PerlIO *f)
1073 {
1074  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1075 }
1076
1077 IV
1078 PerlIOUnix_close(PerlIO *f)
1079 {
1080  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1081  int code = 0;
1082  while (PerlLIO_close(fd) != 0)
1083   {
1084    if (errno != EINTR)
1085     {
1086      code = -1;
1087      break;
1088     }
1089   }
1090  if (code == 0)
1091   {
1092    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1093   }
1094  return code;
1095 }
1096
1097 PerlIO_funcs PerlIO_unix = {
1098  "unix",
1099  sizeof(PerlIOUnix),
1100  0,
1101  PerlIOUnix_fileno,
1102  PerlIOUnix_fdopen,
1103  PerlIOUnix_open,
1104  PerlIOUnix_reopen,
1105  PerlIOBase_pushed,
1106  PerlIOBase_noop_ok,
1107  PerlIOUnix_read,
1108  PerlIOBase_unread,
1109  PerlIOUnix_write,
1110  PerlIOUnix_seek,
1111  PerlIOUnix_tell,
1112  PerlIOUnix_close,
1113  PerlIOBase_noop_ok,   /* flush */
1114  PerlIOBase_noop_fail, /* fill */
1115  PerlIOBase_eof,
1116  PerlIOBase_error,
1117  PerlIOBase_clearerr,
1118  PerlIOBase_setlinebuf,
1119  NULL, /* get_base */
1120  NULL, /* get_bufsiz */
1121  NULL, /* get_ptr */
1122  NULL, /* get_cnt */
1123  NULL, /* set_ptrcnt */
1124 };
1125
1126 /*--------------------------------------------------------------------------------------*/
1127 /* stdio as a layer */
1128
1129 typedef struct
1130 {
1131  struct _PerlIO base;
1132  FILE *         stdio;      /* The stream */
1133 } PerlIOStdio;
1134
1135 IV
1136 PerlIOStdio_fileno(PerlIO *f)
1137 {
1138  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1139 }
1140
1141
1142 PerlIO *
1143 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1144 {
1145  PerlIO *f = NULL;
1146  int init = 0;
1147  if (*mode == 'I')
1148   {
1149    init = 1;
1150    mode++;
1151   }
1152  if (fd >= 0)
1153   {
1154    FILE *stdio = NULL;
1155    if (init)
1156     {
1157      switch(fd)
1158       {
1159        case 0:
1160         stdio = stdin;
1161         break;
1162        case 1:
1163         stdio = stdout;
1164         break;
1165        case 2:
1166         stdio = stderr;
1167         break;
1168       }
1169     }
1170    else
1171     stdio = fdopen(fd,mode);
1172    if (stdio)
1173     {
1174      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1175      s->stdio  = stdio;
1176     }
1177   }
1178  return f;
1179 }
1180
1181 #undef PerlIO_importFILE
1182 PerlIO *
1183 PerlIO_importFILE(FILE *stdio, int fl)
1184 {
1185  PerlIO *f = NULL;
1186  if (stdio)
1187   {
1188    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1189    s->stdio  = stdio;
1190   }
1191  return f;
1192 }
1193
1194 PerlIO *
1195 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1196 {
1197  PerlIO *f = NULL;
1198  FILE *stdio = fopen(path,mode);
1199  if (stdio)
1200   {
1201    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1202    s->stdio  = stdio;
1203   }
1204  return f;
1205 }
1206
1207 int
1208 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1209 {
1210  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1211  FILE *stdio = freopen(path,mode,s->stdio);
1212  if (!s->stdio)
1213   return -1;
1214  s->stdio = stdio;
1215  return 0;
1216 }
1217
1218 SSize_t
1219 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1220 {
1221  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1222  SSize_t got = 0;
1223  if (count == 1)
1224   {
1225    STDCHAR *buf = (STDCHAR *) vbuf;
1226    /* Perl is expecting PerlIO_getc() to fill the buffer
1227     * Linux's stdio does not do that for fread()
1228     */
1229    int ch = fgetc(s);
1230    if (ch != EOF)
1231     {
1232      *buf = ch;
1233      got = 1;
1234     }
1235   }
1236  else
1237   got = fread(vbuf,1,count,s);
1238  return got;
1239 }
1240
1241 SSize_t
1242 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1243 {
1244  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1245  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1246  SSize_t unread = 0;
1247  while (count > 0)
1248   {
1249    int ch = *buf-- & 0xff;
1250    if (ungetc(ch,s) != ch)
1251     break;
1252    unread++;
1253    count--;
1254   }
1255  return unread;
1256 }
1257
1258 SSize_t
1259 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1260 {
1261  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1262 }
1263
1264 IV
1265 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1266 {
1267  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1268  return fseek(stdio,offset,whence);
1269 }
1270
1271 Off_t
1272 PerlIOStdio_tell(PerlIO *f)
1273 {
1274  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1275  return ftell(stdio);
1276 }
1277
1278 IV
1279 PerlIOStdio_close(PerlIO *f)
1280 {
1281  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1282  return fclose(stdio);
1283 }
1284
1285 IV
1286 PerlIOStdio_flush(PerlIO *f)
1287 {
1288  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1289  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1290   {
1291    return fflush(stdio);
1292   }
1293  else
1294   {
1295 #if 0
1296    /* FIXME: This discards ungetc() and pre-read stuff which is
1297       not right if this is just a "sync" from a layer above
1298       Suspect right design is to do _this_ but not have layer above
1299       flush this layer read-to-read
1300     */
1301    /* Not writeable - sync by attempting a seek */
1302    int err = errno;
1303    if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1304     errno = err;
1305 #endif
1306   }
1307  return 0;
1308 }
1309
1310 IV
1311 PerlIOStdio_fill(PerlIO *f)
1312 {
1313  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1314  int c;
1315  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1316  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1317   {
1318    if (fflush(stdio) != 0)
1319     return EOF;
1320   }
1321  c = fgetc(stdio);
1322  if (c == EOF || ungetc(c,stdio) != c)
1323   return EOF;
1324  return 0;
1325 }
1326
1327 IV
1328 PerlIOStdio_eof(PerlIO *f)
1329 {
1330  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1331 }
1332
1333 IV
1334 PerlIOStdio_error(PerlIO *f)
1335 {
1336  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1337 }
1338
1339 void
1340 PerlIOStdio_clearerr(PerlIO *f)
1341 {
1342  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1343 }
1344
1345 void
1346 PerlIOStdio_setlinebuf(PerlIO *f)
1347 {
1348 #ifdef HAS_SETLINEBUF
1349  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1350 #else
1351  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1352 #endif
1353 }
1354
1355 #ifdef FILE_base
1356 STDCHAR *
1357 PerlIOStdio_get_base(PerlIO *f)
1358 {
1359  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1360  return FILE_base(stdio);
1361 }
1362
1363 Size_t
1364 PerlIOStdio_get_bufsiz(PerlIO *f)
1365 {
1366  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1367  return FILE_bufsiz(stdio);
1368 }
1369 #endif
1370
1371 #ifdef USE_STDIO_PTR
1372 STDCHAR *
1373 PerlIOStdio_get_ptr(PerlIO *f)
1374 {
1375  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1376  return FILE_ptr(stdio);
1377 }
1378
1379 SSize_t
1380 PerlIOStdio_get_cnt(PerlIO *f)
1381 {
1382  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1383  return FILE_cnt(stdio);
1384 }
1385
1386 void
1387 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1388 {
1389  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1390  if (ptr != NULL)
1391   {
1392 #ifdef STDIO_PTR_LVALUE
1393    FILE_ptr(stdio) = ptr;
1394 #ifdef STDIO_PTR_LVAL_SETS_CNT
1395    if (FILE_cnt(stdio) != (cnt))
1396     {
1397      dTHX;
1398      assert(FILE_cnt(stdio) == (cnt));
1399     }
1400 #endif
1401 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1402    /* Setting ptr _does_ change cnt - we are done */
1403    return;
1404 #endif
1405 #else  /* STDIO_PTR_LVALUE */
1406    abort();
1407 #endif /* STDIO_PTR_LVALUE */
1408   }
1409 /* Now (or only) set cnt */
1410 #ifdef STDIO_CNT_LVALUE
1411  FILE_cnt(stdio) = cnt;
1412 #else  /* STDIO_CNT_LVALUE */
1413 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1414  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1415 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1416  abort();
1417 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1418 #endif /* STDIO_CNT_LVALUE */
1419 }
1420
1421 #endif
1422
1423 PerlIO_funcs PerlIO_stdio = {
1424  "stdio",
1425  sizeof(PerlIOStdio),
1426  0,
1427  PerlIOStdio_fileno,
1428  PerlIOStdio_fdopen,
1429  PerlIOStdio_open,
1430  PerlIOStdio_reopen,
1431  PerlIOBase_pushed,
1432  PerlIOBase_noop_ok,
1433  PerlIOStdio_read,
1434  PerlIOStdio_unread,
1435  PerlIOStdio_write,
1436  PerlIOStdio_seek,
1437  PerlIOStdio_tell,
1438  PerlIOStdio_close,
1439  PerlIOStdio_flush,
1440  PerlIOStdio_fill,
1441  PerlIOStdio_eof,
1442  PerlIOStdio_error,
1443  PerlIOStdio_clearerr,
1444  PerlIOStdio_setlinebuf,
1445 #ifdef FILE_base
1446  PerlIOStdio_get_base,
1447  PerlIOStdio_get_bufsiz,
1448 #else
1449  NULL,
1450  NULL,
1451 #endif
1452 #ifdef USE_STDIO_PTR
1453  PerlIOStdio_get_ptr,
1454  PerlIOStdio_get_cnt,
1455 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1456  PerlIOStdio_set_ptrcnt
1457 #else  /* STDIO_PTR_LVALUE */
1458  NULL
1459 #endif /* STDIO_PTR_LVALUE */
1460 #else  /* USE_STDIO_PTR */
1461  NULL,
1462  NULL,
1463  NULL
1464 #endif /* USE_STDIO_PTR */
1465 };
1466
1467 #undef PerlIO_exportFILE
1468 FILE *
1469 PerlIO_exportFILE(PerlIO *f, int fl)
1470 {
1471  PerlIO_flush(f);
1472  /* Should really push stdio discipline when we have them */
1473  return fdopen(PerlIO_fileno(f),"r+");
1474 }
1475
1476 #undef PerlIO_findFILE
1477 FILE *
1478 PerlIO_findFILE(PerlIO *f)
1479 {
1480  return PerlIO_exportFILE(f,0);
1481 }
1482
1483 #undef PerlIO_releaseFILE
1484 void
1485 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1486 {
1487 }
1488
1489 /*--------------------------------------------------------------------------------------*/
1490 /* perlio buffer layer */
1491
1492 PerlIO *
1493 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1494 {
1495  PerlIO_funcs *tab = PerlIO_default_btm();
1496  int init = 0;
1497  PerlIO *f;
1498  if (*mode == 'I')
1499   {
1500    init = 1;
1501    mode++;
1502   }
1503  f = (*tab->Fdopen)(tab,fd,mode);
1504  if (f)
1505   {
1506    /* Initial stderr is unbuffered */
1507    if (!init || fd != 2)
1508     {
1509      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1510      b->posn = PerlIO_tell(PerlIONext(f));
1511     }
1512   }
1513  return f;
1514 }
1515
1516 PerlIO *
1517 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1518 {
1519  PerlIO_funcs *tab = PerlIO_default_btm();
1520  PerlIO *f = (*tab->Open)(tab,path,mode);
1521  if (f)
1522   {
1523    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1524    b->posn = PerlIO_tell(PerlIONext(f));
1525   }
1526  return f;
1527 }
1528
1529 int
1530 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1531 {
1532  PerlIO *next = PerlIONext(f);
1533  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1534  if (code = 0)
1535   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1536  if (code == 0)
1537   {
1538    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1539    b->posn = PerlIO_tell(PerlIONext(f));
1540   }
1541  return code;
1542 }
1543
1544 /* This "flush" is akin to sfio's sync in that it handles files in either
1545    read or write state
1546 */
1547 IV
1548 PerlIOBuf_flush(PerlIO *f)
1549 {
1550  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1551  int code = 0;
1552  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1553   {
1554    /* write() the buffer */
1555    STDCHAR *p = b->buf;
1556    int count;
1557    PerlIO *n = PerlIONext(f);
1558    while (p < b->ptr)
1559     {
1560      count = PerlIO_write(n,p,b->ptr - p);
1561      if (count > 0)
1562       {
1563        p += count;
1564       }
1565      else if (count < 0 || PerlIO_error(n))
1566       {
1567        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1568        code = -1;
1569        break;
1570       }
1571     }
1572    b->posn += (p - b->buf);
1573   }
1574  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1575   {
1576    /* Note position change */
1577    b->posn += (b->ptr - b->buf);
1578    if (b->ptr < b->end)
1579     {
1580      /* We did not consume all of it */
1581      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1582       {
1583        b->posn = PerlIO_tell(PerlIONext(f));
1584       }
1585     }
1586   }
1587  b->ptr = b->end = b->buf;
1588  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1589  /* FIXME: Is this right for read case ? */
1590  if (PerlIO_flush(PerlIONext(f)) != 0)
1591   code = -1;
1592  return code;
1593 }
1594
1595 IV
1596 PerlIOBuf_fill(PerlIO *f)
1597 {
1598  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1599  PerlIO *n = PerlIONext(f);
1600  SSize_t avail;
1601  /* FIXME: doing the down-stream flush is a bad idea if it causes
1602     pre-read data in stdio buffer to be discarded
1603     but this is too simplistic - as it skips _our_ hosekeeping
1604     and breaks tell tests.
1605  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1606   {
1607   }
1608   */
1609  if (PerlIO_flush(f) != 0)
1610   return -1;
1611
1612  b->ptr = b->end = b->buf;
1613  if (PerlIO_fast_gets(n))
1614   {
1615    /* Layer below is also buffered
1616     * We do _NOT_ want to call its ->Read() because that will loop
1617     * till it gets what we asked for which may hang on a pipe etc.
1618     * Instead take anything it has to hand, or ask it to fill _once_.
1619     */
1620    avail  = PerlIO_get_cnt(n);
1621    if (avail <= 0)
1622     {
1623      avail = PerlIO_fill(n);
1624      if (avail == 0)
1625       avail = PerlIO_get_cnt(n);
1626      else
1627       {
1628        if (!PerlIO_error(n) && PerlIO_eof(n))
1629         avail = 0;
1630       }
1631     }
1632    if (avail > 0)
1633     {
1634      STDCHAR *ptr = PerlIO_get_ptr(n);
1635      SSize_t cnt  = avail;
1636      if (avail > b->bufsiz)
1637       avail = b->bufsiz;
1638      Copy(ptr,b->buf,avail,STDCHAR);
1639      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1640     }
1641   }
1642  else
1643   {
1644    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1645   }
1646  if (avail <= 0)
1647   {
1648    if (avail == 0)
1649     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1650    else
1651     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1652    return -1;
1653   }
1654  b->end      = b->buf+avail;
1655  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1656  return 0;
1657 }
1658
1659 SSize_t
1660 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1661 {
1662  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1663  STDCHAR *buf = (STDCHAR *) vbuf;
1664  if (f)
1665   {
1666    Size_t got = 0;
1667    if (!b->ptr)
1668     PerlIO_get_base(f);
1669    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1670     return 0;
1671    while (count > 0)
1672     {
1673      SSize_t avail = (b->end - b->ptr);
1674      if ((SSize_t) count < avail)
1675       avail = count;
1676      if (avail > 0)
1677       {
1678        Copy(b->ptr,buf,avail,STDCHAR);
1679        got     += avail;
1680        b->ptr  += avail;
1681        count   -= avail;
1682        buf     += avail;
1683       }
1684      if (count && (b->ptr >= b->end))
1685       {
1686        if (PerlIO_fill(f) != 0)
1687         break;
1688       }
1689     }
1690    return got;
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 currently just a copy of perlio to prove
1933    that extra buffering which real one will do is not an issue.
1934  */
1935
1936 PerlIO_funcs PerlIO_crlf = {
1937  "crlf",
1938  sizeof(PerlIOBuf),
1939  0,
1940  PerlIOBase_fileno,
1941  PerlIOBuf_fdopen,
1942  PerlIOBuf_open,
1943  PerlIOBuf_reopen,
1944  PerlIOBase_pushed,
1945  PerlIOBase_noop_ok,
1946  PerlIOBuf_read,
1947  PerlIOBuf_unread,
1948  PerlIOBuf_write,
1949  PerlIOBuf_seek,
1950  PerlIOBuf_tell,
1951  PerlIOBuf_close,
1952  PerlIOBuf_flush,
1953  PerlIOBuf_fill,
1954  PerlIOBase_eof,
1955  PerlIOBase_error,
1956  PerlIOBase_clearerr,
1957  PerlIOBuf_setlinebuf,
1958  PerlIOBuf_get_base,
1959  PerlIOBuf_bufsiz,
1960  PerlIOBuf_get_ptr,
1961  PerlIOBuf_get_cnt,
1962  PerlIOBuf_set_ptrcnt,
1963 };
1964
1965 #ifdef HAS_MMAP
1966 /*--------------------------------------------------------------------------------------*/
1967 /* mmap as "buffer" layer */
1968
1969 typedef struct
1970 {
1971  PerlIOBuf      base;         /* PerlIOBuf stuff */
1972  Mmap_t         mptr;        /* Mapped address */
1973  Size_t         len;          /* mapped length */
1974  STDCHAR        *bbuf;        /* malloced buffer if map fails */
1975
1976 } PerlIOMmap;
1977
1978 static size_t page_size = 0;
1979
1980 IV
1981 PerlIOMmap_map(PerlIO *f)
1982 {
1983  dTHX;
1984  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1985  PerlIOBuf  *b = &m->base;
1986  IV flags = PerlIOBase(f)->flags;
1987  IV code  = 0;
1988  if (m->len)
1989   abort();
1990  if (flags & PERLIO_F_CANREAD)
1991   {
1992    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1993    int fd   = PerlIO_fileno(f);
1994    struct stat st;
1995    code = fstat(fd,&st);
1996    if (code == 0 && S_ISREG(st.st_mode))
1997     {
1998      SSize_t len = st.st_size - b->posn;
1999      if (len > 0)
2000       {
2001        Off_t posn;
2002        if (!page_size) {
2003 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2004            {
2005                SETERRNO(0,SS$_NORMAL);
2006 #   ifdef _SC_PAGESIZE
2007                page_size = sysconf(_SC_PAGESIZE);
2008 #   else
2009                page_size = sysconf(_SC_PAGE_SIZE);
2010 #   endif
2011                if ((long)page_size < 0) {
2012                    if (errno) {
2013                        SV *error = ERRSV;
2014                        char *msg;
2015                        STRLEN n_a;
2016                        (void)SvUPGRADE(error, SVt_PV);
2017                        msg = SvPVx(error, n_a);
2018                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2019                    }
2020                    else
2021                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2022                }
2023            }
2024 #else
2025 #   ifdef HAS_GETPAGESIZE
2026         page_size = getpagesize();
2027 #   else
2028 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2029         page_size = PAGESIZE; /* compiletime, bad */
2030 #       endif
2031 #   endif
2032 #endif
2033         if ((IV)page_size <= 0)
2034             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2035        }
2036        if (b->posn < 0)
2037         {
2038          /* This is a hack - should never happen - open should have set it ! */
2039          b->posn = PerlIO_tell(PerlIONext(f));
2040         }
2041        posn = (b->posn / page_size) * page_size;
2042        len  = st.st_size - posn;
2043        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2044        if (m->mptr && m->mptr != (Mmap_t) -1)
2045         {
2046 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2047          madvise(m->mptr, len, MADV_SEQUENTIAL);
2048 #endif
2049          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2050          b->end  = ((STDCHAR *)m->mptr) + len;
2051          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2052          b->ptr  = b->buf;
2053          m->len  = len;
2054         }
2055        else
2056         {
2057          b->buf = NULL;
2058         }
2059       }
2060      else
2061       {
2062        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2063        b->buf = NULL;
2064        b->ptr = b->end = b->ptr;
2065        code = -1;
2066       }
2067     }
2068   }
2069  return code;
2070 }
2071
2072 IV
2073 PerlIOMmap_unmap(PerlIO *f)
2074 {
2075  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2076  PerlIOBuf  *b = &m->base;
2077  IV code = 0;
2078  if (m->len)
2079   {
2080    if (b->buf)
2081     {
2082      code = munmap(m->mptr, m->len);
2083      b->buf  = NULL;
2084      m->len  = 0;
2085      m->mptr = NULL;
2086      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2087       code = -1;
2088     }
2089    b->ptr = b->end = b->buf;
2090    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2091   }
2092  return code;
2093 }
2094
2095 STDCHAR *
2096 PerlIOMmap_get_base(PerlIO *f)
2097 {
2098  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2099  PerlIOBuf  *b = &m->base;
2100  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2101   {
2102    /* Already have a readbuffer in progress */
2103    return b->buf;
2104   }
2105  if (b->buf)
2106   {
2107    /* We have a write buffer or flushed PerlIOBuf read buffer */
2108    m->bbuf = b->buf;  /* save it in case we need it again */
2109    b->buf  = NULL;    /* Clear to trigger below */
2110   }
2111  if (!b->buf)
2112   {
2113    PerlIOMmap_map(f);     /* Try and map it */
2114    if (!b->buf)
2115     {
2116      /* Map did not work - recover PerlIOBuf buffer if we have one */
2117      b->buf = m->bbuf;
2118     }
2119   }
2120  b->ptr  = b->end = b->buf;
2121  if (b->buf)
2122   return b->buf;
2123  return PerlIOBuf_get_base(f);
2124 }
2125
2126 SSize_t
2127 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2128 {
2129  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2130  PerlIOBuf  *b = &m->base;
2131  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2132   PerlIO_flush(f);
2133  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2134   {
2135    b->ptr -= count;
2136    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2137    return count;
2138   }
2139  if (m->len)
2140   {
2141    /* Loose the unwritable mapped buffer */
2142    PerlIO_flush(f);
2143    /* If flush took the "buffer" see if we have one from before */
2144    if (!b->buf && m->bbuf)
2145     b->buf = m->bbuf;
2146    if (!b->buf)
2147     {
2148      PerlIOBuf_get_base(f);
2149      m->bbuf = b->buf;
2150     }
2151   }
2152  return PerlIOBuf_unread(f,vbuf,count);
2153 }
2154
2155 SSize_t
2156 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2157 {
2158  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2159  PerlIOBuf  *b = &m->base;
2160  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2161   {
2162    /* No, or wrong sort of, buffer */
2163    if (m->len)
2164     {
2165      if (PerlIOMmap_unmap(f) != 0)
2166       return 0;
2167     }
2168    /* If unmap took the "buffer" see if we have one from before */
2169    if (!b->buf && m->bbuf)
2170     b->buf = m->bbuf;
2171    if (!b->buf)
2172     {
2173      PerlIOBuf_get_base(f);
2174      m->bbuf = b->buf;
2175     }
2176   }
2177  return PerlIOBuf_write(f,vbuf,count);
2178 }
2179
2180 IV
2181 PerlIOMmap_flush(PerlIO *f)
2182 {
2183  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2184  PerlIOBuf  *b = &m->base;
2185  IV code = PerlIOBuf_flush(f);
2186  /* Now we are "synced" at PerlIOBuf level */
2187  if (b->buf)
2188   {
2189    if (m->len)
2190     {
2191      /* Unmap the buffer */
2192      if (PerlIOMmap_unmap(f) != 0)
2193       code = -1;
2194     }
2195    else
2196     {
2197      /* We seem to have a PerlIOBuf buffer which was not mapped
2198       * remember it in case we need one later
2199       */
2200      m->bbuf = b->buf;
2201     }
2202   }
2203  return code;
2204 }
2205
2206 IV
2207 PerlIOMmap_fill(PerlIO *f)
2208 {
2209  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2210  IV code = PerlIO_flush(f);
2211  if (code == 0 && !b->buf)
2212   {
2213    code = PerlIOMmap_map(f);
2214   }
2215  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2216   {
2217    code = PerlIOBuf_fill(f);
2218   }
2219  return code;
2220 }
2221
2222 IV
2223 PerlIOMmap_close(PerlIO *f)
2224 {
2225  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2226  PerlIOBuf  *b = &m->base;
2227  IV code = PerlIO_flush(f);
2228  if (m->bbuf)
2229   {
2230    b->buf  = m->bbuf;
2231    m->bbuf = NULL;
2232    b->ptr  = b->end = b->buf;
2233   }
2234  if (PerlIOBuf_close(f) != 0)
2235   code = -1;
2236  return code;
2237 }
2238
2239
2240 PerlIO_funcs PerlIO_mmap = {
2241  "mmap",
2242  sizeof(PerlIOMmap),
2243  0,
2244  PerlIOBase_fileno,
2245  PerlIOBuf_fdopen,
2246  PerlIOBuf_open,
2247  PerlIOBuf_reopen,
2248  PerlIOBase_pushed,
2249  PerlIOBase_noop_ok,
2250  PerlIOBuf_read,
2251  PerlIOMmap_unread,
2252  PerlIOMmap_write,
2253  PerlIOBuf_seek,
2254  PerlIOBuf_tell,
2255  PerlIOBuf_close,
2256  PerlIOMmap_flush,
2257  PerlIOMmap_fill,
2258  PerlIOBase_eof,
2259  PerlIOBase_error,
2260  PerlIOBase_clearerr,
2261  PerlIOBuf_setlinebuf,
2262  PerlIOMmap_get_base,
2263  PerlIOBuf_bufsiz,
2264  PerlIOBuf_get_ptr,
2265  PerlIOBuf_get_cnt,
2266  PerlIOBuf_set_ptrcnt,
2267 };
2268
2269 #endif /* HAS_MMAP */
2270
2271 void
2272 PerlIO_init(void)
2273 {
2274  if (!_perlio)
2275   {
2276    atexit(&PerlIO_cleanup);
2277   }
2278 }
2279
2280 #undef PerlIO_stdin
2281 PerlIO *
2282 PerlIO_stdin(void)
2283 {
2284  if (!_perlio)
2285   PerlIO_stdstreams();
2286  return &_perlio[1];
2287 }
2288
2289 #undef PerlIO_stdout
2290 PerlIO *
2291 PerlIO_stdout(void)
2292 {
2293  if (!_perlio)
2294   PerlIO_stdstreams();
2295  return &_perlio[2];
2296 }
2297
2298 #undef PerlIO_stderr
2299 PerlIO *
2300 PerlIO_stderr(void)
2301 {
2302  if (!_perlio)
2303   PerlIO_stdstreams();
2304  return &_perlio[3];
2305 }
2306
2307 /*--------------------------------------------------------------------------------------*/
2308
2309 #undef PerlIO_getname
2310 char *
2311 PerlIO_getname(PerlIO *f, char *buf)
2312 {
2313  dTHX;
2314  Perl_croak(aTHX_ "Don't know how to get file name");
2315  return NULL;
2316 }
2317
2318
2319 /*--------------------------------------------------------------------------------------*/
2320 /* Functions which can be called on any kind of PerlIO implemented
2321    in terms of above
2322 */
2323
2324 #undef PerlIO_getc
2325 int
2326 PerlIO_getc(PerlIO *f)
2327 {
2328  STDCHAR buf[1];
2329  SSize_t count = PerlIO_read(f,buf,1);
2330  if (count == 1)
2331   {
2332    return (unsigned char) buf[0];
2333   }
2334  return EOF;
2335 }
2336
2337 #undef PerlIO_ungetc
2338 int
2339 PerlIO_ungetc(PerlIO *f, int ch)
2340 {
2341  if (ch != EOF)
2342   {
2343    STDCHAR buf = ch;
2344    if (PerlIO_unread(f,&buf,1) == 1)
2345     return ch;
2346   }
2347  return EOF;
2348 }
2349
2350 #undef PerlIO_putc
2351 int
2352 PerlIO_putc(PerlIO *f, int ch)
2353 {
2354  STDCHAR buf = ch;
2355  return PerlIO_write(f,&buf,1);
2356 }
2357
2358 #undef PerlIO_puts
2359 int
2360 PerlIO_puts(PerlIO *f, const char *s)
2361 {
2362  STRLEN len = strlen(s);
2363  return PerlIO_write(f,s,len);
2364 }
2365
2366 #undef PerlIO_rewind
2367 void
2368 PerlIO_rewind(PerlIO *f)
2369 {
2370  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2371  PerlIO_clearerr(f);
2372 }
2373
2374 #undef PerlIO_vprintf
2375 int
2376 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2377 {
2378  dTHX;
2379  SV *sv = newSVpvn("",0);
2380  char *s;
2381  STRLEN len;
2382 #ifdef NEED_VA_COPY
2383  va_list apc;
2384  Perl_va_copy(ap, apc);
2385  sv_vcatpvf(sv, fmt, &apc);
2386 #else
2387  sv_vcatpvf(sv, fmt, &ap);
2388 #endif
2389  s = SvPV(sv,len);
2390  return PerlIO_write(f,s,len);
2391 }
2392
2393 #undef PerlIO_printf
2394 int
2395 PerlIO_printf(PerlIO *f,const char *fmt,...)
2396 {
2397  va_list ap;
2398  int result;
2399  va_start(ap,fmt);
2400  result = PerlIO_vprintf(f,fmt,ap);
2401  va_end(ap);
2402  return result;
2403 }
2404
2405 #undef PerlIO_stdoutf
2406 int
2407 PerlIO_stdoutf(const char *fmt,...)
2408 {
2409  va_list ap;
2410  int result;
2411  va_start(ap,fmt);
2412  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2413  va_end(ap);
2414  return result;
2415 }
2416
2417 #undef PerlIO_tmpfile
2418 PerlIO *
2419 PerlIO_tmpfile(void)
2420 {
2421  /* I have no idea how portable mkstemp() is ... */
2422 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2423  PerlIO *f = NULL;
2424  FILE *stdio = tmpfile();
2425  if (stdio)
2426   {
2427    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2428    s->stdio  = stdio;
2429   }
2430  return f;
2431 #else
2432  dTHX;
2433  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2434  int fd = mkstemp(SvPVX(sv));
2435  PerlIO *f = NULL;
2436  if (fd >= 0)
2437   {
2438    f = PerlIO_fdopen(fd,"w+");
2439    if (f)
2440     {
2441      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2442     }
2443    PerlLIO_unlink(SvPVX(sv));
2444    SvREFCNT_dec(sv);
2445   }
2446  return f;
2447 #endif
2448 }
2449
2450 #undef HAS_FSETPOS
2451 #undef HAS_FGETPOS
2452
2453 #endif /* USE_SFIO */
2454 #endif /* PERLIO_IS_STDIO */
2455
2456 /*======================================================================================*/
2457 /* Now some functions in terms of above which may be needed even if
2458    we are not in true PerlIO mode
2459  */
2460
2461 #ifndef HAS_FSETPOS
2462 #undef PerlIO_setpos
2463 int
2464 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2465 {
2466  return PerlIO_seek(f,*pos,0);
2467 }
2468 #else
2469 #ifndef PERLIO_IS_STDIO
2470 #undef PerlIO_setpos
2471 int
2472 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2473 {
2474 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2475  return fsetpos64(f, pos);
2476 #else
2477  return fsetpos(f, pos);
2478 #endif
2479 }
2480 #endif
2481 #endif
2482
2483 #ifndef HAS_FGETPOS
2484 #undef PerlIO_getpos
2485 int
2486 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2487 {
2488  *pos = PerlIO_tell(f);
2489  return *pos == -1 ? -1 : 0;
2490 }
2491 #else
2492 #ifndef PERLIO_IS_STDIO
2493 #undef PerlIO_getpos
2494 int
2495 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2496 {
2497 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2498  return fgetpos64(f, pos);
2499 #else
2500  return fgetpos(f, pos);
2501 #endif
2502 }
2503 #endif
2504 #endif
2505
2506 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2507
2508 int
2509 vprintf(char *pat, char *args)
2510 {
2511     _doprnt(pat, args, stdout);
2512     return 0;           /* wrong, but perl doesn't use the return value */
2513 }
2514
2515 int
2516 vfprintf(FILE *fd, char *pat, char *args)
2517 {
2518     _doprnt(pat, args, fd);
2519     return 0;           /* wrong, but perl doesn't use the return value */
2520 }
2521
2522 #endif
2523
2524 #ifndef PerlIO_vsprintf
2525 int
2526 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2527 {
2528  int val = vsprintf(s, fmt, ap);
2529  if (n >= 0)
2530   {
2531    if (strlen(s) >= (STRLEN)n)
2532     {
2533      dTHX;
2534      (void)PerlIO_puts(Perl_error_log,
2535                        "panic: sprintf overflow - memory corrupted!\n");
2536      my_exit(1);
2537     }
2538   }
2539  return val;
2540 }
2541 #endif
2542
2543 #ifndef PerlIO_sprintf
2544 int
2545 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2546 {
2547  va_list ap;
2548  int result;
2549  va_start(ap,fmt);
2550  result = PerlIO_vsprintf(s, n, fmt, ap);
2551  va_end(ap);
2552  return result;
2553 }
2554 #endif
2555
2556 #endif /* !PERL_IMPLICIT_SYS */
2557