perlio.c

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