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