perlio.c

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