perlio.c

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