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