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