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  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1372  return fclose(stdio);
1373 }
1374
1375 IV
1376 PerlIOStdio_flush(PerlIO *f)
1377 {
1378  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1379  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1380   {
1381    return fflush(stdio);
1382   }
1383  else
1384   {
1385 #if 0
1386    /* FIXME: This discards ungetc() and pre-read stuff which is
1387       not right if this is just a "sync" from a layer above
1388       Suspect right design is to do _this_ but not have layer above
1389       flush this layer read-to-read
1390     */
1391    /* Not writeable - sync by attempting a seek */
1392    int err = errno;
1393    if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1394     errno = err;
1395 #endif
1396   }
1397  return 0;
1398 }
1399
1400 IV
1401 PerlIOStdio_fill(PerlIO *f)
1402 {
1403  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1404  int c;
1405  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1406  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1407   {
1408    if (fflush(stdio) != 0)
1409     return EOF;
1410   }
1411  c = fgetc(stdio);
1412  if (c == EOF || ungetc(c,stdio) != c)
1413   return EOF;
1414  return 0;
1415 }
1416
1417 IV
1418 PerlIOStdio_eof(PerlIO *f)
1419 {
1420  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1421 }
1422
1423 IV
1424 PerlIOStdio_error(PerlIO *f)
1425 {
1426  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1427 }
1428
1429 void
1430 PerlIOStdio_clearerr(PerlIO *f)
1431 {
1432  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1433 }
1434
1435 void
1436 PerlIOStdio_setlinebuf(PerlIO *f)
1437 {
1438 #ifdef HAS_SETLINEBUF
1439  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1440 #else
1441  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1442 #endif
1443 }
1444
1445 #ifdef FILE_base
1446 STDCHAR *
1447 PerlIOStdio_get_base(PerlIO *f)
1448 {
1449  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1450  return FILE_base(stdio);
1451 }
1452
1453 Size_t
1454 PerlIOStdio_get_bufsiz(PerlIO *f)
1455 {
1456  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1457  return FILE_bufsiz(stdio);
1458 }
1459 #endif
1460
1461 #ifdef USE_STDIO_PTR
1462 STDCHAR *
1463 PerlIOStdio_get_ptr(PerlIO *f)
1464 {
1465  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1466  return FILE_ptr(stdio);
1467 }
1468
1469 SSize_t
1470 PerlIOStdio_get_cnt(PerlIO *f)
1471 {
1472  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1473  return FILE_cnt(stdio);
1474 }
1475
1476 void
1477 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1478 {
1479  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1480  if (ptr != NULL)
1481   {
1482 #ifdef STDIO_PTR_LVALUE
1483    FILE_ptr(stdio) = ptr;
1484 #ifdef STDIO_PTR_LVAL_SETS_CNT
1485    if (FILE_cnt(stdio) != (cnt))
1486     {
1487      dTHX;
1488      assert(FILE_cnt(stdio) == (cnt));
1489     }
1490 #endif
1491 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1492    /* Setting ptr _does_ change cnt - we are done */
1493    return;
1494 #endif
1495 #else  /* STDIO_PTR_LVALUE */
1496    abort();
1497 #endif /* STDIO_PTR_LVALUE */
1498   }
1499 /* Now (or only) set cnt */
1500 #ifdef STDIO_CNT_LVALUE
1501  FILE_cnt(stdio) = cnt;
1502 #else  /* STDIO_CNT_LVALUE */
1503 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1504  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1505 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1506  abort();
1507 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1508 #endif /* STDIO_CNT_LVALUE */
1509 }
1510
1511 #endif
1512
1513 PerlIO_funcs PerlIO_stdio = {
1514  "stdio",
1515  sizeof(PerlIOStdio),
1516  0,
1517  PerlIOStdio_fileno,
1518  PerlIOStdio_fdopen,
1519  PerlIOStdio_open,
1520  PerlIOStdio_reopen,
1521  PerlIOBase_pushed,
1522  PerlIOBase_noop_ok,
1523  PerlIOStdio_read,
1524  PerlIOStdio_unread,
1525  PerlIOStdio_write,
1526  PerlIOStdio_seek,
1527  PerlIOStdio_tell,
1528  PerlIOStdio_close,
1529  PerlIOStdio_flush,
1530  PerlIOStdio_fill,
1531  PerlIOStdio_eof,
1532  PerlIOStdio_error,
1533  PerlIOStdio_clearerr,
1534  PerlIOStdio_setlinebuf,
1535 #ifdef FILE_base
1536  PerlIOStdio_get_base,
1537  PerlIOStdio_get_bufsiz,
1538 #else
1539  NULL,
1540  NULL,
1541 #endif
1542 #ifdef USE_STDIO_PTR
1543  PerlIOStdio_get_ptr,
1544  PerlIOStdio_get_cnt,
1545 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1546  PerlIOStdio_set_ptrcnt
1547 #else  /* STDIO_PTR_LVALUE */
1548  NULL
1549 #endif /* STDIO_PTR_LVALUE */
1550 #else  /* USE_STDIO_PTR */
1551  NULL,
1552  NULL,
1553  NULL
1554 #endif /* USE_STDIO_PTR */
1555 };
1556
1557 #undef PerlIO_exportFILE
1558 FILE *
1559 PerlIO_exportFILE(PerlIO *f, int fl)
1560 {
1561  PerlIO_flush(f);
1562  /* Should really push stdio discipline when we have them */
1563  return fdopen(PerlIO_fileno(f),"r+");
1564 }
1565
1566 #undef PerlIO_findFILE
1567 FILE *
1568 PerlIO_findFILE(PerlIO *f)
1569 {
1570  return PerlIO_exportFILE(f,0);
1571 }
1572
1573 #undef PerlIO_releaseFILE
1574 void
1575 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1576 {
1577 }
1578
1579 /*--------------------------------------------------------------------------------------*/
1580 /* perlio buffer layer */
1581
1582 PerlIO *
1583 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1584 {
1585  PerlIO_funcs *tab = PerlIO_default_btm();
1586  int init = 0;
1587  PerlIO *f;
1588  if (*mode == 'I')
1589   {
1590    init = 1;
1591    mode++;
1592   }
1593  f = (*tab->Fdopen)(tab,fd,mode);
1594  if (f)
1595   {
1596    /* Initial stderr is unbuffered */
1597    if (!init || fd != 2)
1598     {
1599      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1600      b->posn = PerlIO_tell(PerlIONext(f));
1601     }
1602   }
1603  return f;
1604 }
1605
1606 PerlIO *
1607 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1608 {
1609  PerlIO_funcs *tab = PerlIO_default_btm();
1610  PerlIO *f = (*tab->Open)(tab,path,mode);
1611  if (f)
1612   {
1613    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1614    b->posn = PerlIO_tell(PerlIONext(f));
1615   }
1616  return f;
1617 }
1618
1619 int
1620 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1621 {
1622  PerlIO *next = PerlIONext(f);
1623  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1624  if (code = 0)
1625   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1626  if (code == 0)
1627   {
1628    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1629    b->posn = PerlIO_tell(PerlIONext(f));
1630   }
1631  return code;
1632 }
1633
1634 /* This "flush" is akin to sfio's sync in that it handles files in either
1635    read or write state
1636 */
1637 IV
1638 PerlIOBuf_flush(PerlIO *f)
1639 {
1640  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1641  int code = 0;
1642  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1643   {
1644    /* write() the buffer */
1645    STDCHAR *p = b->buf;
1646    int count;
1647    PerlIO *n = PerlIONext(f);
1648    while (p < b->ptr)
1649     {
1650      count = PerlIO_write(n,p,b->ptr - p);
1651      if (count > 0)
1652       {
1653        p += count;
1654       }
1655      else if (count < 0 || PerlIO_error(n))
1656       {
1657        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1658        code = -1;
1659        break;
1660       }
1661     }
1662    b->posn += (p - b->buf);
1663   }
1664  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1665   {
1666    /* Note position change */
1667    b->posn += (b->ptr - b->buf);
1668    if (b->ptr < b->end)
1669     {
1670      /* We did not consume all of it */
1671      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1672       {
1673        b->posn = PerlIO_tell(PerlIONext(f));
1674       }
1675     }
1676   }
1677  b->ptr = b->end = b->buf;
1678  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1679  /* FIXME: Is this right for read case ? */
1680  if (PerlIO_flush(PerlIONext(f)) != 0)
1681   code = -1;
1682  return code;
1683 }
1684
1685 IV
1686 PerlIOBuf_fill(PerlIO *f)
1687 {
1688  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1689  PerlIO *n = PerlIONext(f);
1690  SSize_t avail;
1691  /* FIXME: doing the down-stream flush is a bad idea if it causes
1692     pre-read data in stdio buffer to be discarded
1693     but this is too simplistic - as it skips _our_ hosekeeping
1694     and breaks tell tests.
1695  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1696   {
1697   }
1698   */
1699  if (PerlIO_flush(f) != 0)
1700   return -1;
1701
1702  b->ptr = b->end = b->buf;
1703  if (PerlIO_fast_gets(n))
1704   {
1705    /* Layer below is also buffered
1706     * We do _NOT_ want to call its ->Read() because that will loop
1707     * till it gets what we asked for which may hang on a pipe etc.
1708     * Instead take anything it has to hand, or ask it to fill _once_.
1709     */
1710    avail  = PerlIO_get_cnt(n);
1711    if (avail <= 0)
1712     {
1713      avail = PerlIO_fill(n);
1714      if (avail == 0)
1715       avail = PerlIO_get_cnt(n);
1716      else
1717       {
1718        if (!PerlIO_error(n) && PerlIO_eof(n))
1719         avail = 0;
1720       }
1721     }
1722    if (avail > 0)
1723     {
1724      STDCHAR *ptr = PerlIO_get_ptr(n);
1725      SSize_t cnt  = avail;
1726      if (avail > b->bufsiz)
1727       avail = b->bufsiz;
1728      Copy(ptr,b->buf,avail,STDCHAR);
1729      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1730     }
1731   }
1732  else
1733   {
1734    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1735   }
1736  if (avail <= 0)
1737   {
1738    if (avail == 0)
1739     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1740    else
1741     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1742    return -1;
1743   }
1744  b->end      = b->buf+avail;
1745  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1746  return 0;
1747 }
1748
1749 SSize_t
1750 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1751 {
1752  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1753  STDCHAR *buf  = (STDCHAR *) vbuf;
1754  if (f)
1755   {
1756    if (!b->ptr)
1757     PerlIO_get_base(f);
1758    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1759     return 0;
1760    while (count > 0)
1761     {
1762      SSize_t avail = PerlIO_get_cnt(f);
1763      SSize_t take  = (count < avail) ? count : avail;
1764      if (take > 0)
1765       {
1766        STDCHAR *ptr = PerlIO_get_ptr(f);
1767        Copy(ptr,buf,take,STDCHAR);
1768        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1769        count   -= take;
1770        buf     += take;
1771       }
1772      if (count > 0  && avail <= 0)
1773       {
1774        if (PerlIO_fill(f) != 0)
1775         break;
1776       }
1777     }
1778    return (buf - (STDCHAR *) vbuf);
1779   }
1780  return 0;
1781 }
1782
1783 SSize_t
1784 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1785 {
1786  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1787  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1788  SSize_t unread = 0;
1789  SSize_t avail;
1790  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1791   PerlIO_flush(f);
1792  if (!b->buf)
1793   PerlIO_get_base(f);
1794  if (b->buf)
1795   {
1796    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1797     {
1798      avail = (b->ptr - b->buf);
1799      if (avail > (SSize_t) count)
1800       avail = count;
1801      b->ptr -= avail;
1802     }
1803    else
1804     {
1805      avail = b->bufsiz;
1806      if (avail > (SSize_t) count)
1807       avail = count;
1808      b->end = b->ptr + avail;
1809     }
1810    if (avail > 0)
1811     {
1812      buf    -= avail;
1813      if (buf != b->ptr)
1814       {
1815        Copy(buf,b->ptr,avail,STDCHAR);
1816       }
1817      count  -= avail;
1818      unread += avail;
1819      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1820     }
1821   }
1822  return unread;
1823 }
1824
1825 SSize_t
1826 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1827 {
1828  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1829  const STDCHAR *buf = (const STDCHAR *) vbuf;
1830  Size_t written = 0;
1831  if (!b->buf)
1832   PerlIO_get_base(f);
1833  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1834   return 0;
1835  while (count > 0)
1836   {
1837    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1838    if ((SSize_t) count < avail)
1839     avail = count;
1840    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1841    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1842     {
1843      while (avail > 0)
1844       {
1845        int ch = *buf++;
1846        *(b->ptr)++ = ch;
1847        count--;
1848        avail--;
1849        written++;
1850        if (ch == '\n')
1851         {
1852          PerlIO_flush(f);
1853          break;
1854         }
1855       }
1856     }
1857    else
1858     {
1859      if (avail)
1860       {
1861        Copy(buf,b->ptr,avail,STDCHAR);
1862        count   -= avail;
1863        buf     += avail;
1864        written += avail;
1865        b->ptr  += avail;
1866       }
1867     }
1868    if (b->ptr >= (b->buf + b->bufsiz))
1869     PerlIO_flush(f);
1870   }
1871  return written;
1872 }
1873
1874 IV
1875 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1876 {
1877  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1878  int code = PerlIO_flush(f);
1879  if (code == 0)
1880   {
1881    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1882    code = PerlIO_seek(PerlIONext(f),offset,whence);
1883    if (code == 0)
1884     {
1885      b->posn = PerlIO_tell(PerlIONext(f));
1886     }
1887   }
1888  return code;
1889 }
1890
1891 Off_t
1892 PerlIOBuf_tell(PerlIO *f)
1893 {
1894  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1895  Off_t posn = b->posn;
1896  if (b->buf)
1897   posn += (b->ptr - b->buf);
1898  return posn;
1899 }
1900
1901 IV
1902 PerlIOBuf_close(PerlIO *f)
1903 {
1904  IV code = PerlIOBase_close(f);
1905  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1906  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1907   {
1908    Safefree(b->buf);
1909   }
1910  b->buf = NULL;
1911  b->ptr = b->end = b->buf;
1912  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1913  return code;
1914 }
1915
1916 void
1917 PerlIOBuf_setlinebuf(PerlIO *f)
1918 {
1919  if (f)
1920   {
1921    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1922   }
1923 }
1924
1925 STDCHAR *
1926 PerlIOBuf_get_ptr(PerlIO *f)
1927 {
1928  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1929  if (!b->buf)
1930   PerlIO_get_base(f);
1931  return b->ptr;
1932 }
1933
1934 SSize_t
1935 PerlIOBuf_get_cnt(PerlIO *f)
1936 {
1937  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1938  if (!b->buf)
1939   PerlIO_get_base(f);
1940  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1941   return (b->end - b->ptr);
1942  return 0;
1943 }
1944
1945 STDCHAR *
1946 PerlIOBuf_get_base(PerlIO *f)
1947 {
1948  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1949  if (!b->buf)
1950   {
1951    if (!b->bufsiz)
1952     b->bufsiz = 4096;
1953    New('B',b->buf,b->bufsiz,STDCHAR);
1954    if (!b->buf)
1955     {
1956      b->buf = (STDCHAR *)&b->oneword;
1957      b->bufsiz = sizeof(b->oneword);
1958     }
1959    b->ptr = b->buf;
1960    b->end = b->ptr;
1961   }
1962  return b->buf;
1963 }
1964
1965 Size_t
1966 PerlIOBuf_bufsiz(PerlIO *f)
1967 {
1968  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1969  if (!b->buf)
1970   PerlIO_get_base(f);
1971  return (b->end - b->buf);
1972 }
1973
1974 void
1975 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1976 {
1977  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1978  if (!b->buf)
1979   PerlIO_get_base(f);
1980  b->ptr = ptr;
1981  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1982   {
1983    dTHX;
1984    assert(PerlIO_get_cnt(f) == cnt);
1985    assert(b->ptr >= b->buf);
1986   }
1987  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1988 }
1989
1990 PerlIO_funcs PerlIO_perlio = {
1991  "perlio",
1992  sizeof(PerlIOBuf),
1993  0,
1994  PerlIOBase_fileno,
1995  PerlIOBuf_fdopen,
1996  PerlIOBuf_open,
1997  PerlIOBuf_reopen,
1998  PerlIOBase_pushed,
1999  PerlIOBase_noop_ok,
2000  PerlIOBuf_read,
2001  PerlIOBuf_unread,
2002  PerlIOBuf_write,
2003  PerlIOBuf_seek,
2004  PerlIOBuf_tell,
2005  PerlIOBuf_close,
2006  PerlIOBuf_flush,
2007  PerlIOBuf_fill,
2008  PerlIOBase_eof,
2009  PerlIOBase_error,
2010  PerlIOBase_clearerr,
2011  PerlIOBuf_setlinebuf,
2012  PerlIOBuf_get_base,
2013  PerlIOBuf_bufsiz,
2014  PerlIOBuf_get_ptr,
2015  PerlIOBuf_get_cnt,
2016  PerlIOBuf_set_ptrcnt,
2017 };
2018
2019 /*--------------------------------------------------------------------------------------*/
2020 /* crlf - translation
2021    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2022    to hand back a line at a time and keeping a record of which nl we "lied" about.
2023    On write translate "\n" to CR,LF
2024  */
2025
2026 typedef struct
2027 {
2028  PerlIOBuf      base;         /* PerlIOBuf stuff */
2029  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2030 } PerlIOCrlf;
2031
2032 SSize_t
2033 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2034 {
2035  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2036  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2037  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2038  SSize_t unread = 0;
2039  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2040   PerlIO_flush(f);
2041  if (c->nl)
2042   {
2043    *(c->nl) = 0xd;
2044    c->nl = NULL;
2045   }
2046  if (!b->buf)
2047   PerlIO_get_base(f);
2048  if (b->buf)
2049   {
2050    if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2051     {
2052      b->end = b->ptr = b->buf + b->bufsiz;
2053      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2054     }
2055    while (count > 0 && b->ptr > b->buf)
2056     {
2057      int ch = *--buf;
2058      if (ch == '\n')
2059       {
2060        if (b->ptr - 2 >= b->buf)
2061         {
2062          *--(b->ptr) = 0xa;
2063          *--(b->ptr) = 0xd;
2064          unread++;
2065          count--;
2066         }
2067        else
2068         {
2069          buf++;
2070          break;
2071         }
2072       }
2073      else
2074       {
2075        *--(b->ptr) = ch;
2076        unread++;
2077        count--;
2078       }
2079     }
2080   }
2081  return unread;
2082 }
2083
2084 SSize_t
2085 PerlIOCrlf_get_cnt(PerlIO *f)
2086 {
2087  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2088  if (!b->buf)
2089   PerlIO_get_base(f);
2090  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2091   {
2092    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2093    if (!c->nl)
2094     {
2095      STDCHAR *nl   = b->ptr;
2096     scan:
2097      while (nl < b->end && *nl != 0xd)
2098       nl++;
2099      if (nl < b->end && *nl == 0xd)
2100       {
2101      test:
2102        if (nl+1 < b->end)
2103         {
2104          if (nl[1] == 0xa)
2105           {
2106            *nl   = '\n';
2107            c->nl = nl;
2108           }
2109          else
2110           {
2111            /* Not CR,LF but just CR */
2112            nl++;
2113            goto scan;
2114           }
2115         }
2116        else
2117         {
2118          /* Blast - found CR as last char in buffer */
2119          if (b->ptr < nl)
2120           {
2121            /* They may not care, defer work as long as possible */
2122            return (nl - b->ptr);
2123           }
2124          else
2125           {
2126            int code;
2127            dTHX;
2128            Perl_warn(aTHX_ __FUNCTION__ " f=%p CR @ end of buffer",f);
2129            b->ptr++;               /* say we have read it as far as flush() is concerned */
2130            b->buf++;               /* Leave space an front of buffer */
2131            b->bufsiz--;            /* Buffer is thus smaller */
2132            code = PerlIO_fill(f);  /* Fetch some more */
2133            b->bufsiz++;            /* Restore size for next time */
2134            b->buf--;               /* Point at space */
2135            b->ptr = nl = b->buf;   /* Which is what we hand off */
2136            b->posn--;              /* Buffer starts here */
2137            *nl = 0xd;              /* Fill in the CR */
2138            if (code == 0)
2139             goto test;             /* fill() call worked */
2140            /* CR at EOF - just fall through */
2141           }
2142         }
2143       }
2144     }
2145    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2146   }
2147  return 0;
2148 }
2149
2150 void
2151 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2152 {
2153  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2154  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2155  if (!b->buf)
2156   PerlIO_get_base(f);
2157  if (!ptr)
2158   {
2159    if (c->nl)
2160     ptr = c->nl+1;
2161    else
2162     {
2163      ptr = b->end;
2164      if (ptr > b->buf && ptr[-1] == 0xd)
2165       ptr--;
2166     }
2167    ptr -= cnt;
2168   }
2169  else
2170   {
2171    /* Test code - delete when it works ... */
2172    STDCHAR *chk;
2173    if (c->nl)
2174     chk = c->nl+1;
2175    else
2176     {
2177      chk = b->end;
2178      if (chk > b->buf && chk[-1] == 0xd)
2179       chk--;
2180     }
2181    chk -= cnt;
2182
2183    if (ptr != chk)
2184     {
2185      dTHX;
2186      Perl_croak(aTHX_ "ptr wrong %p != %p nl=%p e=%p for %d",
2187                 ptr, chk, c->nl, b->end, cnt);
2188     }
2189   }
2190  if (c->nl)
2191   {
2192    if (ptr > c->nl)
2193     {
2194      /* They have taken what we lied about */
2195      *(c->nl) = 0xd;
2196      c->nl = NULL;
2197      ptr++;
2198     }
2199   }
2200  b->ptr = ptr;
2201  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2202 }
2203
2204 SSize_t
2205 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2206 {
2207  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2208  const STDCHAR *buf  = (const STDCHAR *) vbuf;
2209  const STDCHAR *ebuf = buf+count;
2210  if (!b->buf)
2211   PerlIO_get_base(f);
2212  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2213   return 0;
2214  while (buf < ebuf)
2215   {
2216    STDCHAR *eptr = b->buf+b->bufsiz;
2217    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2218    while (buf < ebuf && b->ptr < eptr)
2219     {
2220      if (*buf == '\n')
2221       {
2222        if ((b->ptr + 2) > eptr)
2223         {
2224          /* Not room for both */
2225          PerlIO_flush(f);
2226          break;
2227         }
2228        else
2229         {
2230          *(b->ptr)++ = 0xd; /* CR */
2231          *(b->ptr)++ = 0xa; /* LF */
2232          buf++;
2233          if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2234           {
2235            PerlIO_flush(f);
2236            break;
2237           }
2238         }
2239       }
2240      else
2241       {
2242        int ch = *buf++;
2243        *(b->ptr)++ = ch;
2244       }
2245      if (b->ptr >= eptr)
2246       {
2247        PerlIO_flush(f);
2248        break;
2249       }
2250     }
2251   }
2252  return (buf - (STDCHAR *) vbuf);
2253 }
2254
2255 IV
2256 PerlIOCrlf_flush(PerlIO *f)
2257 {
2258  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2259  if (c->nl)
2260   {
2261    *(c->nl) = 0xd;
2262    c->nl = NULL;
2263   }
2264  return PerlIOBuf_flush(f);
2265 }
2266
2267 PerlIO_funcs PerlIO_crlf = {
2268  "crlf",
2269  sizeof(PerlIOCrlf),
2270  0,
2271  PerlIOBase_fileno,
2272  PerlIOBuf_fdopen,
2273  PerlIOBuf_open,
2274  PerlIOBuf_reopen,
2275  PerlIOBase_pushed,
2276  PerlIOBase_noop_ok,   /* popped */
2277  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2278  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2279  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2280  PerlIOBuf_seek,
2281  PerlIOBuf_tell,
2282  PerlIOBuf_close,
2283  PerlIOCrlf_flush,
2284  PerlIOBuf_fill,
2285  PerlIOBase_eof,
2286  PerlIOBase_error,
2287  PerlIOBase_clearerr,
2288  PerlIOBuf_setlinebuf,
2289  PerlIOBuf_get_base,
2290  PerlIOBuf_bufsiz,
2291  PerlIOBuf_get_ptr,
2292  PerlIOCrlf_get_cnt,
2293  PerlIOCrlf_set_ptrcnt,
2294 };
2295
2296 #ifdef HAS_MMAP
2297 /*--------------------------------------------------------------------------------------*/
2298 /* mmap as "buffer" layer */
2299
2300 typedef struct
2301 {
2302  PerlIOBuf      base;         /* PerlIOBuf stuff */
2303  Mmap_t         mptr;        /* Mapped address */
2304  Size_t         len;          /* mapped length */
2305  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2306 } PerlIOMmap;
2307
2308 static size_t page_size = 0;
2309
2310 IV
2311 PerlIOMmap_map(PerlIO *f)
2312 {
2313  dTHX;
2314  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2315  PerlIOBuf  *b = &m->base;
2316  IV flags = PerlIOBase(f)->flags;
2317  IV code  = 0;
2318  if (m->len)
2319   abort();
2320  if (flags & PERLIO_F_CANREAD)
2321   {
2322    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2323    int fd   = PerlIO_fileno(f);
2324    struct stat st;
2325    code = fstat(fd,&st);
2326    if (code == 0 && S_ISREG(st.st_mode))
2327     {
2328      SSize_t len = st.st_size - b->posn;
2329      if (len > 0)
2330       {
2331        Off_t posn;
2332        if (!page_size) {
2333 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2334            {
2335                SETERRNO(0,SS$_NORMAL);
2336 #   ifdef _SC_PAGESIZE
2337                page_size = sysconf(_SC_PAGESIZE);
2338 #   else
2339                page_size = sysconf(_SC_PAGE_SIZE);
2340 #   endif
2341                if ((long)page_size < 0) {
2342                    if (errno) {
2343                        SV *error = ERRSV;
2344                        char *msg;
2345                        STRLEN n_a;
2346                        (void)SvUPGRADE(error, SVt_PV);
2347                        msg = SvPVx(error, n_a);
2348                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2349                    }
2350                    else
2351                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2352                }
2353            }
2354 #else
2355 #   ifdef HAS_GETPAGESIZE
2356         page_size = getpagesize();
2357 #   else
2358 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2359         page_size = PAGESIZE; /* compiletime, bad */
2360 #       endif
2361 #   endif
2362 #endif
2363         if ((IV)page_size <= 0)
2364             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2365        }
2366        if (b->posn < 0)
2367         {
2368          /* This is a hack - should never happen - open should have set it ! */
2369          b->posn = PerlIO_tell(PerlIONext(f));
2370         }
2371        posn = (b->posn / page_size) * page_size;
2372        len  = st.st_size - posn;
2373        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2374        if (m->mptr && m->mptr != (Mmap_t) -1)
2375         {
2376 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2377          madvise(m->mptr, len, MADV_SEQUENTIAL);
2378 #endif
2379          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2380          b->end  = ((STDCHAR *)m->mptr) + len;
2381          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2382          b->ptr  = b->buf;
2383          m->len  = len;
2384         }
2385        else
2386         {
2387          b->buf = NULL;
2388         }
2389       }
2390      else
2391       {
2392        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2393        b->buf = NULL;
2394        b->ptr = b->end = b->ptr;
2395        code = -1;
2396       }
2397     }
2398   }
2399  return code;
2400 }
2401
2402 IV
2403 PerlIOMmap_unmap(PerlIO *f)
2404 {
2405  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2406  PerlIOBuf  *b = &m->base;
2407  IV code = 0;
2408  if (m->len)
2409   {
2410    if (b->buf)
2411     {
2412      code = munmap(m->mptr, m->len);
2413      b->buf  = NULL;
2414      m->len  = 0;
2415      m->mptr = NULL;
2416      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2417       code = -1;
2418     }
2419    b->ptr = b->end = b->buf;
2420    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2421   }
2422  return code;
2423 }
2424
2425 STDCHAR *
2426 PerlIOMmap_get_base(PerlIO *f)
2427 {
2428  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2429  PerlIOBuf  *b = &m->base;
2430  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2431   {
2432    /* Already have a readbuffer in progress */
2433    return b->buf;
2434   }
2435  if (b->buf)
2436   {
2437    /* We have a write buffer or flushed PerlIOBuf read buffer */
2438    m->bbuf = b->buf;  /* save it in case we need it again */
2439    b->buf  = NULL;    /* Clear to trigger below */
2440   }
2441  if (!b->buf)
2442   {
2443    PerlIOMmap_map(f);     /* Try and map it */
2444    if (!b->buf)
2445     {
2446      /* Map did not work - recover PerlIOBuf buffer if we have one */
2447      b->buf = m->bbuf;
2448     }
2449   }
2450  b->ptr  = b->end = b->buf;
2451  if (b->buf)
2452   return b->buf;
2453  return PerlIOBuf_get_base(f);
2454 }
2455
2456 SSize_t
2457 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2458 {
2459  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2460  PerlIOBuf  *b = &m->base;
2461  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2462   PerlIO_flush(f);
2463  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2464   {
2465    b->ptr -= count;
2466    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2467    return count;
2468   }
2469  if (m->len)
2470   {
2471    /* Loose the unwritable mapped buffer */
2472    PerlIO_flush(f);
2473    /* If flush took the "buffer" see if we have one from before */
2474    if (!b->buf && m->bbuf)
2475     b->buf = m->bbuf;
2476    if (!b->buf)
2477     {
2478      PerlIOBuf_get_base(f);
2479      m->bbuf = b->buf;
2480     }
2481   }
2482  return PerlIOBuf_unread(f,vbuf,count);
2483 }
2484
2485 SSize_t
2486 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2487 {
2488  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2489  PerlIOBuf  *b = &m->base;
2490  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2491   {
2492    /* No, or wrong sort of, buffer */
2493    if (m->len)
2494     {
2495      if (PerlIOMmap_unmap(f) != 0)
2496       return 0;
2497     }
2498    /* If unmap took the "buffer" see if we have one from before */
2499    if (!b->buf && m->bbuf)
2500     b->buf = m->bbuf;
2501    if (!b->buf)
2502     {
2503      PerlIOBuf_get_base(f);
2504      m->bbuf = b->buf;
2505     }
2506   }
2507  return PerlIOBuf_write(f,vbuf,count);
2508 }
2509
2510 IV
2511 PerlIOMmap_flush(PerlIO *f)
2512 {
2513  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2514  PerlIOBuf  *b = &m->base;
2515  IV code = PerlIOBuf_flush(f);
2516  /* Now we are "synced" at PerlIOBuf level */
2517  if (b->buf)
2518   {
2519    if (m->len)
2520     {
2521      /* Unmap the buffer */
2522      if (PerlIOMmap_unmap(f) != 0)
2523       code = -1;
2524     }
2525    else
2526     {
2527      /* We seem to have a PerlIOBuf buffer which was not mapped
2528       * remember it in case we need one later
2529       */
2530      m->bbuf = b->buf;
2531     }
2532   }
2533  return code;
2534 }
2535
2536 IV
2537 PerlIOMmap_fill(PerlIO *f)
2538 {
2539  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2540  IV code = PerlIO_flush(f);
2541  if (code == 0 && !b->buf)
2542   {
2543    code = PerlIOMmap_map(f);
2544   }
2545  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2546   {
2547    code = PerlIOBuf_fill(f);
2548   }
2549  return code;
2550 }
2551
2552 IV
2553 PerlIOMmap_close(PerlIO *f)
2554 {
2555  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2556  PerlIOBuf  *b = &m->base;
2557  IV code = PerlIO_flush(f);
2558  if (m->bbuf)
2559   {
2560    b->buf  = m->bbuf;
2561    m->bbuf = NULL;
2562    b->ptr  = b->end = b->buf;
2563   }
2564  if (PerlIOBuf_close(f) != 0)
2565   code = -1;
2566  return code;
2567 }
2568
2569
2570 PerlIO_funcs PerlIO_mmap = {
2571  "mmap",
2572  sizeof(PerlIOMmap),
2573  0,
2574  PerlIOBase_fileno,
2575  PerlIOBuf_fdopen,
2576  PerlIOBuf_open,
2577  PerlIOBuf_reopen,
2578  PerlIOBase_pushed,
2579  PerlIOBase_noop_ok,
2580  PerlIOBuf_read,
2581  PerlIOMmap_unread,
2582  PerlIOMmap_write,
2583  PerlIOBuf_seek,
2584  PerlIOBuf_tell,
2585  PerlIOBuf_close,
2586  PerlIOMmap_flush,
2587  PerlIOMmap_fill,
2588  PerlIOBase_eof,
2589  PerlIOBase_error,
2590  PerlIOBase_clearerr,
2591  PerlIOBuf_setlinebuf,
2592  PerlIOMmap_get_base,
2593  PerlIOBuf_bufsiz,
2594  PerlIOBuf_get_ptr,
2595  PerlIOBuf_get_cnt,
2596  PerlIOBuf_set_ptrcnt,
2597 };
2598
2599 #endif /* HAS_MMAP */
2600
2601 void
2602 PerlIO_init(void)
2603 {
2604  if (!_perlio)
2605   {
2606    atexit(&PerlIO_cleanup);
2607   }
2608 }
2609
2610 #undef PerlIO_stdin
2611 PerlIO *
2612 PerlIO_stdin(void)
2613 {
2614  if (!_perlio)
2615   PerlIO_stdstreams();
2616  return &_perlio[1];
2617 }
2618
2619 #undef PerlIO_stdout
2620 PerlIO *
2621 PerlIO_stdout(void)
2622 {
2623  if (!_perlio)
2624   PerlIO_stdstreams();
2625  return &_perlio[2];
2626 }
2627
2628 #undef PerlIO_stderr
2629 PerlIO *
2630 PerlIO_stderr(void)
2631 {
2632  if (!_perlio)
2633   PerlIO_stdstreams();
2634  return &_perlio[3];
2635 }
2636
2637 /*--------------------------------------------------------------------------------------*/
2638
2639 #undef PerlIO_getname
2640 char *
2641 PerlIO_getname(PerlIO *f, char *buf)
2642 {
2643  dTHX;
2644  Perl_croak(aTHX_ "Don't know how to get file name");
2645  return NULL;
2646 }
2647
2648
2649 /*--------------------------------------------------------------------------------------*/
2650 /* Functions which can be called on any kind of PerlIO implemented
2651    in terms of above
2652 */
2653
2654 #undef PerlIO_getc
2655 int
2656 PerlIO_getc(PerlIO *f)
2657 {
2658  STDCHAR buf[1];
2659  SSize_t count = PerlIO_read(f,buf,1);
2660  if (count == 1)
2661   {
2662    return (unsigned char) buf[0];
2663   }
2664  return EOF;
2665 }
2666
2667 #undef PerlIO_ungetc
2668 int
2669 PerlIO_ungetc(PerlIO *f, int ch)
2670 {
2671  if (ch != EOF)
2672   {
2673    STDCHAR buf = ch;
2674    if (PerlIO_unread(f,&buf,1) == 1)
2675     return ch;
2676   }
2677  return EOF;
2678 }
2679
2680 #undef PerlIO_putc
2681 int
2682 PerlIO_putc(PerlIO *f, int ch)
2683 {
2684  STDCHAR buf = ch;
2685  return PerlIO_write(f,&buf,1);
2686 }
2687
2688 #undef PerlIO_puts
2689 int
2690 PerlIO_puts(PerlIO *f, const char *s)
2691 {
2692  STRLEN len = strlen(s);
2693  return PerlIO_write(f,s,len);
2694 }
2695
2696 #undef PerlIO_rewind
2697 void
2698 PerlIO_rewind(PerlIO *f)
2699 {
2700  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2701  PerlIO_clearerr(f);
2702 }
2703
2704 #undef PerlIO_vprintf
2705 int
2706 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2707 {
2708  dTHX;
2709  SV *sv = newSVpvn("",0);
2710  char *s;
2711  STRLEN len;
2712 #ifdef NEED_VA_COPY
2713  va_list apc;
2714  Perl_va_copy(ap, apc);
2715  sv_vcatpvf(sv, fmt, &apc);
2716 #else
2717  sv_vcatpvf(sv, fmt, &ap);
2718 #endif
2719  s = SvPV(sv,len);
2720  return PerlIO_write(f,s,len);
2721 }
2722
2723 #undef PerlIO_printf
2724 int
2725 PerlIO_printf(PerlIO *f,const char *fmt,...)
2726 {
2727  va_list ap;
2728  int result;
2729  va_start(ap,fmt);
2730  result = PerlIO_vprintf(f,fmt,ap);
2731  va_end(ap);
2732  return result;
2733 }
2734
2735 #undef PerlIO_stdoutf
2736 int
2737 PerlIO_stdoutf(const char *fmt,...)
2738 {
2739  va_list ap;
2740  int result;
2741  va_start(ap,fmt);
2742  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2743  va_end(ap);
2744  return result;
2745 }
2746
2747 #undef PerlIO_tmpfile
2748 PerlIO *
2749 PerlIO_tmpfile(void)
2750 {
2751  /* I have no idea how portable mkstemp() is ... */
2752 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2753  PerlIO *f = NULL;
2754  FILE *stdio = tmpfile();
2755  if (stdio)
2756   {
2757    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2758    s->stdio  = stdio;
2759   }
2760  return f;
2761 #else
2762  dTHX;
2763  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2764  int fd = mkstemp(SvPVX(sv));
2765  PerlIO *f = NULL;
2766  if (fd >= 0)
2767   {
2768    f = PerlIO_fdopen(fd,"w+");
2769    if (f)
2770     {
2771      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2772     }
2773    PerlLIO_unlink(SvPVX(sv));
2774    SvREFCNT_dec(sv);
2775   }
2776  return f;
2777 #endif
2778 }
2779
2780 #undef HAS_FSETPOS
2781 #undef HAS_FGETPOS
2782
2783 #endif /* USE_SFIO */
2784 #endif /* PERLIO_IS_STDIO */
2785
2786 /*======================================================================================*/
2787 /* Now some functions in terms of above which may be needed even if
2788    we are not in true PerlIO mode
2789  */
2790
2791 #ifndef HAS_FSETPOS
2792 #undef PerlIO_setpos
2793 int
2794 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2795 {
2796  return PerlIO_seek(f,*pos,0);
2797 }
2798 #else
2799 #ifndef PERLIO_IS_STDIO
2800 #undef PerlIO_setpos
2801 int
2802 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2803 {
2804 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2805  return fsetpos64(f, pos);
2806 #else
2807  return fsetpos(f, pos);
2808 #endif
2809 }
2810 #endif
2811 #endif
2812
2813 #ifndef HAS_FGETPOS
2814 #undef PerlIO_getpos
2815 int
2816 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2817 {
2818  *pos = PerlIO_tell(f);
2819  return *pos == -1 ? -1 : 0;
2820 }
2821 #else
2822 #ifndef PERLIO_IS_STDIO
2823 #undef PerlIO_getpos
2824 int
2825 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2826 {
2827 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2828  return fgetpos64(f, pos);
2829 #else
2830  return fgetpos(f, pos);
2831 #endif
2832 }
2833 #endif
2834 #endif
2835
2836 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2837
2838 int
2839 vprintf(char *pat, char *args)
2840 {
2841     _doprnt(pat, args, stdout);
2842     return 0;           /* wrong, but perl doesn't use the return value */
2843 }
2844
2845 int
2846 vfprintf(FILE *fd, char *pat, char *args)
2847 {
2848     _doprnt(pat, args, fd);
2849     return 0;           /* wrong, but perl doesn't use the return value */
2850 }
2851
2852 #endif
2853
2854 #ifndef PerlIO_vsprintf
2855 int
2856 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2857 {
2858  int val = vsprintf(s, fmt, ap);
2859  if (n >= 0)
2860   {
2861    if (strlen(s) >= (STRLEN)n)
2862     {
2863      dTHX;
2864      (void)PerlIO_puts(Perl_error_log,
2865                        "panic: sprintf overflow - memory corrupted!\n");
2866      my_exit(1);
2867     }
2868   }
2869  return val;
2870 }
2871 #endif
2872
2873 #ifndef PerlIO_sprintf
2874 int
2875 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2876 {
2877  va_list ap;
2878  int result;
2879  va_start(ap,fmt);
2880  result = PerlIO_vsprintf(s, n, fmt, ap);
2881  va_end(ap);
2882  return result;
2883 }
2884 #endif
2885
2886 #endif /* !PERL_IMPLICIT_SYS */
2887