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