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