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