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