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