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