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