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