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