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