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