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(pTHX_ 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 (memEQ(f->name,name,len))
 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 #if defined(WIN32) && !defined(UNDER_CE)
 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    while (*top)
 958     {
 959      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 960       {
 961        PerlIO_flush(top);
 962        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 963        break;
 964       }
 965      top = PerlIONext(top);
 966     }
 967   }
 968  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 969 }
 970
 971 #undef PerlIO__close
 972 int
 973 PerlIO__close(PerlIO *f)
 974 {
 975  if (f && *f)
 976    return (*PerlIOBase(f)->tab->Close)(f);
 977  else
 978   {
 979    SETERRNO(EBADF,SS$_IVCHAN);
 980    return -1;
 981   }
 982 }
 983
 984 #undef PerlIO_fdupopen
 985 PerlIO *
 986 PerlIO_fdupopen(pTHX_ PerlIO *f)
 987 {
 988  if (f && *f)
 989   {
 990    char buf[8];
 991    int fd = PerlLIO_dup(PerlIO_fileno(f));
 992    PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
 993    if (new)
 994     {
 995      Off_t posn = PerlIO_tell(f);
 996      PerlIO_seek(new,posn,SEEK_SET);
 997     }
 998    return new;
 999   }
1000  else
1001   {
1002    SETERRNO(EBADF,SS$_IVCHAN);
1003    return NULL;
1004   }
1005 }
1006
1007 #undef PerlIO_close
1008 int
1009 PerlIO_close(PerlIO *f)
1010 {
1011  dTHX;
1012  int code = -1;
1013  if (f && *f)
1014   {
1015    code = (*PerlIOBase(f)->tab->Close)(f);
1016    while (*f)
1017     {
1018      PerlIO_pop(aTHX_ f);
1019     }
1020   }
1021  return code;
1022 }
1023
1024 #undef PerlIO_fileno
1025 int
1026 PerlIO_fileno(PerlIO *f)
1027 {
1028  if (f && *f)
1029   return (*PerlIOBase(f)->tab->Fileno)(f);
1030  else
1031   {
1032    SETERRNO(EBADF,SS$_IVCHAN);
1033    return -1;
1034   }
1035 }
1036
1037 static const char *
1038 PerlIO_context_layers(pTHX_ const char *mode)
1039 {
1040  const char *type = NULL;
1041  /* Need to supply default layer info from open.pm */
1042  if (PL_curcop)
1043   {
1044    SV *layers = PL_curcop->cop_io;
1045    if (layers)
1046     {
1047      STRLEN len;
1048      type = SvPV(layers,len);
1049      if (type && mode[0] != 'r')
1050       {
1051        /* Skip to write part */
1052        const char *s = strchr(type,0);
1053        if (s && (s-type) < len)
1054         {
1055          type = s+1;
1056         }
1057       }
1058     }
1059   }
1060  return type;
1061 }
1062
1063 static PerlIO_funcs *
1064 PerlIO_layer_from_ref(pTHX_ SV *sv)
1065 {
1066  /* For any scalar type load the handler which is bundled with perl */
1067  if (SvTYPE(sv) < SVt_PVAV)
1068   return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1069
1070  /* For other types allow if layer is known but don't try and load it */
1071  switch (SvTYPE(sv))
1072   {
1073    case SVt_PVAV:
1074     return PerlIO_find_layer(aTHX_ "Array",5, 0);
1075    case SVt_PVHV:
1076     return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1077    case SVt_PVCV:
1078     return PerlIO_find_layer(aTHX_ "Code",4, 0);
1079    case SVt_PVGV:
1080     return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1081   }
1082  return NULL;
1083 }
1084
1085 PerlIO_list_t *
1086 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1087 {
1088  PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1089  int incdef = 1;
1090  if (!_perlio)
1091   PerlIO_stdstreams(aTHX);
1092  if (narg)
1093   {
1094    SV *arg = *args;
1095    /* If it is a reference but not an object see if we have a handler for it */
1096    if (SvROK(arg) && !sv_isobject(arg))
1097     {
1098      PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1099      if (handler)
1100       {
1101        def = PerlIO_list_alloc();
1102        PerlIO_list_push(def,handler,&PL_sv_undef);
1103        incdef = 0;
1104       }
1105      /* Don't fail if handler cannot be found
1106       * :Via(...) etc. may do something sensible
1107       * else we will just stringfy and open resulting string.
1108       */
1109     }
1110   }
1111  if (!layers)
1112   layers = PerlIO_context_layers(aTHX_ mode);
1113  if (layers && *layers)
1114   {
1115    PerlIO_list_t *av;
1116    if (incdef)
1117     {
1118      IV i = def->cur;
1119      av = PerlIO_list_alloc();
1120      for (i=0; i < def->cur; i++)
1121       {
1122        PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1123       }
1124     }
1125    else
1126     {
1127      av = def;
1128     }
1129    PerlIO_parse_layers(aTHX_ av,layers);
1130    return av;
1131   }
1132  else
1133   {
1134    if (incdef)
1135     def->refcnt++;
1136    return def;
1137   }
1138 }
1139
1140 PerlIO *
1141 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1142 {
1143  if (!f && narg == 1 && *args == &PL_sv_undef)
1144   {
1145    if ((f = PerlIO_tmpfile()))
1146     {
1147      if (!layers)
1148       layers = PerlIO_context_layers(aTHX_ mode);
1149      if (layers && *layers)
1150       PerlIO_apply_layers(aTHX_ f,mode,layers);
1151     }
1152   }
1153  else
1154   {
1155    PerlIO_list_t *layera = NULL;
1156    IV n;
1157    PerlIO_funcs *tab = NULL;
1158    if (f && *f)
1159     {
1160      /* This is "reopen" - it is not tested as perl does not use it yet */
1161      PerlIOl *l = *f;
1162      layera = PerlIO_list_alloc();
1163      while (l)
1164       {
1165        SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1166        PerlIO_list_push(layera,l->tab,arg);
1167        l = *PerlIONext(&l);
1168       }
1169     }
1170    else
1171     {
1172      layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1173     }
1174    /* Start at "top" of layer stack */
1175    n = layera->cur-1;
1176    while (n >= 0)
1177     {
1178      PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1179      if (t && t->Open)
1180       {
1181        tab = t;
1182        break;
1183       }
1184      n--;
1185     }
1186    if (tab)
1187     {
1188      /* Found that layer 'n' can do opens - call it */
1189      PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1190                   tab->name,layers,mode,fd,imode,perm,f,narg,args);
1191      f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1192      if (f)
1193       {
1194        if (n+1 < layera->cur)
1195         {
1196          /* More layers above the one that we used to open - apply them now */
1197          if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1198           {
1199            f = NULL;
1200           }
1201         }
1202       }
1203     }
1204    PerlIO_list_free(layera);
1205   }
1206  return f;
1207 }
1208
1209
1210 #undef PerlIO_fdopen
1211 PerlIO *
1212 PerlIO_fdopen(int fd, const char *mode)
1213 {
1214  dTHX;
1215  return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1216 }
1217
1218 #undef PerlIO_open
1219 PerlIO *
1220 PerlIO_open(const char *path, const char *mode)
1221 {
1222  dTHX;
1223  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1224  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1225 }
1226
1227 #undef PerlIO_reopen
1228 PerlIO *
1229 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1230 {
1231  dTHX;
1232  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1233  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1234 }
1235
1236 #undef PerlIO_read
1237 SSize_t
1238 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1239 {
1240  if (f && *f)
1241   return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1242  else
1243   {
1244    SETERRNO(EBADF,SS$_IVCHAN);
1245    return -1;
1246   }
1247 }
1248
1249 #undef PerlIO_unread
1250 SSize_t
1251 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1252 {
1253  if (f && *f)
1254   return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1255  else
1256   {
1257    SETERRNO(EBADF,SS$_IVCHAN);
1258    return -1;
1259   }
1260 }
1261
1262 #undef PerlIO_write
1263 SSize_t
1264 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1265 {
1266  if (f && *f)
1267   return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1268  else
1269   {
1270    SETERRNO(EBADF,SS$_IVCHAN);
1271    return -1;
1272   }
1273 }
1274
1275 #undef PerlIO_seek
1276 int
1277 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1278 {
1279  if (f && *f)
1280   return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1281  else
1282   {
1283    SETERRNO(EBADF,SS$_IVCHAN);
1284    return -1;
1285   }
1286 }
1287
1288 #undef PerlIO_tell
1289 Off_t
1290 PerlIO_tell(PerlIO *f)
1291 {
1292   if (f && *f)
1293    return (*PerlIOBase(f)->tab->Tell)(f);
1294   else
1295    {
1296     SETERRNO(EBADF,SS$_IVCHAN);
1297     return -1;
1298    }
1299 }
1300
1301 #undef PerlIO_flush
1302 int
1303 PerlIO_flush(PerlIO *f)
1304 {
1305  if (f)
1306   {
1307    if (*f)
1308     {
1309      PerlIO_funcs *tab = PerlIOBase(f)->tab;
1310      if (tab && tab->Flush)
1311       {
1312        return (*tab->Flush)(f);
1313       }
1314      else
1315       {
1316        PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1317        SETERRNO(EBADF,SS$_IVCHAN);
1318        return -1;
1319       }
1320     }
1321    else
1322     {
1323      PerlIO_debug("Cannot flush f=%p\n",f);
1324      SETERRNO(EBADF,SS$_IVCHAN);
1325      return -1;
1326     }
1327   }
1328  else
1329   {
1330    /* Is it good API design to do flush-all on NULL,
1331     * a potentially errorneous input?  Maybe some magical
1332     * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1333     * Yes, stdio does similar things on fflush(NULL),
1334     * but should we be bound by their design decisions?
1335     * --jhi */
1336    PerlIO **table = &_perlio;
1337    int code = 0;
1338    while ((f = *table))
1339     {
1340      int i;
1341      table = (PerlIO **)(f++);
1342      for (i=1; i < PERLIO_TABLE_SIZE; i++)
1343       {
1344        if (*f && PerlIO_flush(f) != 0)
1345         code = -1;
1346        f++;
1347       }
1348     }
1349    return code;
1350   }
1351 }
1352
1353 void
1354 PerlIOBase_flush_linebuf()
1355 {
1356  PerlIO **table = &_perlio;
1357  PerlIO *f;
1358  while ((f = *table))
1359   {
1360    int i;
1361    table = (PerlIO **)(f++);
1362    for (i=1; i < PERLIO_TABLE_SIZE; i++)
1363     {
1364      if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1365                 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1366       PerlIO_flush(f);
1367      f++;
1368     }
1369   }
1370 }
1371
1372 #undef PerlIO_fill
1373 int
1374 PerlIO_fill(PerlIO *f)
1375 {
1376  if (f && *f)
1377   return (*PerlIOBase(f)->tab->Fill)(f);
1378  else
1379   {
1380    SETERRNO(EBADF,SS$_IVCHAN);
1381    return -1;
1382   }
1383 }
1384
1385 #undef PerlIO_isutf8
1386 int
1387 PerlIO_isutf8(PerlIO *f)
1388 {
1389  if (f && *f)
1390   return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1391  else
1392   {
1393    SETERRNO(EBADF,SS$_IVCHAN);
1394    return -1;
1395   }
1396 }
1397
1398 #undef PerlIO_eof
1399 int
1400 PerlIO_eof(PerlIO *f)
1401 {
1402  if (f && *f)
1403   return (*PerlIOBase(f)->tab->Eof)(f);
1404  else
1405   {
1406    SETERRNO(EBADF,SS$_IVCHAN);
1407    return -1;
1408   }
1409 }
1410
1411 #undef PerlIO_error
1412 int
1413 PerlIO_error(PerlIO *f)
1414 {
1415  if (f && *f)
1416   return (*PerlIOBase(f)->tab->Error)(f);
1417  else
1418   {
1419    SETERRNO(EBADF,SS$_IVCHAN);
1420    return -1;
1421   }
1422 }
1423
1424 #undef PerlIO_clearerr
1425 void
1426 PerlIO_clearerr(PerlIO *f)
1427 {
1428  if (f && *f)
1429   (*PerlIOBase(f)->tab->Clearerr)(f);
1430  else
1431   SETERRNO(EBADF,SS$_IVCHAN);
1432 }
1433
1434 #undef PerlIO_setlinebuf
1435 void
1436 PerlIO_setlinebuf(PerlIO *f)
1437 {
1438  if (f && *f)
1439   (*PerlIOBase(f)->tab->Setlinebuf)(f);
1440  else
1441   SETERRNO(EBADF,SS$_IVCHAN);
1442 }
1443
1444 #undef PerlIO_has_base
1445 int
1446 PerlIO_has_base(PerlIO *f)
1447 {
1448  if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1449  return 0;
1450 }
1451
1452 #undef PerlIO_fast_gets
1453 int
1454 PerlIO_fast_gets(PerlIO *f)
1455 {
1456  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1457   {
1458    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1459    return (tab->Set_ptrcnt != NULL);
1460   }
1461  return 0;
1462 }
1463
1464 #undef PerlIO_has_cntptr
1465 int
1466 PerlIO_has_cntptr(PerlIO *f)
1467 {
1468  if (f && *f)
1469   {
1470    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1471    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1472   }
1473  return 0;
1474 }
1475
1476 #undef PerlIO_canset_cnt
1477 int
1478 PerlIO_canset_cnt(PerlIO *f)
1479 {
1480  if (f && *f)
1481   {
1482    PerlIOl *l = PerlIOBase(f);
1483    return (l->tab->Set_ptrcnt != NULL);
1484   }
1485  return 0;
1486 }
1487
1488 #undef PerlIO_get_base
1489 STDCHAR *
1490 PerlIO_get_base(PerlIO *f)
1491 {
1492  if (f && *f)
1493   return (*PerlIOBase(f)->tab->Get_base)(f);
1494  return NULL;
1495 }
1496
1497 #undef PerlIO_get_bufsiz
1498 int
1499 PerlIO_get_bufsiz(PerlIO *f)
1500 {
1501  if (f && *f)
1502   return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1503  return 0;
1504 }
1505
1506 #undef PerlIO_get_ptr
1507 STDCHAR *
1508 PerlIO_get_ptr(PerlIO *f)
1509 {
1510  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1511  if (tab->Get_ptr == NULL)
1512   return NULL;
1513  return (*tab->Get_ptr)(f);
1514 }
1515
1516 #undef PerlIO_get_cnt
1517 int
1518 PerlIO_get_cnt(PerlIO *f)
1519 {
1520  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1521  if (tab->Get_cnt == NULL)
1522   return 0;
1523  return (*tab->Get_cnt)(f);
1524 }
1525
1526 #undef PerlIO_set_cnt
1527 void
1528 PerlIO_set_cnt(PerlIO *f,int cnt)
1529 {
1530  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1531 }
1532
1533 #undef PerlIO_set_ptrcnt
1534 void
1535 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1536 {
1537  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1538  if (tab->Set_ptrcnt == NULL)
1539   {
1540    dTHX;
1541    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1542   }
1543  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1544 }
1545
1546 /*--------------------------------------------------------------------------------------*/
1547 /* utf8 and raw dummy layers */
1548
1549 IV
1550 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1551 {
1552  if (PerlIONext(f))
1553   {
1554    dTHX;
1555    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1556    PerlIO_pop(aTHX_ f);
1557    if (tab->kind & PERLIO_K_UTF8)
1558     PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1559    else
1560     PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1561    return 0;
1562   }
1563  return -1;
1564 }
1565
1566 PerlIO_funcs PerlIO_utf8 = {
1567  "utf8",
1568  sizeof(PerlIOl),
1569  PERLIO_K_DUMMY|PERLIO_F_UTF8,
1570  PerlIOUtf8_pushed,
1571  NULL,
1572  NULL,
1573  NULL,
1574  NULL,
1575  NULL,
1576  NULL,
1577  NULL,
1578  NULL,
1579  NULL,
1580  NULL,
1581  NULL, /* flush */
1582  NULL, /* fill */
1583  NULL,
1584  NULL,
1585  NULL,
1586  NULL,
1587  NULL, /* get_base */
1588  NULL, /* get_bufsiz */
1589  NULL, /* get_ptr */
1590  NULL, /* get_cnt */
1591  NULL, /* set_ptrcnt */
1592 };
1593
1594 PerlIO_funcs PerlIO_byte = {
1595  "bytes",
1596  sizeof(PerlIOl),
1597  PERLIO_K_DUMMY,
1598  PerlIOUtf8_pushed,
1599  NULL,
1600  NULL,
1601  NULL,
1602  NULL,
1603  NULL,
1604  NULL,
1605  NULL,
1606  NULL,
1607  NULL,
1608  NULL,
1609  NULL, /* flush */
1610  NULL, /* fill */
1611  NULL,
1612  NULL,
1613  NULL,
1614  NULL,
1615  NULL, /* get_base */
1616  NULL, /* get_bufsiz */
1617  NULL, /* get_ptr */
1618  NULL, /* get_cnt */
1619  NULL, /* set_ptrcnt */
1620 };
1621
1622 PerlIO *
1623 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)
1624 {
1625  PerlIO_funcs *tab = PerlIO_default_btm();
1626  return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1627 }
1628
1629 PerlIO_funcs PerlIO_raw = {
1630  "raw",
1631  sizeof(PerlIOl),
1632  PERLIO_K_DUMMY,
1633  PerlIORaw_pushed,
1634  PerlIOBase_popped,
1635  PerlIORaw_open,
1636  NULL,
1637  NULL,
1638  NULL,
1639  NULL,
1640  NULL,
1641  NULL,
1642  NULL,
1643  NULL,
1644  NULL, /* flush */
1645  NULL, /* fill */
1646  NULL,
1647  NULL,
1648  NULL,
1649  NULL,
1650  NULL, /* get_base */
1651  NULL, /* get_bufsiz */
1652  NULL, /* get_ptr */
1653  NULL, /* get_cnt */
1654  NULL, /* set_ptrcnt */
1655 };
1656 /*--------------------------------------------------------------------------------------*/
1657 /*--------------------------------------------------------------------------------------*/
1658 /* "Methods" of the "base class" */
1659
1660 IV
1661 PerlIOBase_fileno(PerlIO *f)
1662 {
1663  return PerlIO_fileno(PerlIONext(f));
1664 }
1665
1666 char *
1667 PerlIO_modestr(PerlIO *f,char *buf)
1668 {
1669  char *s = buf;
1670  IV flags = PerlIOBase(f)->flags;
1671  if (flags & PERLIO_F_APPEND)
1672   {
1673    *s++ = 'a';
1674    if (flags & PERLIO_F_CANREAD)
1675     {
1676      *s++ = '+';
1677     }
1678   }
1679  else if (flags & PERLIO_F_CANREAD)
1680   {
1681    *s++ = 'r';
1682    if (flags & PERLIO_F_CANWRITE)
1683     *s++ = '+';
1684   }
1685  else if (flags & PERLIO_F_CANWRITE)
1686   {
1687    *s++ = 'w';
1688    if (flags & PERLIO_F_CANREAD)
1689     {
1690      *s++ = '+';
1691     }
1692   }
1693 #if O_TEXT != O_BINARY
1694  if (!(flags & PERLIO_F_CRLF))
1695   *s++ = 'b';
1696 #endif
1697  *s = '\0';
1698  return buf;
1699 }
1700
1701 IV
1702 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1703 {
1704  PerlIOl *l = PerlIOBase(f);
1705 #if 0
1706  const char *omode = mode;
1707  char temp[8];
1708 #endif
1709  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1710  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1711                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1712  if (tab->Set_ptrcnt != NULL)
1713   l->flags |= PERLIO_F_FASTGETS;
1714  if (mode)
1715   {
1716    if (*mode == '#' || *mode == 'I')
1717     mode++;
1718    switch (*mode++)
1719     {
1720      case 'r':
1721       l->flags |= PERLIO_F_CANREAD;
1722       break;
1723      case 'a':
1724       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1725       break;
1726      case 'w':
1727       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1728       break;
1729      default:
1730       SETERRNO(EINVAL,LIB$_INVARG);
1731       return -1;
1732     }
1733    while (*mode)
1734     {
1735      switch (*mode++)
1736       {
1737        case '+':
1738         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1739         break;
1740        case 'b':
1741         l->flags &= ~PERLIO_F_CRLF;
1742         break;
1743        case 't':
1744         l->flags |= PERLIO_F_CRLF;
1745         break;
1746       default:
1747         SETERRNO(EINVAL,LIB$_INVARG);
1748         return -1;
1749       }
1750     }
1751   }
1752  else
1753   {
1754    if (l->next)
1755     {
1756      l->flags |= l->next->flags &
1757                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1758     }
1759   }
1760 #if 0
1761  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1762               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1763               l->flags,PerlIO_modestr(f,temp));
1764 #endif
1765  return 0;
1766 }
1767
1768 IV
1769 PerlIOBase_popped(PerlIO *f)
1770 {
1771  return 0;
1772 }
1773
1774 SSize_t
1775 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1776 {
1777  dTHX;
1778  /* Save the position as current head considers it */
1779  Off_t old = PerlIO_tell(f);
1780  SSize_t done;
1781  PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1782  PerlIOSelf(f,PerlIOBuf)->posn = old;
1783  done = PerlIOBuf_unread(f,vbuf,count);
1784  return done;
1785 }
1786
1787 SSize_t
1788 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1789 {
1790  STDCHAR *buf  = (STDCHAR *) vbuf;
1791  if (f)
1792   {
1793    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1794     return 0;
1795    while (count > 0)
1796     {
1797      SSize_t avail = PerlIO_get_cnt(f);
1798      SSize_t take = 0;
1799      if (avail > 0)
1800        take = (count < avail) ? count : avail;
1801      if (take > 0)
1802       {
1803        STDCHAR *ptr = PerlIO_get_ptr(f);
1804        Copy(ptr,buf,take,STDCHAR);
1805        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1806        count   -= take;
1807        buf     += take;
1808       }
1809      if (count > 0  && avail <= 0)
1810       {
1811        if (PerlIO_fill(f) != 0)
1812         break;
1813       }
1814     }
1815    return (buf - (STDCHAR *) vbuf);
1816   }
1817  return 0;
1818 }
1819
1820 IV
1821 PerlIOBase_noop_ok(PerlIO *f)
1822 {
1823  return 0;
1824 }
1825
1826 IV
1827 PerlIOBase_noop_fail(PerlIO *f)
1828 {
1829  return -1;
1830 }
1831
1832 IV
1833 PerlIOBase_close(PerlIO *f)
1834 {
1835  IV code = 0;
1836  PerlIO *n = PerlIONext(f);
1837  if (PerlIO_flush(f) != 0)
1838   code = -1;
1839  if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1840   code = -1;
1841  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1842  return code;
1843 }
1844
1845 IV
1846 PerlIOBase_eof(PerlIO *f)
1847 {
1848  if (f && *f)
1849   {
1850    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1851   }
1852  return 1;
1853 }
1854
1855 IV
1856 PerlIOBase_error(PerlIO *f)
1857 {
1858  if (f && *f)
1859   {
1860    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1861   }
1862  return 1;
1863 }
1864
1865 void
1866 PerlIOBase_clearerr(PerlIO *f)
1867 {
1868  if (f && *f)
1869   {
1870    PerlIO *n = PerlIONext(f);
1871    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1872    if (n)
1873     PerlIO_clearerr(n);
1874   }
1875 }
1876
1877 void
1878 PerlIOBase_setlinebuf(PerlIO *f)
1879 {
1880  if (f)
1881   {
1882    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1883   }
1884 }
1885
1886 /*--------------------------------------------------------------------------------------*/
1887 /* Bottom-most level for UNIX-like case */
1888
1889 typedef struct
1890 {
1891  struct _PerlIO base;       /* The generic part */
1892  int            fd;         /* UNIX like file descriptor */
1893  int            oflags;     /* open/fcntl flags */
1894 } PerlIOUnix;
1895
1896 int
1897 PerlIOUnix_oflags(const char *mode)
1898 {
1899  int oflags = -1;
1900  if (*mode == 'I' || *mode == '#')
1901   mode++;
1902  switch(*mode)
1903   {
1904    case 'r':
1905     oflags = O_RDONLY;
1906     if (*++mode == '+')
1907      {
1908       oflags = O_RDWR;
1909       mode++;
1910      }
1911     break;
1912
1913    case 'w':
1914     oflags = O_CREAT|O_TRUNC;
1915     if (*++mode == '+')
1916      {
1917       oflags |= O_RDWR;
1918       mode++;
1919      }
1920     else
1921      oflags |= O_WRONLY;
1922     break;
1923
1924    case 'a':
1925     oflags = O_CREAT|O_APPEND;
1926     if (*++mode == '+')
1927      {
1928       oflags |= O_RDWR;
1929       mode++;
1930      }
1931     else
1932      oflags |= O_WRONLY;
1933     break;
1934   }
1935  if (*mode == 'b')
1936   {
1937    oflags |=  O_BINARY;
1938    oflags &= ~O_TEXT;
1939    mode++;
1940   }
1941  else if (*mode == 't')
1942   {
1943    oflags |=  O_TEXT;
1944    oflags &= ~O_BINARY;
1945    mode++;
1946   }
1947  /* Always open in binary mode */
1948  oflags |= O_BINARY;
1949  if (*mode || oflags == -1)
1950   {
1951    SETERRNO(EINVAL,LIB$_INVARG);
1952    oflags = -1;
1953   }
1954  return oflags;
1955 }
1956
1957 IV
1958 PerlIOUnix_fileno(PerlIO *f)
1959 {
1960  return PerlIOSelf(f,PerlIOUnix)->fd;
1961 }
1962
1963 IV
1964 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1965 {
1966  IV code = PerlIOBase_pushed(f,mode,arg);
1967  if (*PerlIONext(f))
1968   {
1969    PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1970    s->fd     = PerlIO_fileno(PerlIONext(f));
1971    /* XXX could (or should) we retrieve the oflags from the open file handle
1972       rather than believing the "mode" we are passed in?
1973       XXX Should the value on NULL mode be 0 or -1?  */
1974    s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
1975   }
1976  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1977  return code;
1978 }
1979
1980 PerlIO *
1981 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)
1982 {
1983  if (f)
1984   {
1985    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1986     (*PerlIOBase(f)->tab->Close)(f);
1987   }
1988  if (narg > 0)
1989   {
1990    char *path = SvPV_nolen(*args);
1991    if (*mode == '#')
1992     mode++;
1993    else
1994     {
1995      imode = PerlIOUnix_oflags(mode);
1996      perm  = 0666;
1997     }
1998    if (imode != -1)
1999     {
2000      fd = PerlLIO_open3(path,imode,perm);
2001     }
2002   }
2003  if (fd >= 0)
2004   {
2005    PerlIOUnix *s;
2006    if (*mode == 'I')
2007     mode++;
2008    if (!f)
2009     {
2010      f = PerlIO_allocate(aTHX);
2011      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2012     }
2013    else
2014     s = PerlIOSelf(f,PerlIOUnix);
2015    s->fd     = fd;
2016    s->oflags = imode;
2017    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2018    return f;
2019   }
2020  else
2021   {
2022    if (f)
2023     {
2024      /* FIXME: pop layers ??? */
2025     }
2026    return NULL;
2027   }
2028 }
2029
2030 SSize_t
2031 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2032 {
2033  dTHX;
2034  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2035  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2036   return 0;
2037  while (1)
2038   {
2039    SSize_t len = PerlLIO_read(fd,vbuf,count);
2040    if (len >= 0 || errno != EINTR)
2041     {
2042      if (len < 0)
2043       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2044      else if (len == 0 && count != 0)
2045       PerlIOBase(f)->flags |= PERLIO_F_EOF;
2046      return len;
2047     }
2048    PERL_ASYNC_CHECK();
2049   }
2050 }
2051
2052 SSize_t
2053 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2054 {
2055  dTHX;
2056  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2057  while (1)
2058   {
2059    SSize_t len = PerlLIO_write(fd,vbuf,count);
2060    if (len >= 0 || errno != EINTR)
2061     {
2062      if (len < 0)
2063       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2064      return len;
2065     }
2066    PERL_ASYNC_CHECK();
2067   }
2068 }
2069
2070 IV
2071 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2072 {
2073  dSYS;
2074  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2075  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2076  return (new == (Off_t) -1) ? -1 : 0;
2077 }
2078
2079 Off_t
2080 PerlIOUnix_tell(PerlIO *f)
2081 {
2082  dSYS;
2083  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2084 }
2085
2086 IV
2087 PerlIOUnix_close(PerlIO *f)
2088 {
2089  dTHX;
2090  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2091  int code = 0;
2092  while (PerlLIO_close(fd) != 0)
2093   {
2094    if (errno != EINTR)
2095     {
2096      code = -1;
2097      break;
2098     }
2099    PERL_ASYNC_CHECK();
2100   }
2101  if (code == 0)
2102   {
2103    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2104   }
2105  return code;
2106 }
2107
2108 PerlIO_funcs PerlIO_unix = {
2109  "unix",
2110  sizeof(PerlIOUnix),
2111  PERLIO_K_RAW,
2112  PerlIOUnix_pushed,
2113  PerlIOBase_noop_ok,
2114  PerlIOUnix_open,
2115  NULL,
2116  PerlIOUnix_fileno,
2117  PerlIOUnix_read,
2118  PerlIOBase_unread,
2119  PerlIOUnix_write,
2120  PerlIOUnix_seek,
2121  PerlIOUnix_tell,
2122  PerlIOUnix_close,
2123  PerlIOBase_noop_ok,   /* flush */
2124  PerlIOBase_noop_fail, /* fill */
2125  PerlIOBase_eof,
2126  PerlIOBase_error,
2127  PerlIOBase_clearerr,
2128  PerlIOBase_setlinebuf,
2129  NULL, /* get_base */
2130  NULL, /* get_bufsiz */
2131  NULL, /* get_ptr */
2132  NULL, /* get_cnt */
2133  NULL, /* set_ptrcnt */
2134 };
2135
2136 /*--------------------------------------------------------------------------------------*/
2137 /* stdio as a layer */
2138
2139 typedef struct
2140 {
2141  struct _PerlIO base;
2142  FILE *         stdio;      /* The stream */
2143 } PerlIOStdio;
2144
2145 IV
2146 PerlIOStdio_fileno(PerlIO *f)
2147 {
2148  dSYS;
2149  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2150 }
2151
2152 char *
2153 PerlIOStdio_mode(const char *mode,char *tmode)
2154 {
2155  char *ret = tmode;
2156  while (*mode)
2157   {
2158    *tmode++ = *mode++;
2159   }
2160  if (O_BINARY != O_TEXT)
2161   {
2162    *tmode++ = 'b';
2163   }
2164  *tmode = '\0';
2165  return ret;
2166 }
2167
2168 /* This isn't used yet ... */
2169 IV
2170 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2171 {
2172  if (*PerlIONext(f))
2173   {
2174    dSYS;
2175    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2176    char tmode[8];
2177    FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2178    if (stdio)
2179     s->stdio = stdio;
2180    else
2181     return -1;
2182   }
2183  return PerlIOBase_pushed(f,mode,arg);
2184 }
2185
2186 #undef PerlIO_importFILE
2187 PerlIO *
2188 PerlIO_importFILE(FILE *stdio, int fl)
2189 {
2190  dTHX;
2191  PerlIO *f = NULL;
2192  if (stdio)
2193   {
2194    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2195    s->stdio  = stdio;
2196   }
2197  return f;
2198 }
2199
2200 PerlIO *
2201 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)
2202 {
2203  char tmode[8];
2204  if (f)
2205   {
2206    char *path = SvPV_nolen(*args);
2207    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2208    FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2209    if (!s->stdio)
2210     return NULL;
2211    s->stdio = stdio;
2212    return f;
2213   }
2214  else
2215   {
2216    if (narg > 0)
2217     {
2218      char *path = SvPV_nolen(*args);
2219      if (*mode == '#')
2220       {
2221        mode++;
2222        fd = PerlLIO_open3(path,imode,perm);
2223       }
2224      else
2225       {
2226        FILE *stdio = PerlSIO_fopen(path,mode);
2227        if (stdio)
2228         {
2229          PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2230                                      (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2231                                      PerlIOStdio);
2232          s->stdio  = stdio;
2233         }
2234        return f;
2235       }
2236     }
2237    if (fd >= 0)
2238     {
2239      FILE *stdio = NULL;
2240      int init = 0;
2241      if (*mode == 'I')
2242       {
2243        init = 1;
2244        mode++;
2245       }
2246      if (init)
2247       {
2248        switch(fd)
2249         {
2250          case 0:
2251           stdio = PerlSIO_stdin;
2252           break;
2253          case 1:
2254           stdio = PerlSIO_stdout;
2255           break;
2256          case 2:
2257           stdio = PerlSIO_stderr;
2258           break;
2259         }
2260       }
2261      else
2262       {
2263        stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2264       }
2265      if (stdio)
2266       {
2267        PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2268        s->stdio  = stdio;
2269        return f;
2270       }
2271     }
2272   }
2273  return NULL;
2274 }
2275
2276 SSize_t
2277 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2278 {
2279  dSYS;
2280  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2281  SSize_t got = 0;
2282  if (count == 1)
2283   {
2284    STDCHAR *buf = (STDCHAR *) vbuf;
2285    /* Perl is expecting PerlIO_getc() to fill the buffer
2286     * Linux's stdio does not do that for fread()
2287     */
2288    int ch = PerlSIO_fgetc(s);
2289    if (ch != EOF)
2290     {
2291      *buf = ch;
2292      got = 1;
2293     }
2294   }
2295  else
2296   got = PerlSIO_fread(vbuf,1,count,s);
2297  return got;
2298 }
2299
2300 SSize_t
2301 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2302 {
2303  dSYS;
2304  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2305  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2306  SSize_t unread = 0;
2307  while (count > 0)
2308   {
2309    int ch = *buf-- & 0xff;
2310    if (PerlSIO_ungetc(ch,s) != ch)
2311     break;
2312    unread++;
2313    count--;
2314   }
2315  return unread;
2316 }
2317
2318 SSize_t
2319 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2320 {
2321  dSYS;
2322  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2323 }
2324
2325 IV
2326 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2327 {
2328  dSYS;
2329  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2330  return PerlSIO_fseek(stdio,offset,whence);
2331 }
2332
2333 Off_t
2334 PerlIOStdio_tell(PerlIO *f)
2335 {
2336  dSYS;
2337  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2338  return PerlSIO_ftell(stdio);
2339 }
2340
2341 IV
2342 PerlIOStdio_close(PerlIO *f)
2343 {
2344  dSYS;
2345 #ifdef SOCKS5_VERSION_NAME
2346  int optval;
2347  Sock_size_t optlen = sizeof(int);
2348 #endif
2349  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2350  return(
2351 #ifdef SOCKS5_VERSION_NAME
2352    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2353        PerlSIO_fclose(stdio) :
2354        close(PerlIO_fileno(f))
2355 #else
2356    PerlSIO_fclose(stdio)
2357 #endif
2358      );
2359
2360 }
2361
2362 IV
2363 PerlIOStdio_flush(PerlIO *f)
2364 {
2365  dSYS;
2366  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2367  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2368   {
2369    return PerlSIO_fflush(stdio);
2370   }
2371  else
2372   {
2373 #if 0
2374    /* FIXME: This discards ungetc() and pre-read stuff which is
2375       not right if this is just a "sync" from a layer above
2376       Suspect right design is to do _this_ but not have layer above
2377       flush this layer read-to-read
2378     */
2379    /* Not writeable - sync by attempting a seek */
2380    int err = errno;
2381    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2382     errno = err;
2383 #endif
2384   }
2385  return 0;
2386 }
2387
2388 IV
2389 PerlIOStdio_fill(PerlIO *f)
2390 {
2391  dSYS;
2392  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2393  int c;
2394  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2395  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2396   {
2397    if (PerlSIO_fflush(stdio) != 0)
2398     return EOF;
2399   }
2400  c = PerlSIO_fgetc(stdio);
2401  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2402   return EOF;
2403  return 0;
2404 }
2405
2406 IV
2407 PerlIOStdio_eof(PerlIO *f)
2408 {
2409  dSYS;
2410  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2411 }
2412
2413 IV
2414 PerlIOStdio_error(PerlIO *f)
2415 {
2416  dSYS;
2417  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2418 }
2419
2420 void
2421 PerlIOStdio_clearerr(PerlIO *f)
2422 {
2423  dSYS;
2424  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2425 }
2426
2427 void
2428 PerlIOStdio_setlinebuf(PerlIO *f)
2429 {
2430  dSYS;
2431 #ifdef HAS_SETLINEBUF
2432  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2433 #else
2434  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2435 #endif
2436 }
2437
2438 #ifdef FILE_base
2439 STDCHAR *
2440 PerlIOStdio_get_base(PerlIO *f)
2441 {
2442  dSYS;
2443  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2444  return PerlSIO_get_base(stdio);
2445 }
2446
2447 Size_t
2448 PerlIOStdio_get_bufsiz(PerlIO *f)
2449 {
2450  dSYS;
2451  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2452  return PerlSIO_get_bufsiz(stdio);
2453 }
2454 #endif
2455
2456 #ifdef USE_STDIO_PTR
2457 STDCHAR *
2458 PerlIOStdio_get_ptr(PerlIO *f)
2459 {
2460  dSYS;
2461  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2462  return PerlSIO_get_ptr(stdio);
2463 }
2464
2465 SSize_t
2466 PerlIOStdio_get_cnt(PerlIO *f)
2467 {
2468  dSYS;
2469  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2470  return PerlSIO_get_cnt(stdio);
2471 }
2472
2473 void
2474 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2475 {
2476  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2477  dSYS;
2478  if (ptr != NULL)
2479   {
2480 #ifdef STDIO_PTR_LVALUE
2481    PerlSIO_set_ptr(stdio,ptr);
2482 #ifdef STDIO_PTR_LVAL_SETS_CNT
2483    if (PerlSIO_get_cnt(stdio) != (cnt))
2484     {
2485      dTHX;
2486      assert(PerlSIO_get_cnt(stdio) == (cnt));
2487     }
2488 #endif
2489 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2490    /* Setting ptr _does_ change cnt - we are done */
2491    return;
2492 #endif
2493 #else  /* STDIO_PTR_LVALUE */
2494    PerlProc_abort();
2495 #endif /* STDIO_PTR_LVALUE */
2496   }
2497 /* Now (or only) set cnt */
2498 #ifdef STDIO_CNT_LVALUE
2499  PerlSIO_set_cnt(stdio,cnt);
2500 #else  /* STDIO_CNT_LVALUE */
2501 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2502  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2503 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2504  PerlProc_abort();
2505 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2506 #endif /* STDIO_CNT_LVALUE */
2507 }
2508
2509 #endif
2510
2511 PerlIO_funcs PerlIO_stdio = {
2512  "stdio",
2513  sizeof(PerlIOStdio),
2514  PERLIO_K_BUFFERED,
2515  PerlIOBase_pushed,
2516  PerlIOBase_noop_ok,
2517  PerlIOStdio_open,
2518  NULL,
2519  PerlIOStdio_fileno,
2520  PerlIOStdio_read,
2521  PerlIOStdio_unread,
2522  PerlIOStdio_write,
2523  PerlIOStdio_seek,
2524  PerlIOStdio_tell,
2525  PerlIOStdio_close,
2526  PerlIOStdio_flush,
2527  PerlIOStdio_fill,
2528  PerlIOStdio_eof,
2529  PerlIOStdio_error,
2530  PerlIOStdio_clearerr,
2531  PerlIOStdio_setlinebuf,
2532 #ifdef FILE_base
2533  PerlIOStdio_get_base,
2534  PerlIOStdio_get_bufsiz,
2535 #else
2536  NULL,
2537  NULL,
2538 #endif
2539 #ifdef USE_STDIO_PTR
2540  PerlIOStdio_get_ptr,
2541  PerlIOStdio_get_cnt,
2542 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2543  PerlIOStdio_set_ptrcnt
2544 #else  /* STDIO_PTR_LVALUE */
2545  NULL
2546 #endif /* STDIO_PTR_LVALUE */
2547 #else  /* USE_STDIO_PTR */
2548  NULL,
2549  NULL,
2550  NULL
2551 #endif /* USE_STDIO_PTR */
2552 };
2553
2554 #undef PerlIO_exportFILE
2555 FILE *
2556 PerlIO_exportFILE(PerlIO *f, int fl)
2557 {
2558  FILE *stdio;
2559  PerlIO_flush(f);
2560  stdio = fdopen(PerlIO_fileno(f),"r+");
2561  if (stdio)
2562   {
2563    dTHX;
2564    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2565    s->stdio  = stdio;
2566   }
2567  return stdio;
2568 }
2569
2570 #undef PerlIO_findFILE
2571 FILE *
2572 PerlIO_findFILE(PerlIO *f)
2573 {
2574  PerlIOl *l = *f;
2575  while (l)
2576   {
2577    if (l->tab == &PerlIO_stdio)
2578     {
2579      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2580      return s->stdio;
2581     }
2582    l = *PerlIONext(&l);
2583   }
2584  return PerlIO_exportFILE(f,0);
2585 }
2586
2587 #undef PerlIO_releaseFILE
2588 void
2589 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2590 {
2591 }
2592
2593 /*--------------------------------------------------------------------------------------*/
2594 /* perlio buffer layer */
2595
2596 IV
2597 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2598 {
2599  dSYS;
2600  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2601  int fd  = PerlIO_fileno(f);
2602  Off_t posn;
2603  if (fd >= 0 && PerlLIO_isatty(fd))
2604   {
2605    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2606   }
2607  posn = PerlIO_tell(PerlIONext(f));
2608  if (posn != (Off_t) -1)
2609   {
2610    b->posn = posn;
2611   }
2612  return PerlIOBase_pushed(f,mode,arg);
2613 }
2614
2615 PerlIO *
2616 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)
2617 {
2618  if (f)
2619   {
2620    PerlIO *next = PerlIONext(f);
2621    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2622    next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2623    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2624     {
2625      return NULL;
2626     }
2627   }
2628  else
2629   {
2630    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2631    int init = 0;
2632    if (*mode == 'I')
2633     {
2634      init = 1;
2635      /* mode++; */
2636     }
2637    f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2638    if (f)
2639     {
2640      PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2641      fd = PerlIO_fileno(f);
2642 #if O_BINARY != O_TEXT
2643      /* do something about failing setmode()? --jhi */
2644      PerlLIO_setmode(fd , O_BINARY);
2645 #endif
2646      if (init && fd == 2)
2647       {
2648        /* Initial stderr is unbuffered */
2649        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2650       }
2651     }
2652   }
2653  return f;
2654 }
2655
2656 /* This "flush" is akin to sfio's sync in that it handles files in either
2657    read or write state
2658 */
2659 IV
2660 PerlIOBuf_flush(PerlIO *f)
2661 {
2662  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2663  int code = 0;
2664  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2665   {
2666    /* write() the buffer */
2667    STDCHAR *buf = b->buf;
2668    STDCHAR *p = buf;
2669    PerlIO *n = PerlIONext(f);
2670    while (p < b->ptr)
2671     {
2672      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2673      if (count > 0)
2674       {
2675        p += count;
2676       }
2677      else if (count < 0 || PerlIO_error(n))
2678       {
2679        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2680        code = -1;
2681        break;
2682       }
2683     }
2684    b->posn += (p - buf);
2685   }
2686  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2687   {
2688    STDCHAR *buf = PerlIO_get_base(f);
2689    /* Note position change */
2690    b->posn += (b->ptr - buf);
2691    if (b->ptr < b->end)
2692     {
2693      /* We did not consume all of it */
2694      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2695       {
2696        b->posn = PerlIO_tell(PerlIONext(f));
2697       }
2698     }
2699   }
2700  b->ptr = b->end = b->buf;
2701  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2702  /* FIXME: Is this right for read case ? */
2703  if (PerlIO_flush(PerlIONext(f)) != 0)
2704   code = -1;
2705  return code;
2706 }
2707
2708 IV
2709 PerlIOBuf_fill(PerlIO *f)
2710 {
2711  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2712  PerlIO *n = PerlIONext(f);
2713  SSize_t avail;
2714  /* FIXME: doing the down-stream flush is a bad idea if it causes
2715     pre-read data in stdio buffer to be discarded
2716     but this is too simplistic - as it skips _our_ hosekeeping
2717     and breaks tell tests.
2718  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2719   {
2720   }
2721   */
2722  if (PerlIO_flush(f) != 0)
2723   return -1;
2724  if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2725   PerlIOBase_flush_linebuf();
2726
2727  if (!b->buf)
2728   PerlIO_get_base(f); /* allocate via vtable */
2729
2730  b->ptr = b->end = b->buf;
2731  if (PerlIO_fast_gets(n))
2732   {
2733    /* Layer below is also buffered
2734     * We do _NOT_ want to call its ->Read() because that will loop
2735     * till it gets what we asked for which may hang on a pipe etc.
2736     * Instead take anything it has to hand, or ask it to fill _once_.
2737     */
2738    avail  = PerlIO_get_cnt(n);
2739    if (avail <= 0)
2740     {
2741      avail = PerlIO_fill(n);
2742      if (avail == 0)
2743       avail = PerlIO_get_cnt(n);
2744      else
2745       {
2746        if (!PerlIO_error(n) && PerlIO_eof(n))
2747         avail = 0;
2748       }
2749     }
2750    if (avail > 0)
2751     {
2752      STDCHAR *ptr = PerlIO_get_ptr(n);
2753      SSize_t cnt  = avail;
2754      if (avail > b->bufsiz)
2755       avail = b->bufsiz;
2756      Copy(ptr,b->buf,avail,STDCHAR);
2757      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2758     }
2759   }
2760  else
2761   {
2762    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2763   }
2764  if (avail <= 0)
2765   {
2766    if (avail == 0)
2767     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2768    else
2769     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2770    return -1;
2771   }
2772  b->end      = b->buf+avail;
2773  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2774  return 0;
2775 }
2776
2777 SSize_t
2778 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2779 {
2780  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2781  if (f)
2782   {
2783    if (!b->ptr)
2784     PerlIO_get_base(f);
2785    return PerlIOBase_read(f,vbuf,count);
2786   }
2787  return 0;
2788 }
2789
2790 SSize_t
2791 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2792 {
2793  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2794  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2795  SSize_t unread = 0;
2796  SSize_t avail;
2797  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2798   PerlIO_flush(f);
2799  if (!b->buf)
2800   PerlIO_get_base(f);
2801  if (b->buf)
2802   {
2803    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2804     {
2805      /* Buffer is already a read buffer, we can overwrite any chars
2806         which have been read back to buffer start
2807       */
2808      avail = (b->ptr - b->buf);
2809     }
2810    else
2811     {
2812      /* Buffer is idle, set it up so whole buffer is available for unread */
2813      avail  = b->bufsiz;
2814      b->end = b->buf + avail;
2815      b->ptr = b->end;
2816      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2817      /* Buffer extends _back_ from where we are now */
2818      b->posn -= b->bufsiz;
2819     }
2820    if (avail > (SSize_t) count)
2821     {
2822      /* If we have space for more than count, just move count */
2823      avail = count;
2824     }
2825    if (avail > 0)
2826     {
2827      b->ptr -= avail;
2828      buf    -= avail;
2829      /* In simple stdio-like ungetc() case chars will be already there */
2830      if (buf != b->ptr)
2831       {
2832        Copy(buf,b->ptr,avail,STDCHAR);
2833       }
2834      count  -= avail;
2835      unread += avail;
2836      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2837     }
2838   }
2839  return unread;
2840 }
2841
2842 SSize_t
2843 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2844 {
2845  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2846  const STDCHAR *buf = (const STDCHAR *) vbuf;
2847  Size_t written = 0;
2848  if (!b->buf)
2849   PerlIO_get_base(f);
2850  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2851   return 0;
2852  while (count > 0)
2853   {
2854    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2855    if ((SSize_t) count < avail)
2856     avail = count;
2857    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2858    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2859     {
2860      while (avail > 0)
2861       {
2862        int ch = *buf++;
2863        *(b->ptr)++ = ch;
2864        count--;
2865        avail--;
2866        written++;
2867        if (ch == '\n')
2868         {
2869          PerlIO_flush(f);
2870          break;
2871         }
2872       }
2873     }
2874    else
2875     {
2876      if (avail)
2877       {
2878        Copy(buf,b->ptr,avail,STDCHAR);
2879        count   -= avail;
2880        buf     += avail;
2881        written += avail;
2882        b->ptr  += avail;
2883       }
2884     }
2885    if (b->ptr >= (b->buf + b->bufsiz))
2886     PerlIO_flush(f);
2887   }
2888  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2889   PerlIO_flush(f);
2890  return written;
2891 }
2892
2893 IV
2894 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2895 {
2896  IV code;
2897  if ((code = PerlIO_flush(f)) == 0)
2898   {
2899    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2900    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2901    code = PerlIO_seek(PerlIONext(f),offset,whence);
2902    if (code == 0)
2903     {
2904      b->posn = PerlIO_tell(PerlIONext(f));
2905     }
2906   }
2907  return code;
2908 }
2909
2910 Off_t
2911 PerlIOBuf_tell(PerlIO *f)
2912 {
2913  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2914  /* b->posn is file position where b->buf was read, or will be written */
2915  Off_t posn = b->posn;
2916  if (b->buf)
2917   {
2918    /* If buffer is valid adjust position by amount in buffer */
2919    posn += (b->ptr - b->buf);
2920   }
2921  return posn;
2922 }
2923
2924 IV
2925 PerlIOBuf_close(PerlIO *f)
2926 {
2927  IV code = PerlIOBase_close(f);
2928  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2929  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2930   {
2931    PerlMemShared_free(b->buf);
2932   }
2933  b->buf = NULL;
2934  b->ptr = b->end = b->buf;
2935  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2936  return code;
2937 }
2938
2939 STDCHAR *
2940 PerlIOBuf_get_ptr(PerlIO *f)
2941 {
2942  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2943  if (!b->buf)
2944   PerlIO_get_base(f);
2945  return b->ptr;
2946 }
2947
2948 SSize_t
2949 PerlIOBuf_get_cnt(PerlIO *f)
2950 {
2951  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2952  if (!b->buf)
2953   PerlIO_get_base(f);
2954  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2955   return (b->end - b->ptr);
2956  return 0;
2957 }
2958
2959 STDCHAR *
2960 PerlIOBuf_get_base(PerlIO *f)
2961 {
2962  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2963  if (!b->buf)
2964   {
2965    if (!b->bufsiz)
2966     b->bufsiz = 4096;
2967    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2968    if (!b->buf)
2969     {
2970      b->buf = (STDCHAR *)&b->oneword;
2971      b->bufsiz = sizeof(b->oneword);
2972     }
2973    b->ptr = b->buf;
2974    b->end = b->ptr;
2975   }
2976  return b->buf;
2977 }
2978
2979 Size_t
2980 PerlIOBuf_bufsiz(PerlIO *f)
2981 {
2982  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2983  if (!b->buf)
2984   PerlIO_get_base(f);
2985  return (b->end - b->buf);
2986 }
2987
2988 void
2989 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2990 {
2991  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2992  if (!b->buf)
2993   PerlIO_get_base(f);
2994  b->ptr = ptr;
2995  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2996   {
2997    dTHX;
2998    assert(PerlIO_get_cnt(f) == cnt);
2999    assert(b->ptr >= b->buf);
3000   }
3001  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3002 }
3003
3004 PerlIO_funcs PerlIO_perlio = {
3005  "perlio",
3006  sizeof(PerlIOBuf),
3007  PERLIO_K_BUFFERED,
3008  PerlIOBuf_pushed,
3009  PerlIOBase_noop_ok,
3010  PerlIOBuf_open,
3011  NULL,
3012  PerlIOBase_fileno,
3013  PerlIOBuf_read,
3014  PerlIOBuf_unread,
3015  PerlIOBuf_write,
3016  PerlIOBuf_seek,
3017  PerlIOBuf_tell,
3018  PerlIOBuf_close,
3019  PerlIOBuf_flush,
3020  PerlIOBuf_fill,
3021  PerlIOBase_eof,
3022  PerlIOBase_error,
3023  PerlIOBase_clearerr,
3024  PerlIOBase_setlinebuf,
3025  PerlIOBuf_get_base,
3026  PerlIOBuf_bufsiz,
3027  PerlIOBuf_get_ptr,
3028  PerlIOBuf_get_cnt,
3029  PerlIOBuf_set_ptrcnt,
3030 };
3031
3032 /*--------------------------------------------------------------------------------------*/
3033 /* Temp layer to hold unread chars when cannot do it any other way */
3034
3035 IV
3036 PerlIOPending_fill(PerlIO *f)
3037 {
3038  /* Should never happen */
3039  PerlIO_flush(f);
3040  return 0;
3041 }
3042
3043 IV
3044 PerlIOPending_close(PerlIO *f)
3045 {
3046  /* A tad tricky - flush pops us, then we close new top */
3047  PerlIO_flush(f);
3048  return PerlIO_close(f);
3049 }
3050
3051 IV
3052 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3053 {
3054  /* A tad tricky - flush pops us, then we seek new top */
3055  PerlIO_flush(f);
3056  return PerlIO_seek(f,offset,whence);
3057 }
3058
3059
3060 IV
3061 PerlIOPending_flush(PerlIO *f)
3062 {
3063  dTHX;
3064  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3065  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3066   {
3067    PerlMemShared_free(b->buf);
3068    b->buf = NULL;
3069   }
3070  PerlIO_pop(aTHX_ f);
3071  return 0;
3072 }
3073
3074 void
3075 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3076 {
3077  if (cnt <= 0)
3078   {
3079    PerlIO_flush(f);
3080   }
3081  else
3082   {
3083    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3084   }
3085 }
3086
3087 IV
3088 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3089 {
3090  IV code    = PerlIOBase_pushed(f,mode,arg);
3091  PerlIOl *l = PerlIOBase(f);
3092  /* Our PerlIO_fast_gets must match what we are pushed on,
3093     or sv_gets() etc. get muddled when it changes mid-string
3094     when we auto-pop.
3095   */
3096  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3097               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3098  return code;
3099 }
3100
3101 SSize_t
3102 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3103 {
3104  SSize_t avail = PerlIO_get_cnt(f);
3105  SSize_t got   = 0;
3106  if (count < avail)
3107   avail = count;
3108  if (avail > 0)
3109   got = PerlIOBuf_read(f,vbuf,avail);
3110  if (got >= 0 && got < count)
3111   {
3112    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3113    if (more >= 0 || got == 0)
3114     got += more;
3115   }
3116  return got;
3117 }
3118
3119 PerlIO_funcs PerlIO_pending = {
3120  "pending",
3121  sizeof(PerlIOBuf),
3122  PERLIO_K_BUFFERED,
3123  PerlIOPending_pushed,
3124  PerlIOBase_noop_ok,
3125  NULL,
3126  NULL,
3127  PerlIOBase_fileno,
3128  PerlIOPending_read,
3129  PerlIOBuf_unread,
3130  PerlIOBuf_write,
3131  PerlIOPending_seek,
3132  PerlIOBuf_tell,
3133  PerlIOPending_close,
3134  PerlIOPending_flush,
3135  PerlIOPending_fill,
3136  PerlIOBase_eof,
3137  PerlIOBase_error,
3138  PerlIOBase_clearerr,
3139  PerlIOBase_setlinebuf,
3140  PerlIOBuf_get_base,
3141  PerlIOBuf_bufsiz,
3142  PerlIOBuf_get_ptr,
3143  PerlIOBuf_get_cnt,
3144  PerlIOPending_set_ptrcnt,
3145 };
3146
3147
3148
3149 /*--------------------------------------------------------------------------------------*/
3150 /* crlf - translation
3151    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3152    to hand back a line at a time and keeping a record of which nl we "lied" about.
3153    On write translate "\n" to CR,LF
3154  */
3155
3156 typedef struct
3157 {
3158  PerlIOBuf      base;         /* PerlIOBuf stuff */
3159  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
3160 } PerlIOCrlf;
3161
3162 IV
3163 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3164 {
3165  IV code;
3166  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3167  code = PerlIOBuf_pushed(f,mode,arg);
3168 #if 0
3169  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3170               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3171               PerlIOBase(f)->flags);
3172 #endif
3173  return code;
3174 }
3175
3176
3177 SSize_t
3178 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3179 {
3180  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3181  if (c->nl)
3182   {
3183    *(c->nl) = 0xd;
3184    c->nl = NULL;
3185   }
3186  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3187   return PerlIOBuf_unread(f,vbuf,count);
3188  else
3189   {
3190    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3191    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3192    SSize_t unread = 0;
3193    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3194     PerlIO_flush(f);
3195    if (!b->buf)
3196     PerlIO_get_base(f);
3197    if (b->buf)
3198     {
3199      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3200       {
3201        b->end = b->ptr = b->buf + b->bufsiz;
3202        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3203        b->posn -= b->bufsiz;
3204       }
3205      while (count > 0 && b->ptr > b->buf)
3206       {
3207        int ch = *--buf;
3208        if (ch == '\n')
3209         {
3210          if (b->ptr - 2 >= b->buf)
3211           {
3212            *--(b->ptr) = 0xa;
3213            *--(b->ptr) = 0xd;
3214            unread++;
3215            count--;
3216           }
3217          else
3218           {
3219            buf++;
3220            break;
3221           }
3222         }
3223        else
3224         {
3225          *--(b->ptr) = ch;
3226          unread++;
3227          count--;
3228         }
3229       }
3230     }
3231    return unread;
3232   }
3233 }
3234
3235 SSize_t
3236 PerlIOCrlf_get_cnt(PerlIO *f)
3237 {
3238  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3239  if (!b->buf)
3240   PerlIO_get_base(f);
3241  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3242   {
3243    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3244    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3245     {
3246      STDCHAR *nl   = b->ptr;
3247     scan:
3248      while (nl < b->end && *nl != 0xd)
3249       nl++;
3250      if (nl < b->end && *nl == 0xd)
3251       {
3252      test:
3253        if (nl+1 < b->end)
3254         {
3255          if (nl[1] == 0xa)
3256           {
3257            *nl   = '\n';
3258            c->nl = nl;
3259           }
3260          else
3261           {
3262            /* Not CR,LF but just CR */
3263            nl++;
3264            goto scan;
3265           }
3266         }
3267        else
3268         {
3269          /* Blast - found CR as last char in buffer */
3270          if (b->ptr < nl)
3271           {
3272            /* They may not care, defer work as long as possible */
3273            return (nl - b->ptr);
3274           }
3275          else
3276           {
3277            int code;
3278            b->ptr++;               /* say we have read it as far as flush() is concerned */
3279            b->buf++;               /* Leave space an front of buffer */
3280            b->bufsiz--;            /* Buffer is thus smaller */
3281            code = PerlIO_fill(f);  /* Fetch some more */
3282            b->bufsiz++;            /* Restore size for next time */
3283            b->buf--;               /* Point at space */
3284            b->ptr = nl = b->buf;   /* Which is what we hand off */
3285            b->posn--;              /* Buffer starts here */
3286            *nl = 0xd;              /* Fill in the CR */
3287            if (code == 0)
3288             goto test;             /* fill() call worked */
3289            /* CR at EOF - just fall through */
3290           }
3291         }
3292       }
3293     }
3294    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3295   }
3296  return 0;
3297 }
3298
3299 void
3300 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3301 {
3302  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3303  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3304  IV flags = PerlIOBase(f)->flags;
3305  if (!b->buf)
3306   PerlIO_get_base(f);
3307  if (!ptr)
3308   {
3309    if (c->nl)
3310     ptr = c->nl+1;
3311    else
3312     {
3313      ptr = b->end;
3314      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3315       ptr--;
3316     }
3317    ptr -= cnt;
3318   }
3319  else
3320   {
3321    /* Test code - delete when it works ... */
3322    STDCHAR *chk;
3323    if (c->nl)
3324     chk = c->nl+1;
3325    else
3326     {
3327      chk = b->end;
3328      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3329       chk--;
3330     }
3331    chk -= cnt;
3332
3333    if (ptr != chk)
3334     {
3335      dTHX;
3336      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3337                 ptr, chk, flags, c->nl, b->end, cnt);
3338     }
3339   }
3340  if (c->nl)
3341   {
3342    if (ptr > c->nl)
3343     {
3344      /* They have taken what we lied about */
3345      *(c->nl) = 0xd;
3346      c->nl = NULL;
3347      ptr++;
3348     }
3349   }
3350  b->ptr = ptr;
3351  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3352 }
3353
3354 SSize_t
3355 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3356 {
3357  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3358   return PerlIOBuf_write(f,vbuf,count);
3359  else
3360   {
3361    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3362    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3363    const STDCHAR *ebuf = buf+count;
3364    if (!b->buf)
3365     PerlIO_get_base(f);
3366    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3367     return 0;
3368    while (buf < ebuf)
3369     {
3370      STDCHAR *eptr = b->buf+b->bufsiz;
3371      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3372      while (buf < ebuf && b->ptr < eptr)
3373       {
3374        if (*buf == '\n')
3375         {
3376          if ((b->ptr + 2) > eptr)
3377           {
3378            /* Not room for both */
3379            PerlIO_flush(f);
3380            break;
3381           }
3382          else
3383           {
3384            *(b->ptr)++ = 0xd; /* CR */
3385            *(b->ptr)++ = 0xa; /* LF */
3386            buf++;
3387            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3388             {
3389              PerlIO_flush(f);
3390              break;
3391             }
3392           }
3393         }
3394        else
3395         {
3396          int ch = *buf++;
3397          *(b->ptr)++ = ch;
3398         }
3399        if (b->ptr >= eptr)
3400         {
3401          PerlIO_flush(f);
3402          break;
3403         }
3404       }
3405     }
3406    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3407     PerlIO_flush(f);
3408    return (buf - (STDCHAR *) vbuf);
3409   }
3410 }
3411
3412 IV
3413 PerlIOCrlf_flush(PerlIO *f)
3414 {
3415  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3416  if (c->nl)
3417   {
3418    *(c->nl) = 0xd;
3419    c->nl = NULL;
3420   }
3421  return PerlIOBuf_flush(f);
3422 }
3423
3424 PerlIO_funcs PerlIO_crlf = {
3425  "crlf",
3426  sizeof(PerlIOCrlf),
3427  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3428  PerlIOCrlf_pushed,
3429  PerlIOBase_noop_ok,   /* popped */
3430  PerlIOBuf_open,
3431  NULL,
3432  PerlIOBase_fileno,
3433  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3434  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3435  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3436  PerlIOBuf_seek,
3437  PerlIOBuf_tell,
3438  PerlIOBuf_close,
3439  PerlIOCrlf_flush,
3440  PerlIOBuf_fill,
3441  PerlIOBase_eof,
3442  PerlIOBase_error,
3443  PerlIOBase_clearerr,
3444  PerlIOBase_setlinebuf,
3445  PerlIOBuf_get_base,
3446  PerlIOBuf_bufsiz,
3447  PerlIOBuf_get_ptr,
3448  PerlIOCrlf_get_cnt,
3449  PerlIOCrlf_set_ptrcnt,
3450 };
3451
3452 #ifdef HAS_MMAP
3453 /*--------------------------------------------------------------------------------------*/
3454 /* mmap as "buffer" layer */
3455
3456 typedef struct
3457 {
3458  PerlIOBuf      base;         /* PerlIOBuf stuff */
3459  Mmap_t         mptr;        /* Mapped address */
3460  Size_t         len;          /* mapped length */
3461  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3462 } PerlIOMmap;
3463
3464 static size_t page_size = 0;
3465
3466 IV
3467 PerlIOMmap_map(PerlIO *f)
3468 {
3469  dTHX;
3470  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3471  IV flags = PerlIOBase(f)->flags;
3472  IV code  = 0;
3473  if (m->len)
3474   abort();
3475  if (flags & PERLIO_F_CANREAD)
3476   {
3477    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3478    int fd   = PerlIO_fileno(f);
3479    struct stat st;
3480    code = fstat(fd,&st);
3481    if (code == 0 && S_ISREG(st.st_mode))
3482     {
3483      SSize_t len = st.st_size - b->posn;
3484      if (len > 0)
3485       {
3486        Off_t posn;
3487        if (!page_size) {
3488 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3489            {
3490                SETERRNO(0,SS$_NORMAL);
3491 #   ifdef _SC_PAGESIZE
3492                page_size = sysconf(_SC_PAGESIZE);
3493 #   else
3494                page_size = sysconf(_SC_PAGE_SIZE);
3495 #   endif
3496                if ((long)page_size < 0) {
3497                    if (errno) {
3498                        SV *error = ERRSV;
3499                        char *msg;
3500                        STRLEN n_a;
3501                        (void)SvUPGRADE(error, SVt_PV);
3502                        msg = SvPVx(error, n_a);
3503                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3504                    }
3505                    else
3506                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3507                }
3508            }
3509 #else
3510 #   ifdef HAS_GETPAGESIZE
3511         page_size = getpagesize();
3512 #   else
3513 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3514         page_size = PAGESIZE; /* compiletime, bad */
3515 #       endif
3516 #   endif
3517 #endif
3518         if ((IV)page_size <= 0)
3519             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3520        }
3521        if (b->posn < 0)
3522         {
3523          /* This is a hack - should never happen - open should have set it ! */
3524          b->posn = PerlIO_tell(PerlIONext(f));
3525         }
3526        posn = (b->posn / page_size) * page_size;
3527        len  = st.st_size - posn;
3528        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3529        if (m->mptr && m->mptr != (Mmap_t) -1)
3530         {
3531 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3532          madvise(m->mptr, len, MADV_SEQUENTIAL);
3533 #endif
3534 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3535          madvise(m->mptr, len, MADV_WILLNEED);
3536 #endif
3537          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3538          b->end  = ((STDCHAR *)m->mptr) + len;
3539          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3540          b->ptr  = b->buf;
3541          m->len  = len;
3542         }
3543        else
3544         {
3545          b->buf = NULL;
3546         }
3547       }
3548      else
3549       {
3550        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3551        b->buf = NULL;
3552        b->ptr = b->end = b->ptr;
3553        code = -1;
3554       }
3555     }
3556   }
3557  return code;
3558 }
3559
3560 IV
3561 PerlIOMmap_unmap(PerlIO *f)
3562 {
3563  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3564  PerlIOBuf  *b = &m->base;
3565  IV code = 0;
3566  if (m->len)
3567   {
3568    if (b->buf)
3569     {
3570      code = munmap(m->mptr, m->len);
3571      b->buf  = NULL;
3572      m->len  = 0;
3573      m->mptr = NULL;
3574      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3575       code = -1;
3576     }
3577    b->ptr = b->end = b->buf;
3578    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3579   }
3580  return code;
3581 }
3582
3583 STDCHAR *
3584 PerlIOMmap_get_base(PerlIO *f)
3585 {
3586  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3587  PerlIOBuf  *b = &m->base;
3588  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3589   {
3590    /* Already have a readbuffer in progress */
3591    return b->buf;
3592   }
3593  if (b->buf)
3594   {
3595    /* We have a write buffer or flushed PerlIOBuf read buffer */
3596    m->bbuf = b->buf;  /* save it in case we need it again */
3597    b->buf  = NULL;    /* Clear to trigger below */
3598   }
3599  if (!b->buf)
3600   {
3601    PerlIOMmap_map(f);     /* Try and map it */
3602    if (!b->buf)
3603     {
3604      /* Map did not work - recover PerlIOBuf buffer if we have one */
3605      b->buf = m->bbuf;
3606     }
3607   }
3608  b->ptr  = b->end = b->buf;
3609  if (b->buf)
3610   return b->buf;
3611  return PerlIOBuf_get_base(f);
3612 }
3613
3614 SSize_t
3615 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3616 {
3617  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3618  PerlIOBuf  *b = &m->base;
3619  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3620   PerlIO_flush(f);
3621  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3622   {
3623    b->ptr -= count;
3624    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3625    return count;
3626   }
3627  if (m->len)
3628   {
3629    /* Loose the unwritable mapped buffer */
3630    PerlIO_flush(f);
3631    /* If flush took the "buffer" see if we have one from before */
3632    if (!b->buf && m->bbuf)
3633     b->buf = m->bbuf;
3634    if (!b->buf)
3635     {
3636      PerlIOBuf_get_base(f);
3637      m->bbuf = b->buf;
3638     }
3639   }
3640 return PerlIOBuf_unread(f,vbuf,count);
3641 }
3642
3643 SSize_t
3644 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3645 {
3646  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3647  PerlIOBuf  *b = &m->base;
3648  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3649   {
3650    /* No, or wrong sort of, buffer */
3651    if (m->len)
3652     {
3653      if (PerlIOMmap_unmap(f) != 0)
3654       return 0;
3655     }
3656    /* If unmap took the "buffer" see if we have one from before */
3657    if (!b->buf && m->bbuf)
3658     b->buf = m->bbuf;
3659    if (!b->buf)
3660     {
3661      PerlIOBuf_get_base(f);
3662      m->bbuf = b->buf;
3663     }
3664   }
3665  return PerlIOBuf_write(f,vbuf,count);
3666 }
3667
3668 IV
3669 PerlIOMmap_flush(PerlIO *f)
3670 {
3671  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3672  PerlIOBuf  *b = &m->base;
3673  IV code = PerlIOBuf_flush(f);
3674  /* Now we are "synced" at PerlIOBuf level */
3675  if (b->buf)
3676   {
3677    if (m->len)
3678     {
3679      /* Unmap the buffer */
3680      if (PerlIOMmap_unmap(f) != 0)
3681       code = -1;
3682     }
3683    else
3684     {
3685      /* We seem to have a PerlIOBuf buffer which was not mapped
3686       * remember it in case we need one later
3687       */
3688      m->bbuf = b->buf;
3689     }
3690   }
3691  return code;
3692 }
3693
3694 IV
3695 PerlIOMmap_fill(PerlIO *f)
3696 {
3697  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3698  IV code = PerlIO_flush(f);
3699  if (code == 0 && !b->buf)
3700   {
3701    code = PerlIOMmap_map(f);
3702   }
3703  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3704   {
3705    code = PerlIOBuf_fill(f);
3706   }
3707  return code;
3708 }
3709
3710 IV
3711 PerlIOMmap_close(PerlIO *f)
3712 {
3713  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3714  PerlIOBuf  *b = &m->base;
3715  IV code = PerlIO_flush(f);
3716  if (m->bbuf)
3717   {
3718    b->buf  = m->bbuf;
3719    m->bbuf = NULL;
3720    b->ptr  = b->end = b->buf;
3721   }
3722  if (PerlIOBuf_close(f) != 0)
3723   code = -1;
3724  return code;
3725 }
3726
3727
3728 PerlIO_funcs PerlIO_mmap = {
3729  "mmap",
3730  sizeof(PerlIOMmap),
3731  PERLIO_K_BUFFERED,
3732  PerlIOBuf_pushed,
3733  PerlIOBase_noop_ok,
3734  PerlIOBuf_open,
3735  NULL,
3736  PerlIOBase_fileno,
3737  PerlIOBuf_read,
3738  PerlIOMmap_unread,
3739  PerlIOMmap_write,
3740  PerlIOBuf_seek,
3741  PerlIOBuf_tell,
3742  PerlIOBuf_close,
3743  PerlIOMmap_flush,
3744  PerlIOMmap_fill,
3745  PerlIOBase_eof,
3746  PerlIOBase_error,
3747  PerlIOBase_clearerr,
3748  PerlIOBase_setlinebuf,
3749  PerlIOMmap_get_base,
3750  PerlIOBuf_bufsiz,
3751  PerlIOBuf_get_ptr,
3752  PerlIOBuf_get_cnt,
3753  PerlIOBuf_set_ptrcnt,
3754 };
3755
3756 #endif /* HAS_MMAP */
3757
3758 void
3759 PerlIO_init(void)
3760 {
3761  dTHX;
3762 #ifndef WIN32
3763  call_atexit(PerlIO_cleanup_layers, NULL);
3764 #endif
3765  if (!_perlio)
3766   {
3767 #ifndef WIN32
3768    atexit(&PerlIO_cleanup);
3769 #endif
3770   }
3771 }
3772
3773 #undef PerlIO_stdin
3774 PerlIO *
3775 PerlIO_stdin(void)
3776 {
3777  if (!_perlio)
3778   {
3779    dTHX;
3780    PerlIO_stdstreams(aTHX);
3781   }
3782  return &_perlio[1];
3783 }
3784
3785 #undef PerlIO_stdout
3786 PerlIO *
3787 PerlIO_stdout(void)
3788 {
3789  if (!_perlio)
3790   {
3791    dTHX;
3792    PerlIO_stdstreams(aTHX);
3793   }
3794  return &_perlio[2];
3795 }
3796
3797 #undef PerlIO_stderr
3798 PerlIO *
3799 PerlIO_stderr(void)
3800 {
3801  if (!_perlio)
3802   {
3803    dTHX;
3804    PerlIO_stdstreams(aTHX);
3805   }
3806  return &_perlio[3];
3807 }
3808
3809 /*--------------------------------------------------------------------------------------*/
3810
3811 #undef PerlIO_getname
3812 char *
3813 PerlIO_getname(PerlIO *f, char *buf)
3814 {
3815  dTHX;
3816  char *name = NULL;
3817 #ifdef VMS
3818  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3819  if (stdio) name = fgetname(stdio, buf);
3820 #else
3821  Perl_croak(aTHX_ "Don't know how to get file name");
3822 #endif
3823  return name;
3824 }
3825
3826
3827 /*--------------------------------------------------------------------------------------*/
3828 /* Functions which can be called on any kind of PerlIO implemented
3829    in terms of above
3830 */
3831
3832 #undef PerlIO_getc
3833 int
3834 PerlIO_getc(PerlIO *f)
3835 {
3836  STDCHAR buf[1];
3837  SSize_t count = PerlIO_read(f,buf,1);
3838  if (count == 1)
3839   {
3840    return (unsigned char) buf[0];
3841   }
3842  return EOF;
3843 }
3844
3845 #undef PerlIO_ungetc
3846 int
3847 PerlIO_ungetc(PerlIO *f, int ch)
3848 {
3849  if (ch != EOF)
3850   {
3851    STDCHAR buf = ch;
3852    if (PerlIO_unread(f,&buf,1) == 1)
3853     return ch;
3854   }
3855  return EOF;
3856 }
3857
3858 #undef PerlIO_putc
3859 int
3860 PerlIO_putc(PerlIO *f, int ch)
3861 {
3862  STDCHAR buf = ch;
3863  return PerlIO_write(f,&buf,1);
3864 }
3865
3866 #undef PerlIO_puts
3867 int
3868 PerlIO_puts(PerlIO *f, const char *s)
3869 {
3870  STRLEN len = strlen(s);
3871  return PerlIO_write(f,s,len);
3872 }
3873
3874 #undef PerlIO_rewind
3875 void
3876 PerlIO_rewind(PerlIO *f)
3877 {
3878  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3879  PerlIO_clearerr(f);
3880 }
3881
3882 #undef PerlIO_vprintf
3883 int
3884 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3885 {
3886  dTHX;
3887  SV *sv = newSVpvn("",0);
3888  char *s;
3889  STRLEN len;
3890  SSize_t wrote;
3891 #ifdef NEED_VA_COPY
3892  va_list apc;
3893  Perl_va_copy(ap, apc);
3894  sv_vcatpvf(sv, fmt, &apc);
3895 #else
3896  sv_vcatpvf(sv, fmt, &ap);
3897 #endif
3898  s = SvPV(sv,len);
3899  wrote = PerlIO_write(f,s,len);
3900  SvREFCNT_dec(sv);
3901  return wrote;
3902 }
3903
3904 #undef PerlIO_printf
3905 int
3906 PerlIO_printf(PerlIO *f,const char *fmt,...)
3907 {
3908  va_list ap;
3909  int result;
3910  va_start(ap,fmt);
3911  result = PerlIO_vprintf(f,fmt,ap);
3912  va_end(ap);
3913  return result;
3914 }
3915
3916 #undef PerlIO_stdoutf
3917 int
3918 PerlIO_stdoutf(const char *fmt,...)
3919 {
3920  va_list ap;
3921  int result;
3922  va_start(ap,fmt);
3923  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3924  va_end(ap);
3925  return result;
3926 }
3927
3928 #undef PerlIO_tmpfile
3929 PerlIO *
3930 PerlIO_tmpfile(void)
3931 {
3932  /* I have no idea how portable mkstemp() is ... */
3933 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3934  dTHX;
3935  PerlIO *f = NULL;
3936  FILE *stdio = PerlSIO_tmpfile();
3937  if (stdio)
3938   {
3939    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3940    s->stdio  = stdio;
3941   }
3942  return f;
3943 #else
3944  dTHX;
3945  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3946  int fd = mkstemp(SvPVX(sv));
3947  PerlIO *f = NULL;
3948  if (fd >= 0)
3949   {
3950    f = PerlIO_fdopen(fd,"w+");
3951    if (f)
3952     {
3953      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3954     }
3955    PerlLIO_unlink(SvPVX(sv));
3956    SvREFCNT_dec(sv);
3957   }
3958  return f;
3959 #endif
3960 }
3961
3962 #undef HAS_FSETPOS
3963 #undef HAS_FGETPOS
3964
3965 #endif /* USE_SFIO */
3966 #endif /* PERLIO_IS_STDIO */
3967
3968 /*======================================================================================*/
3969 /* Now some functions in terms of above which may be needed even if
3970    we are not in true PerlIO mode
3971  */
3972
3973 #ifndef HAS_FSETPOS
3974 #undef PerlIO_setpos
3975 int
3976 PerlIO_setpos(PerlIO *f, SV *pos)
3977 {
3978  dTHX;
3979  if (SvOK(pos))
3980   {
3981    STRLEN len;
3982    Off_t *posn = (Off_t *) SvPV(pos,len);
3983    if (f && len == sizeof(Off_t))
3984     return PerlIO_seek(f,*posn,SEEK_SET);
3985   }
3986  SETERRNO(EINVAL,SS$_IVCHAN);
3987  return -1;
3988 }
3989 #else
3990 #undef PerlIO_setpos
3991 int
3992 PerlIO_setpos(PerlIO *f, SV *pos)
3993 {
3994  dTHX;
3995  if (SvOK(pos))
3996   {
3997    STRLEN len;
3998    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3999    if (f && len == sizeof(Fpos_t))
4000     {
4001 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4002      return fsetpos64(f, fpos);
4003 #else
4004      return fsetpos(f, fpos);
4005 #endif
4006     }
4007   }
4008  SETERRNO(EINVAL,SS$_IVCHAN);
4009  return -1;
4010 }
4011 #endif
4012
4013 #ifndef HAS_FGETPOS
4014 #undef PerlIO_getpos
4015 int
4016 PerlIO_getpos(PerlIO *f, SV *pos)
4017 {
4018  dTHX;
4019  Off_t posn = PerlIO_tell(f);
4020  sv_setpvn(pos,(char *)&posn,sizeof(posn));
4021  return (posn == (Off_t)-1) ? -1 : 0;
4022 }
4023 #else
4024 #undef PerlIO_getpos
4025 int
4026 PerlIO_getpos(PerlIO *f, SV *pos)
4027 {
4028  dTHX;
4029  Fpos_t fpos;
4030  int code;
4031 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4032  code = fgetpos64(f, &fpos);
4033 #else
4034  code = fgetpos(f, &fpos);
4035 #endif
4036  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4037  return code;
4038 }
4039 #endif
4040
4041 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4042
4043 int
4044 vprintf(char *pat, char *args)
4045 {
4046     _doprnt(pat, args, stdout);
4047     return 0;           /* wrong, but perl doesn't use the return value */
4048 }
4049
4050 int
4051 vfprintf(FILE *fd, char *pat, char *args)
4052 {
4053     _doprnt(pat, args, fd);
4054     return 0;           /* wrong, but perl doesn't use the return value */
4055 }
4056
4057 #endif
4058
4059 #ifndef PerlIO_vsprintf
4060 int
4061 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4062 {
4063  int val = vsprintf(s, fmt, ap);
4064  if (n >= 0)
4065   {
4066    if (strlen(s) >= (STRLEN)n)
4067     {
4068      dTHX;
4069      (void)PerlIO_puts(Perl_error_log,
4070                        "panic: sprintf overflow - memory corrupted!\n");
4071      my_exit(1);
4072     }
4073   }
4074  return val;
4075 }
4076 #endif
4077
4078 #ifndef PerlIO_sprintf
4079 int
4080 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4081 {
4082  va_list ap;
4083  int result;
4084  va_start(ap,fmt);
4085  result = PerlIO_vsprintf(s, n, fmt, ap);
4086  va_end(ap);
4087  return result;
4088 }
4089 #endif
4090
4091
4092
4093
4094
4095