perlio.c

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