perlio.c

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