perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2001, Nick Ing-Simmons
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
  11    a dTHX to get at the dispatch tables, even when we do not
  12    need it for other reasons.
  13    Invent a dSYS macro to abstract this out
  14 */
  15 #ifdef PERL_IMPLICIT_SYS
  16 #define dSYS dTHX
  17 #else
  18 #define dSYS dNOOP
  19 #endif
  20
  21 #define VOIDUSED 1
  22 #ifdef PERL_MICRO
  23 #   include "uconfig.h"
  24 #else
  25 #   include "config.h"
  26 #endif
  27
  28 #define PERLIO_NOT_STDIO 0
  29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  30 /* #define PerlIO FILE */
  31 #endif
  32 /*
  33  * This file provides those parts of PerlIO abstraction
  34  * which are not #defined in perlio.h.
  35  * Which these are depends on various Configure #ifdef's
  36  */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_PERLIO_C
  40 #include "perl.h"
  41
  42 #include "XSUB.h"
  43
  44 #undef PerlMemShared_calloc
  45 #define PerlMemShared_calloc(x,y) calloc(x,y)
  46 #undef PerlMemShared_free
  47 #define PerlMemShared_free(x) free(x)
  48
  49 int
  50 perlsio_binmode(FILE *fp, int iotype, int mode)
  51 {
  52 /* This used to be contents of do_binmode in doio.c */
  53 #ifdef DOSISH
  54 #  if defined(atarist) || defined(__MINT__)
  55     if (!fflush(fp)) {
  56         if (mode & O_BINARY)
  57             ((FILE*)fp)->_flag |= _IOBIN;
  58         else
  59             ((FILE*)fp)->_flag &= ~ _IOBIN;
  60         return 1;
  61     }
  62     return 0;
  63 #  else
  64     dTHX;
  65         #ifdef NETWARE
  66         if (PerlLIO_setmode(fp, mode) != -1) {
  67         #else
  68     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  69         #endif
  70 #    if defined(WIN32) && defined(__BORLANDC__)
  71         /* The translation mode of the stream is maintained independent
  72          * of the translation mode of the fd in the Borland RTL (heavy
  73          * digging through their runtime sources reveal).  User has to
  74          * set the mode explicitly for the stream (though they don't
  75          * document this anywhere). GSAR 97-5-24
  76          */
  77         fseek(fp,0L,0);
  78         if (mode & O_BINARY)
  79             fp->flags |= _F_BIN;
  80         else
  81             fp->flags &= ~ _F_BIN;
  82 #    endif
  83         return 1;
  84     }
  85     else
  86         return 0;
  87 #  endif
  88 #else
  89 #  if defined(USEMYBINMODE)
  90     if (my_binmode(fp, iotype, mode) != FALSE)
  91         return 1;
  92     else
  93         return 0;
  94 #  else
  95     return 1;
  96 #  endif
  97 #endif
  98 }
  99
 100 #ifndef PERLIO_LAYERS
 101 int
 102 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 103 {
 104  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
 105   {
 106    return 0;
 107   }
 108  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
 109  /* NOTREACHED */
 110  return -1;
 111 }
 112
 113 void
 114 PerlIO_destruct(pTHX)
 115 {
 116 }
 117
 118 int
 119 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 120 {
 121 #ifdef USE_SFIO
 122  return 1;
 123 #else
 124  return perlsio_binmode(fp,iotype,mode);
 125 #endif
 126 }
 127
 128 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
 129
 130 PerlIO *
 131 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
 132 {
 133  if (narg == 1)
 134   {
 135    if (*args == &PL_sv_undef)
 136     return PerlIO_tmpfile();
 137    else
 138     {
 139      char *name = SvPV_nolen(*args);
 140      if (*mode == '#')
 141       {
 142        fd = PerlLIO_open3(name,imode,perm);
 143        if (fd >= 0)
 144         return PerlIO_fdopen(fd,(char *)mode+1);
 145       }
 146      else if (old)
 147       {
 148        return PerlIO_reopen(name,mode,old);
 149       }
 150      else
 151       {
 152        return PerlIO_open(name,mode);
 153       }
 154     }
 155   }
 156  else
 157   {
 158    return PerlIO_fdopen(fd,(char *)mode);
 159   }
 160  return NULL;
 161 }
 162
 163 XS(XS_PerlIO__Layer__find)
 164 {
 165  dXSARGS;
 166  if (items < 2)
 167   Perl_croak(aTHX_ "Usage class->find(name[,load])");
 168  else
 169   {
 170    char *name = SvPV_nolen(ST(1));
 171    ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
 172    XSRETURN(1);
 173   }
 174 }
 175
 176
 177 void
 178 Perl_boot_core_PerlIO(pTHX)
 179 {
 180  newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
 181 }
 182
 183 #endif
 184
 185
 186 #ifdef PERLIO_IS_STDIO
 187
 188 void
 189 PerlIO_init(void)
 190 {
 191  /* Does nothing (yet) except force this file to be included
 192     in perl binary. That allows this file to force inclusion
 193     of other functions that may be required by loadable
 194     extensions e.g. for FileHandle::tmpfile
 195  */
 196 }
 197
 198 #undef PerlIO_tmpfile
 199 PerlIO *
 200 PerlIO_tmpfile(void)
 201 {
 202  return tmpfile();
 203 }
 204
 205 #else /* PERLIO_IS_STDIO */
 206
 207 #ifdef USE_SFIO
 208
 209 #undef HAS_FSETPOS
 210 #undef HAS_FGETPOS
 211
 212 /* This section is just to make sure these functions
 213    get pulled in from libsfio.a
 214 */
 215
 216 #undef PerlIO_tmpfile
 217 PerlIO *
 218 PerlIO_tmpfile(void)
 219 {
 220  return sftmp(0);
 221 }
 222
 223 void
 224 PerlIO_init(void)
 225 {
 226  /* Force this file to be included  in perl binary. Which allows
 227   *  this file to force inclusion  of other functions that may be
 228   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 229   */
 230
 231  /* Hack
 232   * sfio does its own 'autoflush' on stdout in common cases.
 233   * Flush results in a lot of lseek()s to regular files and
 234   * lot of small writes to pipes.
 235   */
 236  sfset(sfstdout,SF_SHARE,0);
 237 }
 238
 239 PerlIO *
 240 PerlIO_importFILE(FILE *stdio, int fl)
 241 {
 242  int fd    = fileno(stdio);
 243  PerlIO *r = PerlIO_fdopen(fd,"r+");
 244  return r;
 245 }
 246
 247 FILE *
 248 PerlIO_findFILE(PerlIO *pio)
 249 {
 250  int fd = PerlIO_fileno(pio);
 251  FILE *f = fdopen(fd,"r+");
 252  PerlIO_flush(pio);
 253  if (!f && errno == EINVAL)
 254   f = fdopen(fd,"w");
 255  if (!f && errno == EINVAL)
 256   f = fdopen(fd,"r");
 257  return f;
 258 }
 259
 260
 261 #else /* USE_SFIO */
 262 /*======================================================================================*/
 263 /* Implement all the PerlIO interface ourselves.
 264  */
 265
 266 #include "perliol.h"
 267
 268 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 269 #ifdef I_UNISTD
 270 #include <unistd.h>
 271 #endif
 272 #ifdef HAS_MMAP
 273 #include <sys/mman.h>
 274 #endif
 275
 276
 277 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 278
 279 void
 280 PerlIO_debug(const char *fmt,...)
 281 {
 282  static int dbg = 0;
 283  va_list ap;
 284  dSYS;
 285  va_start(ap,fmt);
 286  if (!dbg)
 287   {
 288    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 289    if (s && *s)
 290     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 291    else
 292     dbg = -1;
 293   }
 294  if (dbg > 0)
 295   {
 296    dTHX;
 297    SV *sv = newSVpvn("",0);
 298    char *s;
 299    STRLEN len;
 300    s = CopFILE(PL_curcop);
 301    if (!s)
 302     s = "(none)";
 303    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 304    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 305
 306    s = SvPV(sv,len);
 307    PerlLIO_write(dbg,s,len);
 308    SvREFCNT_dec(sv);
 309   }
 310  va_end(ap);
 311 }
 312
 313 /*--------------------------------------------------------------------------------------*/
 314
 315 /* Inner level routines */
 316
 317 /* Table of pointers to the PerlIO structs (malloc'ed) */
 318 PerlIO *_perlio      = NULL;
 319 #define PERLIO_TABLE_SIZE 64
 320
 321
 322
 323 PerlIO *
 324 PerlIO_allocate(pTHX)
 325 {
 326  /* Find a free slot in the table, allocating new table as necessary */
 327  PerlIO **last;
 328  PerlIO *f;
 329  last = &_perlio;
 330  while ((f = *last))
 331   {
 332    int i;
 333    last = (PerlIO **)(f);
 334    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 335     {
 336      if (!*++f)
 337       {
 338        return f;
 339       }
 340     }
 341   }
 342  f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
 343  if (!f)
 344   {
 345    return NULL;
 346   }
 347  *last = f;
 348  return f+1;
 349 }
 350
 351 void
 352 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 353 {
 354  PerlIO *table = *tablep;
 355  if (table)
 356   {
 357    int i;
 358    PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
 359    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 360     {
 361      PerlIO *f = table+i;
 362      if (*f)
 363       {
 364        PerlIO_close(f);
 365       }
 366     }
 367    PerlMemShared_free(table);
 368    *tablep = NULL;
 369   }
 370 }
 371
 372 PerlIO_list_t *PerlIO_known_layers;
 373 PerlIO_list_t *PerlIO_def_layerlist;
 374
 375 PerlIO_list_t *
 376 PerlIO_list_alloc(void)
 377 {
 378  PerlIO_list_t *list;
 379  Newz('L',list,1,PerlIO_list_t);
 380  list->refcnt = 1;
 381  return list;
 382 }
 383
 384 void
 385 PerlIO_list_free(PerlIO_list_t *list)
 386 {
 387  if (list)
 388   {
 389    if (--list->refcnt == 0)
 390     {
 391      if (list->array)
 392       {
 393        dTHX;
 394        IV i;
 395        for (i=0; i < list->cur; i++)
 396         {
 397          if (list->array[i].arg)
 398           SvREFCNT_dec(list->array[i].arg);
 399         }
 400        Safefree(list->array);
 401       }
 402      Safefree(list);
 403     }
 404   }
 405 }
 406
 407 void
 408 PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
 409 {
 410  dTHX;
 411  PerlIO_pair_t *p;
 412  if (list->cur >= list->len)
 413   {
 414    list->len += 8;
 415    if (list->array)
 416     Renew(list->array,list->len,PerlIO_pair_t);
 417    else
 418     New('l',list->array,list->len,PerlIO_pair_t);
 419   }
 420  p = &(list->array[list->cur++]);
 421  p->funcs = funcs;
 422  if ((p->arg = arg)) {
 423   SvREFCNT_inc(arg);
 424  }
 425 }
 426
 427
 428 void
 429 PerlIO_cleanup_layers(pTHXo_ void *data)
 430 {
 431 #if 0
 432  PerlIO_known_layers = Nullhv;
 433  PerlIO_def_layerlist = Nullav;
 434 #endif
 435 }
 436
 437 void
 438 PerlIO_cleanup()
 439 {
 440  dTHX;
 441  PerlIO_cleantable(aTHX_ &_perlio);
 442 }
 443
 444 void
 445 PerlIO_destruct(pTHX)
 446 {
 447  PerlIO **table = &_perlio;
 448  PerlIO *f;
 449  while ((f = *table))
 450   {
 451    int i;
 452    table = (PerlIO **)(f++);
 453    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 454     {
 455      PerlIO *x = f;
 456      PerlIOl *l;
 457      while ((l = *x))
 458       {
 459        if (l->tab->kind & PERLIO_K_DESTRUCT)
 460         {
 461          PerlIO_debug("Destruct popping %s\n",l->tab->name);
 462          PerlIO_flush(x);
 463          PerlIO_pop(aTHX_ x);
 464         }
 465        else
 466         {
 467          x = PerlIONext(x);
 468         }
 469       }
 470      f++;
 471     }
 472   }
 473 }
 474
 475 void
 476 PerlIO_pop(pTHX_ PerlIO *f)
 477 {
 478  PerlIOl *l = *f;
 479  if (l)
 480   {
 481    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 482    if (l->tab->Popped)
 483     {
 484      /* If popped returns non-zero do not free its layer structure
 485         it has either done so itself, or it is shared and still in use
 486       */
 487      if ((*l->tab->Popped)(f) != 0)
 488       return;
 489     }
 490    *f = l->next;;
 491    PerlMemShared_free(l);
 492   }
 493 }
 494
 495 /*--------------------------------------------------------------------------------------*/
 496 /* XS Interface for perl code */
 497
 498 PerlIO_funcs *
 499 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 500 {
 501  IV i;
 502  if ((SSize_t) len <= 0)
 503   len = strlen(name);
 504  for (i=0; i < PerlIO_known_layers->cur; i++)
 505   {
 506    PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
 507    if (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 #ifdef WIN32
 775    PerlIO_define_layer(aTHX_ &PerlIO_win32);
 776 #if 0
 777    osLayer = &PerlIO_win32;
 778 #endif
 779 #endif
 780    PerlIO_define_layer(aTHX_ &PerlIO_raw);
 781    PerlIO_define_layer(aTHX_ &PerlIO_perlio);
 782    PerlIO_define_layer(aTHX_ &PerlIO_stdio);
 783    PerlIO_define_layer(aTHX_ &PerlIO_crlf);
 784 #ifdef HAS_MMAP
 785    PerlIO_define_layer(aTHX_ &PerlIO_mmap);
 786 #endif
 787    PerlIO_define_layer(aTHX_ &PerlIO_utf8);
 788    PerlIO_define_layer(aTHX_ &PerlIO_byte);
 789    PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ osLayer->name,0,0),&PL_sv_undef);
 790    if (s)
 791     {
 792      PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
 793     }
 794    else
 795     {
 796      PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
 797     }
 798   }
 799  if (PerlIO_def_layerlist->cur < 2)
 800   {
 801    PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
 802   }
 803  return PerlIO_def_layerlist;
 804 }
 805
 806 void
 807 Perl_boot_core_PerlIO(pTHX)
 808 {
 809 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 810    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 811 #endif
 812    newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
 813 }
 814
 815 PerlIO_funcs *
 816 PerlIO_default_layer(pTHX_ I32 n)
 817 {
 818  PerlIO_list_t *av = PerlIO_default_layers(aTHX);
 819  if (n < 0)
 820   n += av->cur;
 821  return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
 822 }
 823
 824 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
 825 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
 826
 827 void
 828 PerlIO_stdstreams(pTHX)
 829 {
 830  if (!_perlio)
 831   {
 832    PerlIO_allocate(aTHX);
 833    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
 834    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
 835    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
 836   }
 837 }
 838
 839 PerlIO *
 840 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
 841 {
 842  PerlIOl *l = NULL;
 843  l = PerlMemShared_calloc(tab->size,sizeof(char));
 844  if (l)
 845   {
 846    Zero(l,tab->size,char);
 847    l->next = *f;
 848    l->tab  = tab;
 849    *f      = l;
 850    PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
 851                  (mode) ? mode : "(Null)",arg);
 852    if ((*l->tab->Pushed)(f,mode,arg) != 0)
 853     {
 854      PerlIO_pop(aTHX_ f);
 855      return NULL;
 856     }
 857   }
 858  return f;
 859 }
 860
 861 IV
 862 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
 863 {
 864  dTHX;
 865  PerlIO_pop(aTHX_ f);
 866  if (*f)
 867   {
 868    PerlIO_flush(f);
 869    PerlIO_pop(aTHX_ f);
 870    return 0;
 871   }
 872  return -1;
 873 }
 874
 875 IV
 876 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
 877 {
 878  /* Remove the dummy layer */
 879  dTHX;
 880  PerlIO_pop(aTHX_ f);
 881  /* Pop back to bottom layer */
 882  if (f && *f)
 883   {
 884    PerlIO_flush(f);
 885    while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
 886     {
 887      if (*PerlIONext(f))
 888       {
 889        PerlIO_pop(aTHX_ f);
 890       }
 891      else
 892       {
 893        /* Nothing bellow - push unix on top then remove it */
 894        if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
 895         {
 896          PerlIO_pop(aTHX_ PerlIONext(f));
 897         }
 898        break;
 899       }
 900     }
 901    PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
 902    return 0;
 903   }
 904  return -1;
 905 }
 906
 907 int
 908 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
 909 {
 910  IV max = layers->cur;
 911  int code = 0;
 912  while (n < max)
 913   {
 914    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
 915    if (tab)
 916     {
 917      if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
 918       {
 919        code = -1;
 920        break;
 921       }
 922     }
 923    n++;
 924   }
 925  return code;
 926 }
 927
 928 int
 929 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 930 {
 931  int code = 0;
 932  if (names)
 933   {
 934    PerlIO_list_t *layers = PerlIO_list_alloc();
 935    code = PerlIO_parse_layers(aTHX_ layers,names);
 936    if (code == 0)
 937     {
 938      code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
 939     }
 940    PerlIO_list_free(layers);
 941   }
 942  return code;
 943 }
 944
 945
 946 /*--------------------------------------------------------------------------------------*/
 947 /* Given the abstraction above the public API functions */
 948
 949 int
 950 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 951 {
 952  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 953               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 954  if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
 955   {
 956    PerlIO *top = f;
 957    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    s->oflags = PerlIOUnix_oflags(mode);
1972   }
1973  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1974  return code;
1975 }
1976
1977 PerlIO *
1978 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)
1979 {
1980  if (f)
1981   {
1982    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1983     (*PerlIOBase(f)->tab->Close)(f);
1984   }
1985  if (narg > 0)
1986   {
1987    char *path = SvPV_nolen(*args);
1988    if (*mode == '#')
1989     mode++;
1990    else
1991     {
1992      imode = PerlIOUnix_oflags(mode);
1993      perm  = 0666;
1994     }
1995    if (imode != -1)
1996     {
1997      fd = PerlLIO_open3(path,imode,perm);
1998     }
1999   }
2000  if (fd >= 0)
2001   {
2002    PerlIOUnix *s;
2003    if (*mode == 'I')
2004     mode++;
2005    if (!f)
2006     {
2007      f = PerlIO_allocate(aTHX);
2008      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2009     }
2010    else
2011     s = PerlIOSelf(f,PerlIOUnix);
2012    s->fd     = fd;
2013    s->oflags = imode;
2014    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2015    return f;
2016   }
2017  else
2018   {
2019    if (f)
2020     {
2021      /* FIXME: pop layers ??? */
2022     }
2023    return NULL;
2024   }
2025 }
2026
2027 SSize_t
2028 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2029 {
2030  dTHX;
2031  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2032  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2033   return 0;
2034  while (1)
2035   {
2036    SSize_t len = PerlLIO_read(fd,vbuf,count);
2037    if (len >= 0 || errno != EINTR)
2038     {
2039      if (len < 0)
2040       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2041      else if (len == 0 && count != 0)
2042       PerlIOBase(f)->flags |= PERLIO_F_EOF;
2043      return len;
2044     }
2045    PERL_ASYNC_CHECK();
2046   }
2047 }
2048
2049 SSize_t
2050 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2051 {
2052  dTHX;
2053  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2054  while (1)
2055   {
2056    SSize_t len = PerlLIO_write(fd,vbuf,count);
2057    if (len >= 0 || errno != EINTR)
2058     {
2059      if (len < 0)
2060       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2061      return len;
2062     }
2063    PERL_ASYNC_CHECK();
2064   }
2065 }
2066
2067 IV
2068 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2069 {
2070  dSYS;
2071  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2072  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2073  return (new == (Off_t) -1) ? -1 : 0;
2074 }
2075
2076 Off_t
2077 PerlIOUnix_tell(PerlIO *f)
2078 {
2079  dSYS;
2080  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2081 }
2082
2083 IV
2084 PerlIOUnix_close(PerlIO *f)
2085 {
2086  dTHX;
2087  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2088  int code = 0;
2089  while (PerlLIO_close(fd) != 0)
2090   {
2091    if (errno != EINTR)
2092     {
2093      code = -1;
2094      break;
2095     }
2096    PERL_ASYNC_CHECK();
2097   }
2098  if (code == 0)
2099   {
2100    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2101   }
2102  return code;
2103 }
2104
2105 PerlIO_funcs PerlIO_unix = {
2106  "unix",
2107  sizeof(PerlIOUnix),
2108  PERLIO_K_RAW,
2109  PerlIOUnix_pushed,
2110  PerlIOBase_noop_ok,
2111  PerlIOUnix_open,
2112  NULL,
2113  PerlIOUnix_fileno,
2114  PerlIOUnix_read,
2115  PerlIOBase_unread,
2116  PerlIOUnix_write,
2117  PerlIOUnix_seek,
2118  PerlIOUnix_tell,
2119  PerlIOUnix_close,
2120  PerlIOBase_noop_ok,   /* flush */
2121  PerlIOBase_noop_fail, /* fill */
2122  PerlIOBase_eof,
2123  PerlIOBase_error,
2124  PerlIOBase_clearerr,
2125  PerlIOBase_setlinebuf,
2126  NULL, /* get_base */
2127  NULL, /* get_bufsiz */
2128  NULL, /* get_ptr */
2129  NULL, /* get_cnt */
2130  NULL, /* set_ptrcnt */
2131 };
2132
2133 /*--------------------------------------------------------------------------------------*/
2134 /* stdio as a layer */
2135
2136 typedef struct
2137 {
2138  struct _PerlIO base;
2139  FILE *         stdio;      /* The stream */
2140 } PerlIOStdio;
2141
2142 IV
2143 PerlIOStdio_fileno(PerlIO *f)
2144 {
2145  dSYS;
2146  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2147 }
2148
2149 char *
2150 PerlIOStdio_mode(const char *mode,char *tmode)
2151 {
2152  char *ret = tmode;
2153  while (*mode)
2154   {
2155    *tmode++ = *mode++;
2156   }
2157  if (O_BINARY != O_TEXT)
2158   {
2159    *tmode++ = 'b';
2160   }
2161  *tmode = '\0';
2162  return ret;
2163 }
2164
2165 /* This isn't used yet ... */
2166 IV
2167 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2168 {
2169  if (*PerlIONext(f))
2170   {
2171    dSYS;
2172    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2173    char tmode[8];
2174    FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2175    if (stdio)
2176     s->stdio = stdio;
2177    else
2178     return -1;
2179   }
2180  return PerlIOBase_pushed(f,mode,arg);
2181 }
2182
2183 #undef PerlIO_importFILE
2184 PerlIO *
2185 PerlIO_importFILE(FILE *stdio, int fl)
2186 {
2187  dTHX;
2188  PerlIO *f = NULL;
2189  if (stdio)
2190   {
2191    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2192    s->stdio  = stdio;
2193   }
2194  return f;
2195 }
2196
2197 PerlIO *
2198 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)
2199 {
2200  char tmode[8];
2201  if (f)
2202   {
2203    char *path = SvPV_nolen(*args);
2204    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2205    FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2206    if (!s->stdio)
2207     return NULL;
2208    s->stdio = stdio;
2209    return f;
2210   }
2211  else
2212   {
2213    if (narg > 0)
2214     {
2215      char *path = SvPV_nolen(*args);
2216      if (*mode == '#')
2217       {
2218        mode++;
2219        fd = PerlLIO_open3(path,imode,perm);
2220       }
2221      else
2222       {
2223        FILE *stdio = PerlSIO_fopen(path,mode);
2224        if (stdio)
2225         {
2226          PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2227                                      (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2228                                      PerlIOStdio);
2229          s->stdio  = stdio;
2230         }
2231        return f;
2232       }
2233     }
2234    if (fd >= 0)
2235     {
2236      FILE *stdio = NULL;
2237      int init = 0;
2238      if (*mode == 'I')
2239       {
2240        init = 1;
2241        mode++;
2242       }
2243      if (init)
2244       {
2245        switch(fd)
2246         {
2247          case 0:
2248           stdio = PerlSIO_stdin;
2249           break;
2250          case 1:
2251           stdio = PerlSIO_stdout;
2252           break;
2253          case 2:
2254           stdio = PerlSIO_stderr;
2255           break;
2256         }
2257       }
2258      else
2259       {
2260        stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2261       }
2262      if (stdio)
2263       {
2264        PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2265        s->stdio  = stdio;
2266        return f;
2267       }
2268     }
2269   }
2270  return NULL;
2271 }
2272
2273 SSize_t
2274 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2275 {
2276  dSYS;
2277  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2278  SSize_t got = 0;
2279  if (count == 1)
2280   {
2281    STDCHAR *buf = (STDCHAR *) vbuf;
2282    /* Perl is expecting PerlIO_getc() to fill the buffer
2283     * Linux's stdio does not do that for fread()
2284     */
2285    int ch = PerlSIO_fgetc(s);
2286    if (ch != EOF)
2287     {
2288      *buf = ch;
2289      got = 1;
2290     }
2291   }
2292  else
2293   got = PerlSIO_fread(vbuf,1,count,s);
2294  return got;
2295 }
2296
2297 SSize_t
2298 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2299 {
2300  dSYS;
2301  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2302  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2303  SSize_t unread = 0;
2304  while (count > 0)
2305   {
2306    int ch = *buf-- & 0xff;
2307    if (PerlSIO_ungetc(ch,s) != ch)
2308     break;
2309    unread++;
2310    count--;
2311   }
2312  return unread;
2313 }
2314
2315 SSize_t
2316 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2317 {
2318  dSYS;
2319  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2320 }
2321
2322 IV
2323 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2324 {
2325  dSYS;
2326  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2327  return PerlSIO_fseek(stdio,offset,whence);
2328 }
2329
2330 Off_t
2331 PerlIOStdio_tell(PerlIO *f)
2332 {
2333  dSYS;
2334  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2335  return PerlSIO_ftell(stdio);
2336 }
2337
2338 IV
2339 PerlIOStdio_close(PerlIO *f)
2340 {
2341  dSYS;
2342 #ifdef SOCKS5_VERSION_NAME
2343  int optval;
2344  Sock_size_t optlen = sizeof(int);
2345 #endif
2346  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2347  return(
2348 #ifdef SOCKS5_VERSION_NAME
2349    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2350        PerlSIO_fclose(stdio) :
2351        close(PerlIO_fileno(f))
2352 #else
2353    PerlSIO_fclose(stdio)
2354 #endif
2355      );
2356
2357 }
2358
2359 IV
2360 PerlIOStdio_flush(PerlIO *f)
2361 {
2362  dSYS;
2363  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2364  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2365   {
2366    return PerlSIO_fflush(stdio);
2367   }
2368  else
2369   {
2370 #if 0
2371    /* FIXME: This discards ungetc() and pre-read stuff which is
2372       not right if this is just a "sync" from a layer above
2373       Suspect right design is to do _this_ but not have layer above
2374       flush this layer read-to-read
2375     */
2376    /* Not writeable - sync by attempting a seek */
2377    int err = errno;
2378    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2379     errno = err;
2380 #endif
2381   }
2382  return 0;
2383 }
2384
2385 IV
2386 PerlIOStdio_fill(PerlIO *f)
2387 {
2388  dSYS;
2389  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2390  int c;
2391  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2392  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2393   {
2394    if (PerlSIO_fflush(stdio) != 0)
2395     return EOF;
2396   }
2397  c = PerlSIO_fgetc(stdio);
2398  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2399   return EOF;
2400  return 0;
2401 }
2402
2403 IV
2404 PerlIOStdio_eof(PerlIO *f)
2405 {
2406  dSYS;
2407  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2408 }
2409
2410 IV
2411 PerlIOStdio_error(PerlIO *f)
2412 {
2413  dSYS;
2414  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2415 }
2416
2417 void
2418 PerlIOStdio_clearerr(PerlIO *f)
2419 {
2420  dSYS;
2421  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2422 }
2423
2424 void
2425 PerlIOStdio_setlinebuf(PerlIO *f)
2426 {
2427  dSYS;
2428 #ifdef HAS_SETLINEBUF
2429  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2430 #else
2431  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2432 #endif
2433 }
2434
2435 #ifdef FILE_base
2436 STDCHAR *
2437 PerlIOStdio_get_base(PerlIO *f)
2438 {
2439  dSYS;
2440  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2441  return PerlSIO_get_base(stdio);
2442 }
2443
2444 Size_t
2445 PerlIOStdio_get_bufsiz(PerlIO *f)
2446 {
2447  dSYS;
2448  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2449  return PerlSIO_get_bufsiz(stdio);
2450 }
2451 #endif
2452
2453 #ifdef USE_STDIO_PTR
2454 STDCHAR *
2455 PerlIOStdio_get_ptr(PerlIO *f)
2456 {
2457  dSYS;
2458  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2459  return PerlSIO_get_ptr(stdio);
2460 }
2461
2462 SSize_t
2463 PerlIOStdio_get_cnt(PerlIO *f)
2464 {
2465  dSYS;
2466  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2467  return PerlSIO_get_cnt(stdio);
2468 }
2469
2470 void
2471 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2472 {
2473  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2474  dSYS;
2475  if (ptr != NULL)
2476   {
2477 #ifdef STDIO_PTR_LVALUE
2478    PerlSIO_set_ptr(stdio,ptr);
2479 #ifdef STDIO_PTR_LVAL_SETS_CNT
2480    if (PerlSIO_get_cnt(stdio) != (cnt))
2481     {
2482      dTHX;
2483      assert(PerlSIO_get_cnt(stdio) == (cnt));
2484     }
2485 #endif
2486 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2487    /* Setting ptr _does_ change cnt - we are done */
2488    return;
2489 #endif
2490 #else  /* STDIO_PTR_LVALUE */
2491    PerlProc_abort();
2492 #endif /* STDIO_PTR_LVALUE */
2493   }
2494 /* Now (or only) set cnt */
2495 #ifdef STDIO_CNT_LVALUE
2496  PerlSIO_set_cnt(stdio,cnt);
2497 #else  /* STDIO_CNT_LVALUE */
2498 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2499  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2500 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2501  PerlProc_abort();
2502 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2503 #endif /* STDIO_CNT_LVALUE */
2504 }
2505
2506 #endif
2507
2508 PerlIO_funcs PerlIO_stdio = {
2509  "stdio",
2510  sizeof(PerlIOStdio),
2511  PERLIO_K_BUFFERED,
2512  PerlIOBase_pushed,
2513  PerlIOBase_noop_ok,
2514  PerlIOStdio_open,
2515  NULL,
2516  PerlIOStdio_fileno,
2517  PerlIOStdio_read,
2518  PerlIOStdio_unread,
2519  PerlIOStdio_write,
2520  PerlIOStdio_seek,
2521  PerlIOStdio_tell,
2522  PerlIOStdio_close,
2523  PerlIOStdio_flush,
2524  PerlIOStdio_fill,
2525  PerlIOStdio_eof,
2526  PerlIOStdio_error,
2527  PerlIOStdio_clearerr,
2528  PerlIOStdio_setlinebuf,
2529 #ifdef FILE_base
2530  PerlIOStdio_get_base,
2531  PerlIOStdio_get_bufsiz,
2532 #else
2533  NULL,
2534  NULL,
2535 #endif
2536 #ifdef USE_STDIO_PTR
2537  PerlIOStdio_get_ptr,
2538  PerlIOStdio_get_cnt,
2539 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2540  PerlIOStdio_set_ptrcnt
2541 #else  /* STDIO_PTR_LVALUE */
2542  NULL
2543 #endif /* STDIO_PTR_LVALUE */
2544 #else  /* USE_STDIO_PTR */
2545  NULL,
2546  NULL,
2547  NULL
2548 #endif /* USE_STDIO_PTR */
2549 };
2550
2551 #undef PerlIO_exportFILE
2552 FILE *
2553 PerlIO_exportFILE(PerlIO *f, int fl)
2554 {
2555  FILE *stdio;
2556  PerlIO_flush(f);
2557  stdio = fdopen(PerlIO_fileno(f),"r+");
2558  if (stdio)
2559   {
2560    dTHX;
2561    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2562    s->stdio  = stdio;
2563   }
2564  return stdio;
2565 }
2566
2567 #undef PerlIO_findFILE
2568 FILE *
2569 PerlIO_findFILE(PerlIO *f)
2570 {
2571  PerlIOl *l = *f;
2572  while (l)
2573   {
2574    if (l->tab == &PerlIO_stdio)
2575     {
2576      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2577      return s->stdio;
2578     }
2579    l = *PerlIONext(&l);
2580   }
2581  return PerlIO_exportFILE(f,0);
2582 }
2583
2584 #undef PerlIO_releaseFILE
2585 void
2586 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2587 {
2588 }
2589
2590 /*--------------------------------------------------------------------------------------*/
2591 /* perlio buffer layer */
2592
2593 IV
2594 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2595 {
2596  dSYS;
2597  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2598  int fd  = PerlIO_fileno(f);
2599  Off_t posn;
2600  if (fd >= 0 && PerlLIO_isatty(fd))
2601   {
2602    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2603   }
2604  posn = PerlIO_tell(PerlIONext(f));
2605  if (posn != (Off_t) -1)
2606   {
2607    b->posn = posn;
2608   }
2609  return PerlIOBase_pushed(f,mode,arg);
2610 }
2611
2612 PerlIO *
2613 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)
2614 {
2615  if (f)
2616   {
2617    PerlIO *next = PerlIONext(f);
2618    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2619    next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2620    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2621     {
2622      return NULL;
2623     }
2624   }
2625  else
2626   {
2627    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2628    int init = 0;
2629    if (*mode == 'I')
2630     {
2631      init = 1;
2632      /* mode++; */
2633     }
2634    f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2635    if (f)
2636     {
2637      PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2638      fd = PerlIO_fileno(f);
2639 #if O_BINARY != O_TEXT
2640      /* do something about failing setmode()? --jhi */
2641      PerlLIO_setmode(fd , O_BINARY);
2642 #endif
2643      if (init && fd == 2)
2644       {
2645        /* Initial stderr is unbuffered */
2646        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2647       }
2648     }
2649   }
2650  return f;
2651 }
2652
2653 /* This "flush" is akin to sfio's sync in that it handles files in either
2654    read or write state
2655 */
2656 IV
2657 PerlIOBuf_flush(PerlIO *f)
2658 {
2659  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2660  int code = 0;
2661  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2662   {
2663    /* write() the buffer */
2664    STDCHAR *buf = b->buf;
2665    STDCHAR *p = buf;
2666    PerlIO *n = PerlIONext(f);
2667    while (p < b->ptr)
2668     {
2669      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2670      if (count > 0)
2671       {
2672        p += count;
2673       }
2674      else if (count < 0 || PerlIO_error(n))
2675       {
2676        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2677        code = -1;
2678        break;
2679       }
2680     }
2681    b->posn += (p - buf);
2682   }
2683  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2684   {
2685    STDCHAR *buf = PerlIO_get_base(f);
2686    /* Note position change */
2687    b->posn += (b->ptr - buf);
2688    if (b->ptr < b->end)
2689     {
2690      /* We did not consume all of it */
2691      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2692       {
2693        b->posn = PerlIO_tell(PerlIONext(f));
2694       }
2695     }
2696   }
2697  b->ptr = b->end = b->buf;
2698  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2699  /* FIXME: Is this right for read case ? */
2700  if (PerlIO_flush(PerlIONext(f)) != 0)
2701   code = -1;
2702  return code;
2703 }
2704
2705 IV
2706 PerlIOBuf_fill(PerlIO *f)
2707 {
2708  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2709  PerlIO *n = PerlIONext(f);
2710  SSize_t avail;
2711  /* FIXME: doing the down-stream flush is a bad idea if it causes
2712     pre-read data in stdio buffer to be discarded
2713     but this is too simplistic - as it skips _our_ hosekeeping
2714     and breaks tell tests.
2715  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2716   {
2717   }
2718   */
2719  if (PerlIO_flush(f) != 0)
2720   return -1;
2721  if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2722   PerlIOBase_flush_linebuf();
2723
2724  if (!b->buf)
2725   PerlIO_get_base(f); /* allocate via vtable */
2726
2727  b->ptr = b->end = b->buf;
2728  if (PerlIO_fast_gets(n))
2729   {
2730    /* Layer below is also buffered
2731     * We do _NOT_ want to call its ->Read() because that will loop
2732     * till it gets what we asked for which may hang on a pipe etc.
2733     * Instead take anything it has to hand, or ask it to fill _once_.
2734     */
2735    avail  = PerlIO_get_cnt(n);
2736    if (avail <= 0)
2737     {
2738      avail = PerlIO_fill(n);
2739      if (avail == 0)
2740       avail = PerlIO_get_cnt(n);
2741      else
2742       {
2743        if (!PerlIO_error(n) && PerlIO_eof(n))
2744         avail = 0;
2745       }
2746     }
2747    if (avail > 0)
2748     {
2749      STDCHAR *ptr = PerlIO_get_ptr(n);
2750      SSize_t cnt  = avail;
2751      if (avail > b->bufsiz)
2752       avail = b->bufsiz;
2753      Copy(ptr,b->buf,avail,STDCHAR);
2754      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2755     }
2756   }
2757  else
2758   {
2759    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2760   }
2761  if (avail <= 0)
2762   {
2763    if (avail == 0)
2764     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2765    else
2766     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2767    return -1;
2768   }
2769  b->end      = b->buf+avail;
2770  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2771  return 0;
2772 }
2773
2774 SSize_t
2775 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2776 {
2777  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2778  if (f)
2779   {
2780    if (!b->ptr)
2781     PerlIO_get_base(f);
2782    return PerlIOBase_read(f,vbuf,count);
2783   }
2784  return 0;
2785 }
2786
2787 SSize_t
2788 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2789 {
2790  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2791  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2792  SSize_t unread = 0;
2793  SSize_t avail;
2794  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2795   PerlIO_flush(f);
2796  if (!b->buf)
2797   PerlIO_get_base(f);
2798  if (b->buf)
2799   {
2800    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2801     {
2802      /* Buffer is already a read buffer, we can overwrite any chars
2803         which have been read back to buffer start
2804       */
2805      avail = (b->ptr - b->buf);
2806     }
2807    else
2808     {
2809      /* Buffer is idle, set it up so whole buffer is available for unread */
2810      avail  = b->bufsiz;
2811      b->end = b->buf + avail;
2812      b->ptr = b->end;
2813      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2814      /* Buffer extends _back_ from where we are now */
2815      b->posn -= b->bufsiz;
2816     }
2817    if (avail > (SSize_t) count)
2818     {
2819      /* If we have space for more than count, just move count */
2820      avail = count;
2821     }
2822    if (avail > 0)
2823     {
2824      b->ptr -= avail;
2825      buf    -= avail;
2826      /* In simple stdio-like ungetc() case chars will be already there */
2827      if (buf != b->ptr)
2828       {
2829        Copy(buf,b->ptr,avail,STDCHAR);
2830       }
2831      count  -= avail;
2832      unread += avail;
2833      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2834     }
2835   }
2836  return unread;
2837 }
2838
2839 SSize_t
2840 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2841 {
2842  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2843  const STDCHAR *buf = (const STDCHAR *) vbuf;
2844  Size_t written = 0;
2845  if (!b->buf)
2846   PerlIO_get_base(f);
2847  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2848   return 0;
2849  while (count > 0)
2850   {
2851    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2852    if ((SSize_t) count < avail)
2853     avail = count;
2854    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2855    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2856     {
2857      while (avail > 0)
2858       {
2859        int ch = *buf++;
2860        *(b->ptr)++ = ch;
2861        count--;
2862        avail--;
2863        written++;
2864        if (ch == '\n')
2865         {
2866          PerlIO_flush(f);
2867          break;
2868         }
2869       }
2870     }
2871    else
2872     {
2873      if (avail)
2874       {
2875        Copy(buf,b->ptr,avail,STDCHAR);
2876        count   -= avail;
2877        buf     += avail;
2878        written += avail;
2879        b->ptr  += avail;
2880       }
2881     }
2882    if (b->ptr >= (b->buf + b->bufsiz))
2883     PerlIO_flush(f);
2884   }
2885  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2886   PerlIO_flush(f);
2887  return written;
2888 }
2889
2890 IV
2891 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2892 {
2893  IV code;
2894  if ((code = PerlIO_flush(f)) == 0)
2895   {
2896    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2897    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2898    code = PerlIO_seek(PerlIONext(f),offset,whence);
2899    if (code == 0)
2900     {
2901      b->posn = PerlIO_tell(PerlIONext(f));
2902     }
2903   }
2904  return code;
2905 }
2906
2907 Off_t
2908 PerlIOBuf_tell(PerlIO *f)
2909 {
2910  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2911  /* b->posn is file position where b->buf was read, or will be written */
2912  Off_t posn = b->posn;
2913  if (b->buf)
2914   {
2915    /* If buffer is valid adjust position by amount in buffer */
2916    posn += (b->ptr - b->buf);
2917   }
2918  return posn;
2919 }
2920
2921 IV
2922 PerlIOBuf_close(PerlIO *f)
2923 {
2924  IV code = PerlIOBase_close(f);
2925  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2926  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2927   {
2928    PerlMemShared_free(b->buf);
2929   }
2930  b->buf = NULL;
2931  b->ptr = b->end = b->buf;
2932  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2933  return code;
2934 }
2935
2936 STDCHAR *
2937 PerlIOBuf_get_ptr(PerlIO *f)
2938 {
2939  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2940  if (!b->buf)
2941   PerlIO_get_base(f);
2942  return b->ptr;
2943 }
2944
2945 SSize_t
2946 PerlIOBuf_get_cnt(PerlIO *f)
2947 {
2948  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2949  if (!b->buf)
2950   PerlIO_get_base(f);
2951  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2952   return (b->end - b->ptr);
2953  return 0;
2954 }
2955
2956 STDCHAR *
2957 PerlIOBuf_get_base(PerlIO *f)
2958 {
2959  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2960  if (!b->buf)
2961   {
2962    if (!b->bufsiz)
2963     b->bufsiz = 4096;
2964    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2965    if (!b->buf)
2966     {
2967      b->buf = (STDCHAR *)&b->oneword;
2968      b->bufsiz = sizeof(b->oneword);
2969     }
2970    b->ptr = b->buf;
2971    b->end = b->ptr;
2972   }
2973  return b->buf;
2974 }
2975
2976 Size_t
2977 PerlIOBuf_bufsiz(PerlIO *f)
2978 {
2979  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2980  if (!b->buf)
2981   PerlIO_get_base(f);
2982  return (b->end - b->buf);
2983 }
2984
2985 void
2986 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2987 {
2988  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2989  if (!b->buf)
2990   PerlIO_get_base(f);
2991  b->ptr = ptr;
2992  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2993   {
2994    dTHX;
2995    assert(PerlIO_get_cnt(f) == cnt);
2996    assert(b->ptr >= b->buf);
2997   }
2998  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2999 }
3000
3001 PerlIO_funcs PerlIO_perlio = {
3002  "perlio",
3003  sizeof(PerlIOBuf),
3004  PERLIO_K_BUFFERED,
3005  PerlIOBuf_pushed,
3006  PerlIOBase_noop_ok,
3007  PerlIOBuf_open,
3008  NULL,
3009  PerlIOBase_fileno,
3010  PerlIOBuf_read,
3011  PerlIOBuf_unread,
3012  PerlIOBuf_write,
3013  PerlIOBuf_seek,
3014  PerlIOBuf_tell,
3015  PerlIOBuf_close,
3016  PerlIOBuf_flush,
3017  PerlIOBuf_fill,
3018  PerlIOBase_eof,
3019  PerlIOBase_error,
3020  PerlIOBase_clearerr,
3021  PerlIOBase_setlinebuf,
3022  PerlIOBuf_get_base,
3023  PerlIOBuf_bufsiz,
3024  PerlIOBuf_get_ptr,
3025  PerlIOBuf_get_cnt,
3026  PerlIOBuf_set_ptrcnt,
3027 };
3028
3029 /*--------------------------------------------------------------------------------------*/
3030 /* Temp layer to hold unread chars when cannot do it any other way */
3031
3032 IV
3033 PerlIOPending_fill(PerlIO *f)
3034 {
3035  /* Should never happen */
3036  PerlIO_flush(f);
3037  return 0;
3038 }
3039
3040 IV
3041 PerlIOPending_close(PerlIO *f)
3042 {
3043  /* A tad tricky - flush pops us, then we close new top */
3044  PerlIO_flush(f);
3045  return PerlIO_close(f);
3046 }
3047
3048 IV
3049 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3050 {
3051  /* A tad tricky - flush pops us, then we seek new top */
3052  PerlIO_flush(f);
3053  return PerlIO_seek(f,offset,whence);
3054 }
3055
3056
3057 IV
3058 PerlIOPending_flush(PerlIO *f)
3059 {
3060  dTHX;
3061  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3062  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3063   {
3064    PerlMemShared_free(b->buf);
3065    b->buf = NULL;
3066   }
3067  PerlIO_pop(aTHX_ f);
3068  return 0;
3069 }
3070
3071 void
3072 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3073 {
3074  if (cnt <= 0)
3075   {
3076    PerlIO_flush(f);
3077   }
3078  else
3079   {
3080    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3081   }
3082 }
3083
3084 IV
3085 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3086 {
3087  IV code    = PerlIOBase_pushed(f,mode,arg);
3088  PerlIOl *l = PerlIOBase(f);
3089  /* Our PerlIO_fast_gets must match what we are pushed on,
3090     or sv_gets() etc. get muddled when it changes mid-string
3091     when we auto-pop.
3092   */
3093  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3094               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3095  return code;
3096 }
3097
3098 SSize_t
3099 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3100 {
3101  SSize_t avail = PerlIO_get_cnt(f);
3102  SSize_t got   = 0;
3103  if (count < avail)
3104   avail = count;
3105  if (avail > 0)
3106   got = PerlIOBuf_read(f,vbuf,avail);
3107  if (got >= 0 && got < count)
3108   {
3109    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3110    if (more >= 0 || got == 0)
3111     got += more;
3112   }
3113  return got;
3114 }
3115
3116 PerlIO_funcs PerlIO_pending = {
3117  "pending",
3118  sizeof(PerlIOBuf),
3119  PERLIO_K_BUFFERED,
3120  PerlIOPending_pushed,
3121  PerlIOBase_noop_ok,
3122  NULL,
3123  NULL,
3124  PerlIOBase_fileno,
3125  PerlIOPending_read,
3126  PerlIOBuf_unread,
3127  PerlIOBuf_write,
3128  PerlIOPending_seek,
3129  PerlIOBuf_tell,
3130  PerlIOPending_close,
3131  PerlIOPending_flush,
3132  PerlIOPending_fill,
3133  PerlIOBase_eof,
3134  PerlIOBase_error,
3135  PerlIOBase_clearerr,
3136  PerlIOBase_setlinebuf,
3137  PerlIOBuf_get_base,
3138  PerlIOBuf_bufsiz,
3139  PerlIOBuf_get_ptr,
3140  PerlIOBuf_get_cnt,
3141  PerlIOPending_set_ptrcnt,
3142 };
3143
3144
3145
3146 /*--------------------------------------------------------------------------------------*/
3147 /* crlf - translation
3148    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3149    to hand back a line at a time and keeping a record of which nl we "lied" about.
3150    On write translate "\n" to CR,LF
3151  */
3152
3153 typedef struct
3154 {
3155  PerlIOBuf      base;         /* PerlIOBuf stuff */
3156  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
3157 } PerlIOCrlf;
3158
3159 IV
3160 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3161 {
3162  IV code;
3163  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3164  code = PerlIOBuf_pushed(f,mode,arg);
3165 #if 0
3166  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3167               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3168               PerlIOBase(f)->flags);
3169 #endif
3170  return code;
3171 }
3172
3173
3174 SSize_t
3175 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3176 {
3177  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3178  if (c->nl)
3179   {
3180    *(c->nl) = 0xd;
3181    c->nl = NULL;
3182   }
3183  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3184   return PerlIOBuf_unread(f,vbuf,count);
3185  else
3186   {
3187    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3188    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3189    SSize_t unread = 0;
3190    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3191     PerlIO_flush(f);
3192    if (!b->buf)
3193     PerlIO_get_base(f);
3194    if (b->buf)
3195     {
3196      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3197       {
3198        b->end = b->ptr = b->buf + b->bufsiz;
3199        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3200        b->posn -= b->bufsiz;
3201       }
3202      while (count > 0 && b->ptr > b->buf)
3203       {
3204        int ch = *--buf;
3205        if (ch == '\n')
3206         {
3207          if (b->ptr - 2 >= b->buf)
3208           {
3209            *--(b->ptr) = 0xa;
3210            *--(b->ptr) = 0xd;
3211            unread++;
3212            count--;
3213           }
3214          else
3215           {
3216            buf++;
3217            break;
3218           }
3219         }
3220        else
3221         {
3222          *--(b->ptr) = ch;
3223          unread++;
3224          count--;
3225         }
3226       }
3227     }
3228    return unread;
3229   }
3230 }
3231
3232 SSize_t
3233 PerlIOCrlf_get_cnt(PerlIO *f)
3234 {
3235  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3236  if (!b->buf)
3237   PerlIO_get_base(f);
3238  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3239   {
3240    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3241    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3242     {
3243      STDCHAR *nl   = b->ptr;
3244     scan:
3245      while (nl < b->end && *nl != 0xd)
3246       nl++;
3247      if (nl < b->end && *nl == 0xd)
3248       {
3249      test:
3250        if (nl+1 < b->end)
3251         {
3252          if (nl[1] == 0xa)
3253           {
3254            *nl   = '\n';
3255            c->nl = nl;
3256           }
3257          else
3258           {
3259            /* Not CR,LF but just CR */
3260            nl++;
3261            goto scan;
3262           }
3263         }
3264        else
3265         {
3266          /* Blast - found CR as last char in buffer */
3267          if (b->ptr < nl)
3268           {
3269            /* They may not care, defer work as long as possible */
3270            return (nl - b->ptr);
3271           }
3272          else
3273           {
3274            int code;
3275            b->ptr++;               /* say we have read it as far as flush() is concerned */
3276            b->buf++;               /* Leave space an front of buffer */
3277            b->bufsiz--;            /* Buffer is thus smaller */
3278            code = PerlIO_fill(f);  /* Fetch some more */
3279            b->bufsiz++;            /* Restore size for next time */
3280            b->buf--;               /* Point at space */
3281            b->ptr = nl = b->buf;   /* Which is what we hand off */
3282            b->posn--;              /* Buffer starts here */
3283            *nl = 0xd;              /* Fill in the CR */
3284            if (code == 0)
3285             goto test;             /* fill() call worked */
3286            /* CR at EOF - just fall through */
3287           }
3288         }
3289       }
3290     }
3291    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3292   }
3293  return 0;
3294 }
3295
3296 void
3297 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3298 {
3299  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3300  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3301  IV flags = PerlIOBase(f)->flags;
3302  if (!b->buf)
3303   PerlIO_get_base(f);
3304  if (!ptr)
3305   {
3306    if (c->nl)
3307     ptr = c->nl+1;
3308    else
3309     {
3310      ptr = b->end;
3311      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3312       ptr--;
3313     }
3314    ptr -= cnt;
3315   }
3316  else
3317   {
3318    /* Test code - delete when it works ... */
3319    STDCHAR *chk;
3320    if (c->nl)
3321     chk = c->nl+1;
3322    else
3323     {
3324      chk = b->end;
3325      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3326       chk--;
3327     }
3328    chk -= cnt;
3329
3330    if (ptr != chk)
3331     {
3332      dTHX;
3333      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3334                 ptr, chk, flags, c->nl, b->end, cnt);
3335     }
3336   }
3337  if (c->nl)
3338   {
3339    if (ptr > c->nl)
3340     {
3341      /* They have taken what we lied about */
3342      *(c->nl) = 0xd;
3343      c->nl = NULL;
3344      ptr++;
3345     }
3346   }
3347  b->ptr = ptr;
3348  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3349 }
3350
3351 SSize_t
3352 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3353 {
3354  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3355   return PerlIOBuf_write(f,vbuf,count);
3356  else
3357   {
3358    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3359    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3360    const STDCHAR *ebuf = buf+count;
3361    if (!b->buf)
3362     PerlIO_get_base(f);
3363    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3364     return 0;
3365    while (buf < ebuf)
3366     {
3367      STDCHAR *eptr = b->buf+b->bufsiz;
3368      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3369      while (buf < ebuf && b->ptr < eptr)
3370       {
3371        if (*buf == '\n')
3372         {
3373          if ((b->ptr + 2) > eptr)
3374           {
3375            /* Not room for both */
3376            PerlIO_flush(f);
3377            break;
3378           }
3379          else
3380           {
3381            *(b->ptr)++ = 0xd; /* CR */
3382            *(b->ptr)++ = 0xa; /* LF */
3383            buf++;
3384            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3385             {
3386              PerlIO_flush(f);
3387              break;
3388             }
3389           }
3390         }
3391        else
3392         {
3393          int ch = *buf++;
3394          *(b->ptr)++ = ch;
3395         }
3396        if (b->ptr >= eptr)
3397         {
3398          PerlIO_flush(f);
3399          break;
3400         }
3401       }
3402     }
3403    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3404     PerlIO_flush(f);
3405    return (buf - (STDCHAR *) vbuf);
3406   }
3407 }
3408
3409 IV
3410 PerlIOCrlf_flush(PerlIO *f)
3411 {
3412  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3413  if (c->nl)
3414   {
3415    *(c->nl) = 0xd;
3416    c->nl = NULL;
3417   }
3418  return PerlIOBuf_flush(f);
3419 }
3420
3421 PerlIO_funcs PerlIO_crlf = {
3422  "crlf",
3423  sizeof(PerlIOCrlf),
3424  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3425  PerlIOCrlf_pushed,
3426  PerlIOBase_noop_ok,   /* popped */
3427  PerlIOBuf_open,
3428  NULL,
3429  PerlIOBase_fileno,
3430  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3431  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3432  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3433  PerlIOBuf_seek,
3434  PerlIOBuf_tell,
3435  PerlIOBuf_close,
3436  PerlIOCrlf_flush,
3437  PerlIOBuf_fill,
3438  PerlIOBase_eof,
3439  PerlIOBase_error,
3440  PerlIOBase_clearerr,
3441  PerlIOBase_setlinebuf,
3442  PerlIOBuf_get_base,
3443  PerlIOBuf_bufsiz,
3444  PerlIOBuf_get_ptr,
3445  PerlIOCrlf_get_cnt,
3446  PerlIOCrlf_set_ptrcnt,
3447 };
3448
3449 #ifdef HAS_MMAP
3450 /*--------------------------------------------------------------------------------------*/
3451 /* mmap as "buffer" layer */
3452
3453 typedef struct
3454 {
3455  PerlIOBuf      base;         /* PerlIOBuf stuff */
3456  Mmap_t         mptr;        /* Mapped address */
3457  Size_t         len;          /* mapped length */
3458  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3459 } PerlIOMmap;
3460
3461 static size_t page_size = 0;
3462
3463 IV
3464 PerlIOMmap_map(PerlIO *f)
3465 {
3466  dTHX;
3467  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3468  IV flags = PerlIOBase(f)->flags;
3469  IV code  = 0;
3470  if (m->len)
3471   abort();
3472  if (flags & PERLIO_F_CANREAD)
3473   {
3474    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3475    int fd   = PerlIO_fileno(f);
3476    struct stat st;
3477    code = fstat(fd,&st);
3478    if (code == 0 && S_ISREG(st.st_mode))
3479     {
3480      SSize_t len = st.st_size - b->posn;
3481      if (len > 0)
3482       {
3483        Off_t posn;
3484        if (!page_size) {
3485 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3486            {
3487                SETERRNO(0,SS$_NORMAL);
3488 #   ifdef _SC_PAGESIZE
3489                page_size = sysconf(_SC_PAGESIZE);
3490 #   else
3491                page_size = sysconf(_SC_PAGE_SIZE);
3492 #   endif
3493                if ((long)page_size < 0) {
3494                    if (errno) {
3495                        SV *error = ERRSV;
3496                        char *msg;
3497                        STRLEN n_a;
3498                        (void)SvUPGRADE(error, SVt_PV);
3499                        msg = SvPVx(error, n_a);
3500                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3501                    }
3502                    else
3503                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3504                }
3505            }
3506 #else
3507 #   ifdef HAS_GETPAGESIZE
3508         page_size = getpagesize();
3509 #   else
3510 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3511         page_size = PAGESIZE; /* compiletime, bad */
3512 #       endif
3513 #   endif
3514 #endif
3515         if ((IV)page_size <= 0)
3516             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3517        }
3518        if (b->posn < 0)
3519         {
3520          /* This is a hack - should never happen - open should have set it ! */
3521          b->posn = PerlIO_tell(PerlIONext(f));
3522         }
3523        posn = (b->posn / page_size) * page_size;
3524        len  = st.st_size - posn;
3525        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3526        if (m->mptr && m->mptr != (Mmap_t) -1)
3527         {
3528 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3529          madvise(m->mptr, len, MADV_SEQUENTIAL);
3530 #endif
3531 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3532          madvise(m->mptr, len, MADV_WILLNEED);
3533 #endif
3534          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3535          b->end  = ((STDCHAR *)m->mptr) + len;
3536          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3537          b->ptr  = b->buf;
3538          m->len  = len;
3539         }
3540        else
3541         {
3542          b->buf = NULL;
3543         }
3544       }
3545      else
3546       {
3547        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3548        b->buf = NULL;
3549        b->ptr = b->end = b->ptr;
3550        code = -1;
3551       }
3552     }
3553   }
3554  return code;
3555 }
3556
3557 IV
3558 PerlIOMmap_unmap(PerlIO *f)
3559 {
3560  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3561  PerlIOBuf  *b = &m->base;
3562  IV code = 0;
3563  if (m->len)
3564   {
3565    if (b->buf)
3566     {
3567      code = munmap(m->mptr, m->len);
3568      b->buf  = NULL;
3569      m->len  = 0;
3570      m->mptr = NULL;
3571      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3572       code = -1;
3573     }
3574    b->ptr = b->end = b->buf;
3575    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3576   }
3577  return code;
3578 }
3579
3580 STDCHAR *
3581 PerlIOMmap_get_base(PerlIO *f)
3582 {
3583  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3584  PerlIOBuf  *b = &m->base;
3585  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3586   {
3587    /* Already have a readbuffer in progress */
3588    return b->buf;
3589   }
3590  if (b->buf)
3591   {
3592    /* We have a write buffer or flushed PerlIOBuf read buffer */
3593    m->bbuf = b->buf;  /* save it in case we need it again */
3594    b->buf  = NULL;    /* Clear to trigger below */
3595   }
3596  if (!b->buf)
3597   {
3598    PerlIOMmap_map(f);     /* Try and map it */
3599    if (!b->buf)
3600     {
3601      /* Map did not work - recover PerlIOBuf buffer if we have one */
3602      b->buf = m->bbuf;
3603     }
3604   }
3605  b->ptr  = b->end = b->buf;
3606  if (b->buf)
3607   return b->buf;
3608  return PerlIOBuf_get_base(f);
3609 }
3610
3611 SSize_t
3612 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3613 {
3614  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3615  PerlIOBuf  *b = &m->base;
3616  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3617   PerlIO_flush(f);
3618  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3619   {
3620    b->ptr -= count;
3621    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3622    return count;
3623   }
3624  if (m->len)
3625   {
3626    /* Loose the unwritable mapped buffer */
3627    PerlIO_flush(f);
3628    /* If flush took the "buffer" see if we have one from before */
3629    if (!b->buf && m->bbuf)
3630     b->buf = m->bbuf;
3631    if (!b->buf)
3632     {
3633      PerlIOBuf_get_base(f);
3634      m->bbuf = b->buf;
3635     }
3636   }
3637 return PerlIOBuf_unread(f,vbuf,count);
3638 }
3639
3640 SSize_t
3641 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3642 {
3643  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3644  PerlIOBuf  *b = &m->base;
3645  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3646   {
3647    /* No, or wrong sort of, buffer */
3648    if (m->len)
3649     {
3650      if (PerlIOMmap_unmap(f) != 0)
3651       return 0;
3652     }
3653    /* If unmap took the "buffer" see if we have one from before */
3654    if (!b->buf && m->bbuf)
3655     b->buf = m->bbuf;
3656    if (!b->buf)
3657     {
3658      PerlIOBuf_get_base(f);
3659      m->bbuf = b->buf;
3660     }
3661   }
3662  return PerlIOBuf_write(f,vbuf,count);
3663 }
3664
3665 IV
3666 PerlIOMmap_flush(PerlIO *f)
3667 {
3668  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3669  PerlIOBuf  *b = &m->base;
3670  IV code = PerlIOBuf_flush(f);
3671  /* Now we are "synced" at PerlIOBuf level */
3672  if (b->buf)
3673   {
3674    if (m->len)
3675     {
3676      /* Unmap the buffer */
3677      if (PerlIOMmap_unmap(f) != 0)
3678       code = -1;
3679     }
3680    else
3681     {
3682      /* We seem to have a PerlIOBuf buffer which was not mapped
3683       * remember it in case we need one later
3684       */
3685      m->bbuf = b->buf;
3686     }
3687   }
3688  return code;
3689 }
3690
3691 IV
3692 PerlIOMmap_fill(PerlIO *f)
3693 {
3694  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3695  IV code = PerlIO_flush(f);
3696  if (code == 0 && !b->buf)
3697   {
3698    code = PerlIOMmap_map(f);
3699   }
3700  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3701   {
3702    code = PerlIOBuf_fill(f);
3703   }
3704  return code;
3705 }
3706
3707 IV
3708 PerlIOMmap_close(PerlIO *f)
3709 {
3710  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3711  PerlIOBuf  *b = &m->base;
3712  IV code = PerlIO_flush(f);
3713  if (m->bbuf)
3714   {
3715    b->buf  = m->bbuf;
3716    m->bbuf = NULL;
3717    b->ptr  = b->end = b->buf;
3718   }
3719  if (PerlIOBuf_close(f) != 0)
3720   code = -1;
3721  return code;
3722 }
3723
3724
3725 PerlIO_funcs PerlIO_mmap = {
3726  "mmap",
3727  sizeof(PerlIOMmap),
3728  PERLIO_K_BUFFERED,
3729  PerlIOBuf_pushed,
3730  PerlIOBase_noop_ok,
3731  PerlIOBuf_open,
3732  NULL,
3733  PerlIOBase_fileno,
3734  PerlIOBuf_read,
3735  PerlIOMmap_unread,
3736  PerlIOMmap_write,
3737  PerlIOBuf_seek,
3738  PerlIOBuf_tell,
3739  PerlIOBuf_close,
3740  PerlIOMmap_flush,
3741  PerlIOMmap_fill,
3742  PerlIOBase_eof,
3743  PerlIOBase_error,
3744  PerlIOBase_clearerr,
3745  PerlIOBase_setlinebuf,
3746  PerlIOMmap_get_base,
3747  PerlIOBuf_bufsiz,
3748  PerlIOBuf_get_ptr,
3749  PerlIOBuf_get_cnt,
3750  PerlIOBuf_set_ptrcnt,
3751 };
3752
3753 #endif /* HAS_MMAP */
3754
3755 void
3756 PerlIO_init(void)
3757 {
3758  dTHX;
3759 #ifndef WIN32
3760  call_atexit(PerlIO_cleanup_layers, NULL);
3761 #endif
3762  if (!_perlio)
3763   {
3764 #ifndef WIN32
3765    atexit(&PerlIO_cleanup);
3766 #endif
3767   }
3768 }
3769
3770 #undef PerlIO_stdin
3771 PerlIO *
3772 PerlIO_stdin(void)
3773 {
3774  if (!_perlio)
3775   {
3776    dTHX;
3777    PerlIO_stdstreams(aTHX);
3778   }
3779  return &_perlio[1];
3780 }
3781
3782 #undef PerlIO_stdout
3783 PerlIO *
3784 PerlIO_stdout(void)
3785 {
3786  if (!_perlio)
3787   {
3788    dTHX;
3789    PerlIO_stdstreams(aTHX);
3790   }
3791  return &_perlio[2];
3792 }
3793
3794 #undef PerlIO_stderr
3795 PerlIO *
3796 PerlIO_stderr(void)
3797 {
3798  if (!_perlio)
3799   {
3800    dTHX;
3801    PerlIO_stdstreams(aTHX);
3802   }
3803  return &_perlio[3];
3804 }
3805
3806 /*--------------------------------------------------------------------------------------*/
3807
3808 #undef PerlIO_getname
3809 char *
3810 PerlIO_getname(PerlIO *f, char *buf)
3811 {
3812  dTHX;
3813  char *name = NULL;
3814 #ifdef VMS
3815  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3816  if (stdio) name = fgetname(stdio, buf);
3817 #else
3818  Perl_croak(aTHX_ "Don't know how to get file name");
3819 #endif
3820  return name;
3821 }
3822
3823
3824 /*--------------------------------------------------------------------------------------*/
3825 /* Functions which can be called on any kind of PerlIO implemented
3826    in terms of above
3827 */
3828
3829 #undef PerlIO_getc
3830 int
3831 PerlIO_getc(PerlIO *f)
3832 {
3833  STDCHAR buf[1];
3834  SSize_t count = PerlIO_read(f,buf,1);
3835  if (count == 1)
3836   {
3837    return (unsigned char) buf[0];
3838   }
3839  return EOF;
3840 }
3841
3842 #undef PerlIO_ungetc
3843 int
3844 PerlIO_ungetc(PerlIO *f, int ch)
3845 {
3846  if (ch != EOF)
3847   {
3848    STDCHAR buf = ch;
3849    if (PerlIO_unread(f,&buf,1) == 1)
3850     return ch;
3851   }
3852  return EOF;
3853 }
3854
3855 #undef PerlIO_putc
3856 int
3857 PerlIO_putc(PerlIO *f, int ch)
3858 {
3859  STDCHAR buf = ch;
3860  return PerlIO_write(f,&buf,1);
3861 }
3862
3863 #undef PerlIO_puts
3864 int
3865 PerlIO_puts(PerlIO *f, const char *s)
3866 {
3867  STRLEN len = strlen(s);
3868  return PerlIO_write(f,s,len);
3869 }
3870
3871 #undef PerlIO_rewind
3872 void
3873 PerlIO_rewind(PerlIO *f)
3874 {
3875  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3876  PerlIO_clearerr(f);
3877 }
3878
3879 #undef PerlIO_vprintf
3880 int
3881 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3882 {
3883  dTHX;
3884  SV *sv = newSVpvn("",0);
3885  char *s;
3886  STRLEN len;
3887  SSize_t wrote;
3888 #ifdef NEED_VA_COPY
3889  va_list apc;
3890  Perl_va_copy(ap, apc);
3891  sv_vcatpvf(sv, fmt, &apc);
3892 #else
3893  sv_vcatpvf(sv, fmt, &ap);
3894 #endif
3895  s = SvPV(sv,len);
3896  wrote = PerlIO_write(f,s,len);
3897  SvREFCNT_dec(sv);
3898  return wrote;
3899 }
3900
3901 #undef PerlIO_printf
3902 int
3903 PerlIO_printf(PerlIO *f,const char *fmt,...)
3904 {
3905  va_list ap;
3906  int result;
3907  va_start(ap,fmt);
3908  result = PerlIO_vprintf(f,fmt,ap);
3909  va_end(ap);
3910  return result;
3911 }
3912
3913 #undef PerlIO_stdoutf
3914 int
3915 PerlIO_stdoutf(const char *fmt,...)
3916 {
3917  va_list ap;
3918  int result;
3919  va_start(ap,fmt);
3920  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3921  va_end(ap);
3922  return result;
3923 }
3924
3925 #undef PerlIO_tmpfile
3926 PerlIO *
3927 PerlIO_tmpfile(void)
3928 {
3929  /* I have no idea how portable mkstemp() is ... */
3930 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3931  dTHX;
3932  PerlIO *f = NULL;
3933  FILE *stdio = PerlSIO_tmpfile();
3934  if (stdio)
3935   {
3936    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3937    s->stdio  = stdio;
3938   }
3939  return f;
3940 #else
3941  dTHX;
3942  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3943  int fd = mkstemp(SvPVX(sv));
3944  PerlIO *f = NULL;
3945  if (fd >= 0)
3946   {
3947    f = PerlIO_fdopen(fd,"w+");
3948    if (f)
3949     {
3950      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3951     }
3952    PerlLIO_unlink(SvPVX(sv));
3953    SvREFCNT_dec(sv);
3954   }
3955  return f;
3956 #endif
3957 }
3958
3959 #undef HAS_FSETPOS
3960 #undef HAS_FGETPOS
3961
3962 #endif /* USE_SFIO */
3963 #endif /* PERLIO_IS_STDIO */
3964
3965 /*======================================================================================*/
3966 /* Now some functions in terms of above which may be needed even if
3967    we are not in true PerlIO mode
3968  */
3969
3970 #ifndef HAS_FSETPOS
3971 #undef PerlIO_setpos
3972 int
3973 PerlIO_setpos(PerlIO *f, SV *pos)
3974 {
3975  dTHX;
3976  if (SvOK(pos))
3977   {
3978    STRLEN len;
3979    Off_t *posn = (Off_t *) SvPV(pos,len);
3980    if (f && len == sizeof(Off_t))
3981     return PerlIO_seek(f,*posn,SEEK_SET);
3982   }
3983  SETERRNO(EINVAL,SS$_IVCHAN);
3984  return -1;
3985 }
3986 #else
3987 #undef PerlIO_setpos
3988 int
3989 PerlIO_setpos(PerlIO *f, SV *pos)
3990 {
3991  dTHX;
3992  if (SvOK(pos))
3993   {
3994    STRLEN len;
3995    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3996    if (f && len == sizeof(Fpos_t))
3997     {
3998 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3999      return fsetpos64(f, fpos);
4000 #else
4001      return fsetpos(f, fpos);
4002 #endif
4003     }
4004   }
4005  SETERRNO(EINVAL,SS$_IVCHAN);
4006  return -1;
4007 }
4008 #endif
4009
4010 #ifndef HAS_FGETPOS
4011 #undef PerlIO_getpos
4012 int
4013 PerlIO_getpos(PerlIO *f, SV *pos)
4014 {
4015  dTHX;
4016  Off_t posn = PerlIO_tell(f);
4017  sv_setpvn(pos,(char *)&posn,sizeof(posn));
4018  return (posn == (Off_t)-1) ? -1 : 0;
4019 }
4020 #else
4021 #undef PerlIO_getpos
4022 int
4023 PerlIO_getpos(PerlIO *f, SV *pos)
4024 {
4025  dTHX;
4026  Fpos_t fpos;
4027  int code;
4028 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4029  code = fgetpos64(f, &fpos);
4030 #else
4031  code = fgetpos(f, &fpos);
4032 #endif
4033  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4034  return code;
4035 }
4036 #endif
4037
4038 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4039
4040 int
4041 vprintf(char *pat, char *args)
4042 {
4043     _doprnt(pat, args, stdout);
4044     return 0;           /* wrong, but perl doesn't use the return value */
4045 }
4046
4047 int
4048 vfprintf(FILE *fd, char *pat, char *args)
4049 {
4050     _doprnt(pat, args, fd);
4051     return 0;           /* wrong, but perl doesn't use the return value */
4052 }
4053
4054 #endif
4055
4056 #ifndef PerlIO_vsprintf
4057 int
4058 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4059 {
4060  int val = vsprintf(s, fmt, ap);
4061  if (n >= 0)
4062   {
4063    if (strlen(s) >= (STRLEN)n)
4064     {
4065      dTHX;
4066      (void)PerlIO_puts(Perl_error_log,
4067                        "panic: sprintf overflow - memory corrupted!\n");
4068      my_exit(1);
4069     }
4070   }
4071  return val;
4072 }
4073 #endif
4074
4075 #ifndef PerlIO_sprintf
4076 int
4077 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4078 {
4079  va_list ap;
4080  int result;
4081  va_start(ap,fmt);
4082  result = PerlIO_vsprintf(s, n, fmt, ap);
4083  va_end(ap);
4084  return result;
4085 }
4086 #endif
4087
4088
4089
4090
4091
4092