perlio.c

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