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, optlen = sizeof(int);
2097 #endif
2098  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2099  return(
2100 #ifdef HAS_SOCKS5_INIT
2101    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2102        PerlSIO_fclose(stdio) :
2103        close(PerlIO_fileno(f))
2104 #else
2105    PerlSIO_fclose(stdio)
2106 #endif
2107      );
2108
2109 }
2110
2111 IV
2112 PerlIOStdio_flush(PerlIO *f)
2113 {
2114  dTHX;
2115  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2116  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2117   {
2118    return PerlSIO_fflush(stdio);
2119   }
2120  else
2121   {
2122 #if 0
2123    /* FIXME: This discards ungetc() and pre-read stuff which is
2124       not right if this is just a "sync" from a layer above
2125       Suspect right design is to do _this_ but not have layer above
2126       flush this layer read-to-read
2127     */
2128    /* Not writeable - sync by attempting a seek */
2129    int err = errno;
2130    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2131     errno = err;
2132 #endif
2133   }
2134  return 0;
2135 }
2136
2137 IV
2138 PerlIOStdio_fill(PerlIO *f)
2139 {
2140  dTHX;
2141  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2142  int c;
2143  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2144  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2145   {
2146    if (PerlSIO_fflush(stdio) != 0)
2147     return EOF;
2148   }
2149  c = PerlSIO_fgetc(stdio);
2150  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2151   return EOF;
2152  return 0;
2153 }
2154
2155 IV
2156 PerlIOStdio_eof(PerlIO *f)
2157 {
2158  dTHX;
2159  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2160 }
2161
2162 IV
2163 PerlIOStdio_error(PerlIO *f)
2164 {
2165  dTHX;
2166  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2167 }
2168
2169 void
2170 PerlIOStdio_clearerr(PerlIO *f)
2171 {
2172  dTHX;
2173  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2174 }
2175
2176 void
2177 PerlIOStdio_setlinebuf(PerlIO *f)
2178 {
2179  dTHX;
2180 #ifdef HAS_SETLINEBUF
2181  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2182 #else
2183  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2184 #endif
2185 }
2186
2187 #ifdef FILE_base
2188 STDCHAR *
2189 PerlIOStdio_get_base(PerlIO *f)
2190 {
2191  dTHX;
2192  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2193  return PerlSIO_get_base(stdio);
2194 }
2195
2196 Size_t
2197 PerlIOStdio_get_bufsiz(PerlIO *f)
2198 {
2199  dTHX;
2200  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2201  return PerlSIO_get_bufsiz(stdio);
2202 }
2203 #endif
2204
2205 #ifdef USE_STDIO_PTR
2206 STDCHAR *
2207 PerlIOStdio_get_ptr(PerlIO *f)
2208 {
2209  dTHX;
2210  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2211  return PerlSIO_get_ptr(stdio);
2212 }
2213
2214 SSize_t
2215 PerlIOStdio_get_cnt(PerlIO *f)
2216 {
2217  dTHX;
2218  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2219  return PerlSIO_get_cnt(stdio);
2220 }
2221
2222 void
2223 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2224 {
2225  dTHX;
2226  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2227  if (ptr != NULL)
2228   {
2229 #ifdef STDIO_PTR_LVALUE
2230    PerlSIO_set_ptr(stdio,ptr);
2231 #ifdef STDIO_PTR_LVAL_SETS_CNT
2232    if (PerlSIO_get_cnt(stdio) != (cnt))
2233     {
2234      dTHX;
2235      assert(PerlSIO_get_cnt(stdio) == (cnt));
2236     }
2237 #endif
2238 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2239    /* Setting ptr _does_ change cnt - we are done */
2240    return;
2241 #endif
2242 #else  /* STDIO_PTR_LVALUE */
2243    PerlProc_abort();
2244 #endif /* STDIO_PTR_LVALUE */
2245   }
2246 /* Now (or only) set cnt */
2247 #ifdef STDIO_CNT_LVALUE
2248  PerlSIO_set_cnt(stdio,cnt);
2249 #else  /* STDIO_CNT_LVALUE */
2250 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2251  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2252 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2253  PerlProc_abort();
2254 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2255 #endif /* STDIO_CNT_LVALUE */
2256 }
2257
2258 #endif
2259
2260 PerlIO_funcs PerlIO_stdio = {
2261  "stdio",
2262  sizeof(PerlIOStdio),
2263  PERLIO_K_BUFFERED,
2264  PerlIOBase_pushed,
2265  PerlIOBase_noop_ok,
2266  PerlIOStdio_open,
2267  NULL,
2268  PerlIOStdio_fileno,
2269  PerlIOStdio_read,
2270  PerlIOStdio_unread,
2271  PerlIOStdio_write,
2272  PerlIOStdio_seek,
2273  PerlIOStdio_tell,
2274  PerlIOStdio_close,
2275  PerlIOStdio_flush,
2276  PerlIOStdio_fill,
2277  PerlIOStdio_eof,
2278  PerlIOStdio_error,
2279  PerlIOStdio_clearerr,
2280  PerlIOStdio_setlinebuf,
2281 #ifdef FILE_base
2282  PerlIOStdio_get_base,
2283  PerlIOStdio_get_bufsiz,
2284 #else
2285  NULL,
2286  NULL,
2287 #endif
2288 #ifdef USE_STDIO_PTR
2289  PerlIOStdio_get_ptr,
2290  PerlIOStdio_get_cnt,
2291 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2292  PerlIOStdio_set_ptrcnt
2293 #else  /* STDIO_PTR_LVALUE */
2294  NULL
2295 #endif /* STDIO_PTR_LVALUE */
2296 #else  /* USE_STDIO_PTR */
2297  NULL,
2298  NULL,
2299  NULL
2300 #endif /* USE_STDIO_PTR */
2301 };
2302
2303 #undef PerlIO_exportFILE
2304 FILE *
2305 PerlIO_exportFILE(PerlIO *f, int fl)
2306 {
2307  FILE *stdio;
2308  PerlIO_flush(f);
2309  stdio = fdopen(PerlIO_fileno(f),"r+");
2310  if (stdio)
2311   {
2312    dTHX;
2313    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2314    s->stdio  = stdio;
2315   }
2316  return stdio;
2317 }
2318
2319 #undef PerlIO_findFILE
2320 FILE *
2321 PerlIO_findFILE(PerlIO *f)
2322 {
2323  PerlIOl *l = *f;
2324  while (l)
2325   {
2326    if (l->tab == &PerlIO_stdio)
2327     {
2328      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2329      return s->stdio;
2330     }
2331    l = *PerlIONext(&l);
2332   }
2333  return PerlIO_exportFILE(f,0);
2334 }
2335
2336 #undef PerlIO_releaseFILE
2337 void
2338 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2339 {
2340 }
2341
2342 /*--------------------------------------------------------------------------------------*/
2343 /* perlio buffer layer */
2344
2345 IV
2346 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2347 {
2348  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2349  int fd  = PerlIO_fileno(f);
2350  Off_t posn;
2351  dTHX;
2352  if (fd >= 0 && PerlLIO_isatty(fd))
2353   {
2354    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2355   }
2356  posn = PerlIO_tell(PerlIONext(f));
2357  if (posn != (Off_t) -1)
2358   {
2359    b->posn = posn;
2360   }
2361  return PerlIOBase_pushed(f,mode,arg);
2362 }
2363
2364 PerlIO *
2365 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)
2366 {
2367  if (f)
2368   {
2369    PerlIO *next = PerlIONext(f);
2370    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2371    next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2372    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2373     {
2374      return NULL;
2375     }
2376   }
2377  else
2378   {
2379    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2380    int init = 0;
2381    if (*mode == 'I')
2382     {
2383      init = 1;
2384      mode++;
2385     }
2386    f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2387    if (f)
2388     {
2389      PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2390      fd = PerlIO_fileno(f);
2391 #if O_BINARY != O_TEXT
2392      /* do something about failing setmode()? --jhi */
2393      PerlLIO_setmode(fd , O_BINARY);
2394 #endif
2395      if (init && fd == 2)
2396       {
2397        /* Initial stderr is unbuffered */
2398        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2399       }
2400     }
2401   }
2402  return f;
2403 }
2404
2405 /* This "flush" is akin to sfio's sync in that it handles files in either
2406    read or write state
2407 */
2408 IV
2409 PerlIOBuf_flush(PerlIO *f)
2410 {
2411  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2412  int code = 0;
2413  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2414   {
2415    /* write() the buffer */
2416    STDCHAR *buf = b->buf;
2417    STDCHAR *p = buf;
2418    PerlIO *n = PerlIONext(f);
2419    while (p < b->ptr)
2420     {
2421      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2422      if (count > 0)
2423       {
2424        p += count;
2425       }
2426      else if (count < 0 || PerlIO_error(n))
2427       {
2428        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2429        code = -1;
2430        break;
2431       }
2432     }
2433    b->posn += (p - buf);
2434   }
2435  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2436   {
2437    STDCHAR *buf = PerlIO_get_base(f);
2438    /* Note position change */
2439    b->posn += (b->ptr - buf);
2440    if (b->ptr < b->end)
2441     {
2442      /* We did not consume all of it */
2443      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2444       {
2445        b->posn = PerlIO_tell(PerlIONext(f));
2446       }
2447     }
2448   }
2449  b->ptr = b->end = b->buf;
2450  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2451  /* FIXME: Is this right for read case ? */
2452  if (PerlIO_flush(PerlIONext(f)) != 0)
2453   code = -1;
2454  return code;
2455 }
2456
2457 IV
2458 PerlIOBuf_fill(PerlIO *f)
2459 {
2460  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2461  PerlIO *n = PerlIONext(f);
2462  SSize_t avail;
2463  /* FIXME: doing the down-stream flush is a bad idea if it causes
2464     pre-read data in stdio buffer to be discarded
2465     but this is too simplistic - as it skips _our_ hosekeeping
2466     and breaks tell tests.
2467  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2468   {
2469   }
2470   */
2471  if (PerlIO_flush(f) != 0)
2472   return -1;
2473  if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2474   PerlIOBase_flush_linebuf();
2475
2476  if (!b->buf)
2477   PerlIO_get_base(f); /* allocate via vtable */
2478
2479  b->ptr = b->end = b->buf;
2480  if (PerlIO_fast_gets(n))
2481   {
2482    /* Layer below is also buffered
2483     * We do _NOT_ want to call its ->Read() because that will loop
2484     * till it gets what we asked for which may hang on a pipe etc.
2485     * Instead take anything it has to hand, or ask it to fill _once_.
2486     */
2487    avail  = PerlIO_get_cnt(n);
2488    if (avail <= 0)
2489     {
2490      avail = PerlIO_fill(n);
2491      if (avail == 0)
2492       avail = PerlIO_get_cnt(n);
2493      else
2494       {
2495        if (!PerlIO_error(n) && PerlIO_eof(n))
2496         avail = 0;
2497       }
2498     }
2499    if (avail > 0)
2500     {
2501      STDCHAR *ptr = PerlIO_get_ptr(n);
2502      SSize_t cnt  = avail;
2503      if (avail > b->bufsiz)
2504       avail = b->bufsiz;
2505      Copy(ptr,b->buf,avail,STDCHAR);
2506      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2507     }
2508   }
2509  else
2510   {
2511    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2512   }
2513  if (avail <= 0)
2514   {
2515    if (avail == 0)
2516     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2517    else
2518     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2519    return -1;
2520   }
2521  b->end      = b->buf+avail;
2522  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2523  return 0;
2524 }
2525
2526 SSize_t
2527 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2528 {
2529  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2530  if (f)
2531   {
2532    if (!b->ptr)
2533     PerlIO_get_base(f);
2534    return PerlIOBase_read(f,vbuf,count);
2535   }
2536  return 0;
2537 }
2538
2539 SSize_t
2540 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2541 {
2542  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2543  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2544  SSize_t unread = 0;
2545  SSize_t avail;
2546  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2547   PerlIO_flush(f);
2548  if (!b->buf)
2549   PerlIO_get_base(f);
2550  if (b->buf)
2551   {
2552    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2553     {
2554      avail = (b->ptr - b->buf);
2555     }
2556    else
2557     {
2558      avail = b->bufsiz;
2559      b->end = b->buf + avail;
2560      b->ptr = b->end;
2561      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2562      b->posn -= b->bufsiz;
2563     }
2564    if (avail > (SSize_t) count)
2565     avail = count;
2566    if (avail > 0)
2567     {
2568      b->ptr -= avail;
2569      buf    -= avail;
2570      if (buf != b->ptr)
2571       {
2572        Copy(buf,b->ptr,avail,STDCHAR);
2573       }
2574      count  -= avail;
2575      unread += avail;
2576      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2577     }
2578   }
2579  return unread;
2580 }
2581
2582 SSize_t
2583 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2584 {
2585  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2586  const STDCHAR *buf = (const STDCHAR *) vbuf;
2587  Size_t written = 0;
2588  if (!b->buf)
2589   PerlIO_get_base(f);
2590  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2591   return 0;
2592  while (count > 0)
2593   {
2594    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2595    if ((SSize_t) count < avail)
2596     avail = count;
2597    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2598    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2599     {
2600      while (avail > 0)
2601       {
2602        int ch = *buf++;
2603        *(b->ptr)++ = ch;
2604        count--;
2605        avail--;
2606        written++;
2607        if (ch == '\n')
2608         {
2609          PerlIO_flush(f);
2610          break;
2611         }
2612       }
2613     }
2614    else
2615     {
2616      if (avail)
2617       {
2618        Copy(buf,b->ptr,avail,STDCHAR);
2619        count   -= avail;
2620        buf     += avail;
2621        written += avail;
2622        b->ptr  += avail;
2623       }
2624     }
2625    if (b->ptr >= (b->buf + b->bufsiz))
2626     PerlIO_flush(f);
2627   }
2628  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2629   PerlIO_flush(f);
2630  return written;
2631 }
2632
2633 IV
2634 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2635 {
2636  IV code;
2637  if ((code = PerlIO_flush(f)) == 0)
2638   {
2639    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2640    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2641    code = PerlIO_seek(PerlIONext(f),offset,whence);
2642    if (code == 0)
2643     {
2644      b->posn = PerlIO_tell(PerlIONext(f));
2645     }
2646   }
2647  return code;
2648 }
2649
2650 Off_t
2651 PerlIOBuf_tell(PerlIO *f)
2652 {
2653  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2654  Off_t posn = b->posn;
2655  if (b->buf)
2656   posn += (b->ptr - b->buf);
2657  return posn;
2658 }
2659
2660 IV
2661 PerlIOBuf_close(PerlIO *f)
2662 {
2663  dTHX;
2664  IV code = PerlIOBase_close(f);
2665  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2666  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2667   {
2668    PerlMemShared_free(b->buf);
2669   }
2670  b->buf = NULL;
2671  b->ptr = b->end = b->buf;
2672  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2673  return code;
2674 }
2675
2676 STDCHAR *
2677 PerlIOBuf_get_ptr(PerlIO *f)
2678 {
2679  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2680  if (!b->buf)
2681   PerlIO_get_base(f);
2682  return b->ptr;
2683 }
2684
2685 SSize_t
2686 PerlIOBuf_get_cnt(PerlIO *f)
2687 {
2688  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2689  if (!b->buf)
2690   PerlIO_get_base(f);
2691  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2692   return (b->end - b->ptr);
2693  return 0;
2694 }
2695
2696 STDCHAR *
2697 PerlIOBuf_get_base(PerlIO *f)
2698 {
2699  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2700  if (!b->buf)
2701   {
2702    dTHX;
2703    if (!b->bufsiz)
2704     b->bufsiz = 4096;
2705    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2706    if (!b->buf)
2707     {
2708      b->buf = (STDCHAR *)&b->oneword;
2709      b->bufsiz = sizeof(b->oneword);
2710     }
2711    b->ptr = b->buf;
2712    b->end = b->ptr;
2713   }
2714  return b->buf;
2715 }
2716
2717 Size_t
2718 PerlIOBuf_bufsiz(PerlIO *f)
2719 {
2720  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2721  if (!b->buf)
2722   PerlIO_get_base(f);
2723  return (b->end - b->buf);
2724 }
2725
2726 void
2727 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2728 {
2729  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2730  if (!b->buf)
2731   PerlIO_get_base(f);
2732  b->ptr = ptr;
2733  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2734   {
2735    dTHX;
2736    assert(PerlIO_get_cnt(f) == cnt);
2737    assert(b->ptr >= b->buf);
2738   }
2739  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2740 }
2741
2742 PerlIO_funcs PerlIO_perlio = {
2743  "perlio",
2744  sizeof(PerlIOBuf),
2745  PERLIO_K_BUFFERED,
2746  PerlIOBuf_pushed,
2747  PerlIOBase_noop_ok,
2748  PerlIOBuf_open,
2749  NULL,
2750  PerlIOBase_fileno,
2751  PerlIOBuf_read,
2752  PerlIOBuf_unread,
2753  PerlIOBuf_write,
2754  PerlIOBuf_seek,
2755  PerlIOBuf_tell,
2756  PerlIOBuf_close,
2757  PerlIOBuf_flush,
2758  PerlIOBuf_fill,
2759  PerlIOBase_eof,
2760  PerlIOBase_error,
2761  PerlIOBase_clearerr,
2762  PerlIOBase_setlinebuf,
2763  PerlIOBuf_get_base,
2764  PerlIOBuf_bufsiz,
2765  PerlIOBuf_get_ptr,
2766  PerlIOBuf_get_cnt,
2767  PerlIOBuf_set_ptrcnt,
2768 };
2769
2770 /*--------------------------------------------------------------------------------------*/
2771 /* Temp layer to hold unread chars when cannot do it any other way */
2772
2773 IV
2774 PerlIOPending_fill(PerlIO *f)
2775 {
2776  /* Should never happen */
2777  PerlIO_flush(f);
2778  return 0;
2779 }
2780
2781 IV
2782 PerlIOPending_close(PerlIO *f)
2783 {
2784  /* A tad tricky - flush pops us, then we close new top */
2785  PerlIO_flush(f);
2786  return PerlIO_close(f);
2787 }
2788
2789 IV
2790 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2791 {
2792  /* A tad tricky - flush pops us, then we seek new top */
2793  PerlIO_flush(f);
2794  return PerlIO_seek(f,offset,whence);
2795 }
2796
2797
2798 IV
2799 PerlIOPending_flush(PerlIO *f)
2800 {
2801  dTHX;
2802  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2803  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2804   {
2805    PerlMemShared_free(b->buf);
2806    b->buf = NULL;
2807   }
2808  PerlIO_pop(aTHX_ f);
2809  return 0;
2810 }
2811
2812 void
2813 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2814 {
2815  if (cnt <= 0)
2816   {
2817    PerlIO_flush(f);
2818   }
2819  else
2820   {
2821    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2822   }
2823 }
2824
2825 IV
2826 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2827 {
2828  IV code    = PerlIOBase_pushed(f,mode,arg);
2829  PerlIOl *l = PerlIOBase(f);
2830  /* Our PerlIO_fast_gets must match what we are pushed on,
2831     or sv_gets() etc. get muddled when it changes mid-string
2832     when we auto-pop.
2833   */
2834  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2835               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2836  return code;
2837 }
2838
2839 SSize_t
2840 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2841 {
2842  SSize_t avail = PerlIO_get_cnt(f);
2843  SSize_t got   = 0;
2844  if (count < avail)
2845   avail = count;
2846  if (avail > 0)
2847   got = PerlIOBuf_read(f,vbuf,avail);
2848  if (got >= 0 && got < count)
2849   {
2850    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2851    if (more >= 0 || got == 0)
2852     got += more;
2853   }
2854  return got;
2855 }
2856
2857 PerlIO_funcs PerlIO_pending = {
2858  "pending",
2859  sizeof(PerlIOBuf),
2860  PERLIO_K_BUFFERED,
2861  PerlIOPending_pushed,
2862  PerlIOBase_noop_ok,
2863  NULL,
2864  NULL,
2865  PerlIOBase_fileno,
2866  PerlIOPending_read,
2867  PerlIOBuf_unread,
2868  PerlIOBuf_write,
2869  PerlIOPending_seek,
2870  PerlIOBuf_tell,
2871  PerlIOPending_close,
2872  PerlIOPending_flush,
2873  PerlIOPending_fill,
2874  PerlIOBase_eof,
2875  PerlIOBase_error,
2876  PerlIOBase_clearerr,
2877  PerlIOBase_setlinebuf,
2878  PerlIOBuf_get_base,
2879  PerlIOBuf_bufsiz,
2880  PerlIOBuf_get_ptr,
2881  PerlIOBuf_get_cnt,
2882  PerlIOPending_set_ptrcnt,
2883 };
2884
2885
2886
2887 /*--------------------------------------------------------------------------------------*/
2888 /* crlf - translation
2889    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2890    to hand back a line at a time and keeping a record of which nl we "lied" about.
2891    On write translate "\n" to CR,LF
2892  */
2893
2894 typedef struct
2895 {
2896  PerlIOBuf      base;         /* PerlIOBuf stuff */
2897  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2898 } PerlIOCrlf;
2899
2900 IV
2901 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2902 {
2903  IV code;
2904  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2905  code = PerlIOBuf_pushed(f,mode,arg);
2906 #if 0
2907  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2908               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2909               PerlIOBase(f)->flags);
2910 #endif
2911  return code;
2912 }
2913
2914
2915 SSize_t
2916 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2917 {
2918  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2919  if (c->nl)
2920   {
2921    *(c->nl) = 0xd;
2922    c->nl = NULL;
2923   }
2924  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2925   return PerlIOBuf_unread(f,vbuf,count);
2926  else
2927   {
2928    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2929    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2930    SSize_t unread = 0;
2931    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2932     PerlIO_flush(f);
2933    if (!b->buf)
2934     PerlIO_get_base(f);
2935    if (b->buf)
2936     {
2937      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2938       {
2939        b->end = b->ptr = b->buf + b->bufsiz;
2940        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2941        b->posn -= b->bufsiz;
2942       }
2943      while (count > 0 && b->ptr > b->buf)
2944       {
2945        int ch = *--buf;
2946        if (ch == '\n')
2947         {
2948          if (b->ptr - 2 >= b->buf)
2949           {
2950            *--(b->ptr) = 0xa;
2951            *--(b->ptr) = 0xd;
2952            unread++;
2953            count--;
2954           }
2955          else
2956           {
2957            buf++;
2958            break;
2959           }
2960         }
2961        else
2962         {
2963          *--(b->ptr) = ch;
2964          unread++;
2965          count--;
2966         }
2967       }
2968     }
2969    return unread;
2970   }
2971 }
2972
2973 SSize_t
2974 PerlIOCrlf_get_cnt(PerlIO *f)
2975 {
2976  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2977  if (!b->buf)
2978   PerlIO_get_base(f);
2979  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2980   {
2981    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2982    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2983     {
2984      STDCHAR *nl   = b->ptr;
2985     scan:
2986      while (nl < b->end && *nl != 0xd)
2987       nl++;
2988      if (nl < b->end && *nl == 0xd)
2989       {
2990      test:
2991        if (nl+1 < b->end)
2992         {
2993          if (nl[1] == 0xa)
2994           {
2995            *nl   = '\n';
2996            c->nl = nl;
2997           }
2998          else
2999           {
3000            /* Not CR,LF but just CR */
3001            nl++;
3002            goto scan;
3003           }
3004         }
3005        else
3006         {
3007          /* Blast - found CR as last char in buffer */
3008          if (b->ptr < nl)
3009           {
3010            /* They may not care, defer work as long as possible */
3011            return (nl - b->ptr);
3012           }
3013          else
3014           {
3015            int code;
3016            dTHX;
3017            b->ptr++;               /* say we have read it as far as flush() is concerned */
3018            b->buf++;               /* Leave space an front of buffer */
3019            b->bufsiz--;            /* Buffer is thus smaller */
3020            code = PerlIO_fill(f);  /* Fetch some more */
3021            b->bufsiz++;            /* Restore size for next time */
3022            b->buf--;               /* Point at space */
3023            b->ptr = nl = b->buf;   /* Which is what we hand off */
3024            b->posn--;              /* Buffer starts here */
3025            *nl = 0xd;              /* Fill in the CR */
3026            if (code == 0)
3027             goto test;             /* fill() call worked */
3028            /* CR at EOF - just fall through */
3029           }
3030         }
3031       }
3032     }
3033    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3034   }
3035  return 0;
3036 }
3037
3038 void
3039 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3040 {
3041  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3042  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3043  IV flags = PerlIOBase(f)->flags;
3044  if (!b->buf)
3045   PerlIO_get_base(f);
3046  if (!ptr)
3047   {
3048    if (c->nl)
3049     ptr = c->nl+1;
3050    else
3051     {
3052      ptr = b->end;
3053      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3054       ptr--;
3055     }
3056    ptr -= cnt;
3057   }
3058  else
3059   {
3060    /* Test code - delete when it works ... */
3061    STDCHAR *chk;
3062    if (c->nl)
3063     chk = c->nl+1;
3064    else
3065     {
3066      chk = b->end;
3067      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3068       chk--;
3069     }
3070    chk -= cnt;
3071
3072    if (ptr != chk)
3073     {
3074      dTHX;
3075      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3076                 ptr, chk, flags, c->nl, b->end, cnt);
3077     }
3078   }
3079  if (c->nl)
3080   {
3081    if (ptr > c->nl)
3082     {
3083      /* They have taken what we lied about */
3084      *(c->nl) = 0xd;
3085      c->nl = NULL;
3086      ptr++;
3087     }
3088   }
3089  b->ptr = ptr;
3090  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3091 }
3092
3093 SSize_t
3094 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3095 {
3096  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3097   return PerlIOBuf_write(f,vbuf,count);
3098  else
3099   {
3100    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3101    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3102    const STDCHAR *ebuf = buf+count;
3103    if (!b->buf)
3104     PerlIO_get_base(f);
3105    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3106     return 0;
3107    while (buf < ebuf)
3108     {
3109      STDCHAR *eptr = b->buf+b->bufsiz;
3110      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3111      while (buf < ebuf && b->ptr < eptr)
3112       {
3113        if (*buf == '\n')
3114         {
3115          if ((b->ptr + 2) > eptr)
3116           {
3117            /* Not room for both */
3118            PerlIO_flush(f);
3119            break;
3120           }
3121          else
3122           {
3123            *(b->ptr)++ = 0xd; /* CR */
3124            *(b->ptr)++ = 0xa; /* LF */
3125            buf++;
3126            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3127             {
3128              PerlIO_flush(f);
3129              break;
3130             }
3131           }
3132         }
3133        else
3134         {
3135          int ch = *buf++;
3136          *(b->ptr)++ = ch;
3137         }
3138        if (b->ptr >= eptr)
3139         {
3140          PerlIO_flush(f);
3141          break;
3142         }
3143       }
3144     }
3145    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3146     PerlIO_flush(f);
3147    return (buf - (STDCHAR *) vbuf);
3148   }
3149 }
3150
3151 IV
3152 PerlIOCrlf_flush(PerlIO *f)
3153 {
3154  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3155  if (c->nl)
3156   {
3157    *(c->nl) = 0xd;
3158    c->nl = NULL;
3159   }
3160  return PerlIOBuf_flush(f);
3161 }
3162
3163 PerlIO_funcs PerlIO_crlf = {
3164  "crlf",
3165  sizeof(PerlIOCrlf),
3166  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3167  PerlIOCrlf_pushed,
3168  PerlIOBase_noop_ok,   /* popped */
3169  PerlIOBuf_open,
3170  NULL,
3171  PerlIOBase_fileno,
3172  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3173  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3174  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3175  PerlIOBuf_seek,
3176  PerlIOBuf_tell,
3177  PerlIOBuf_close,
3178  PerlIOCrlf_flush,
3179  PerlIOBuf_fill,
3180  PerlIOBase_eof,
3181  PerlIOBase_error,
3182  PerlIOBase_clearerr,
3183  PerlIOBase_setlinebuf,
3184  PerlIOBuf_get_base,
3185  PerlIOBuf_bufsiz,
3186  PerlIOBuf_get_ptr,
3187  PerlIOCrlf_get_cnt,
3188  PerlIOCrlf_set_ptrcnt,
3189 };
3190
3191 #ifdef HAS_MMAP
3192 /*--------------------------------------------------------------------------------------*/
3193 /* mmap as "buffer" layer */
3194
3195 typedef struct
3196 {
3197  PerlIOBuf      base;         /* PerlIOBuf stuff */
3198  Mmap_t         mptr;        /* Mapped address */
3199  Size_t         len;          /* mapped length */
3200  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3201 } PerlIOMmap;
3202
3203 static size_t page_size = 0;
3204
3205 IV
3206 PerlIOMmap_map(PerlIO *f)
3207 {
3208  dTHX;
3209  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3210  PerlIOBuf  *b = &m->base;
3211  IV flags = PerlIOBase(f)->flags;
3212  IV code  = 0;
3213  if (m->len)
3214   abort();
3215  if (flags & PERLIO_F_CANREAD)
3216   {
3217    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3218    int fd   = PerlIO_fileno(f);
3219    struct stat st;
3220    code = fstat(fd,&st);
3221    if (code == 0 && S_ISREG(st.st_mode))
3222     {
3223      SSize_t len = st.st_size - b->posn;
3224      if (len > 0)
3225       {
3226        Off_t posn;
3227        if (!page_size) {
3228 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3229            {
3230                SETERRNO(0,SS$_NORMAL);
3231 #   ifdef _SC_PAGESIZE
3232                page_size = sysconf(_SC_PAGESIZE);
3233 #   else
3234                page_size = sysconf(_SC_PAGE_SIZE);
3235 #   endif
3236                if ((long)page_size < 0) {
3237                    if (errno) {
3238                        SV *error = ERRSV;
3239                        char *msg;
3240                        STRLEN n_a;
3241                        (void)SvUPGRADE(error, SVt_PV);
3242                        msg = SvPVx(error, n_a);
3243                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3244                    }
3245                    else
3246                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3247                }
3248            }
3249 #else
3250 #   ifdef HAS_GETPAGESIZE
3251         page_size = getpagesize();
3252 #   else
3253 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3254         page_size = PAGESIZE; /* compiletime, bad */
3255 #       endif
3256 #   endif
3257 #endif
3258         if ((IV)page_size <= 0)
3259             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3260        }
3261        if (b->posn < 0)
3262         {
3263          /* This is a hack - should never happen - open should have set it ! */
3264          b->posn = PerlIO_tell(PerlIONext(f));
3265         }
3266        posn = (b->posn / page_size) * page_size;
3267        len  = st.st_size - posn;
3268        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3269        if (m->mptr && m->mptr != (Mmap_t) -1)
3270         {
3271 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3272          madvise(m->mptr, len, MADV_SEQUENTIAL);
3273 #endif
3274 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3275          madvise(m->mptr, len, MADV_WILLNEED);
3276 #endif
3277          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3278          b->end  = ((STDCHAR *)m->mptr) + len;
3279          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3280          b->ptr  = b->buf;
3281          m->len  = len;
3282         }
3283        else
3284         {
3285          b->buf = NULL;
3286         }
3287       }
3288      else
3289       {
3290        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3291        b->buf = NULL;
3292        b->ptr = b->end = b->ptr;
3293        code = -1;
3294       }
3295     }
3296   }
3297  return code;
3298 }
3299
3300 IV
3301 PerlIOMmap_unmap(PerlIO *f)
3302 {
3303  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3304  PerlIOBuf  *b = &m->base;
3305  IV code = 0;
3306  if (m->len)
3307   {
3308    if (b->buf)
3309     {
3310      code = munmap(m->mptr, m->len);
3311      b->buf  = NULL;
3312      m->len  = 0;
3313      m->mptr = NULL;
3314      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3315       code = -1;
3316     }
3317    b->ptr = b->end = b->buf;
3318    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3319   }
3320  return code;
3321 }
3322
3323 STDCHAR *
3324 PerlIOMmap_get_base(PerlIO *f)
3325 {
3326  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3327  PerlIOBuf  *b = &m->base;
3328  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3329   {
3330    /* Already have a readbuffer in progress */
3331    return b->buf;
3332   }
3333  if (b->buf)
3334   {
3335    /* We have a write buffer or flushed PerlIOBuf read buffer */
3336    m->bbuf = b->buf;  /* save it in case we need it again */
3337    b->buf  = NULL;    /* Clear to trigger below */
3338   }
3339  if (!b->buf)
3340   {
3341    PerlIOMmap_map(f);     /* Try and map it */
3342    if (!b->buf)
3343     {
3344      /* Map did not work - recover PerlIOBuf buffer if we have one */
3345      b->buf = m->bbuf;
3346     }
3347   }
3348  b->ptr  = b->end = b->buf;
3349  if (b->buf)
3350   return b->buf;
3351  return PerlIOBuf_get_base(f);
3352 }
3353
3354 SSize_t
3355 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3356 {
3357  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3358  PerlIOBuf  *b = &m->base;
3359  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3360   PerlIO_flush(f);
3361  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3362   {
3363    b->ptr -= count;
3364    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3365    return count;
3366   }
3367  if (m->len)
3368   {
3369    /* Loose the unwritable mapped buffer */
3370    PerlIO_flush(f);
3371    /* If flush took the "buffer" see if we have one from before */
3372    if (!b->buf && m->bbuf)
3373     b->buf = m->bbuf;
3374    if (!b->buf)
3375     {
3376      PerlIOBuf_get_base(f);
3377      m->bbuf = b->buf;
3378     }
3379   }
3380 return PerlIOBuf_unread(f,vbuf,count);
3381 }
3382
3383 SSize_t
3384 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3385 {
3386  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3387  PerlIOBuf  *b = &m->base;
3388  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3389   {
3390    /* No, or wrong sort of, buffer */
3391    if (m->len)
3392     {
3393      if (PerlIOMmap_unmap(f) != 0)
3394       return 0;
3395     }
3396    /* If unmap took the "buffer" see if we have one from before */
3397    if (!b->buf && m->bbuf)
3398     b->buf = m->bbuf;
3399    if (!b->buf)
3400     {
3401      PerlIOBuf_get_base(f);
3402      m->bbuf = b->buf;
3403     }
3404   }
3405  return PerlIOBuf_write(f,vbuf,count);
3406 }
3407
3408 IV
3409 PerlIOMmap_flush(PerlIO *f)
3410 {
3411  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3412  PerlIOBuf  *b = &m->base;
3413  IV code = PerlIOBuf_flush(f);
3414  /* Now we are "synced" at PerlIOBuf level */
3415  if (b->buf)
3416   {
3417    if (m->len)
3418     {
3419      /* Unmap the buffer */
3420      if (PerlIOMmap_unmap(f) != 0)
3421       code = -1;
3422     }
3423    else
3424     {
3425      /* We seem to have a PerlIOBuf buffer which was not mapped
3426       * remember it in case we need one later
3427       */
3428      m->bbuf = b->buf;
3429     }
3430   }
3431  return code;
3432 }
3433
3434 IV
3435 PerlIOMmap_fill(PerlIO *f)
3436 {
3437  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3438  IV code = PerlIO_flush(f);
3439  if (code == 0 && !b->buf)
3440   {
3441    code = PerlIOMmap_map(f);
3442   }
3443  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3444   {
3445    code = PerlIOBuf_fill(f);
3446   }
3447  return code;
3448 }
3449
3450 IV
3451 PerlIOMmap_close(PerlIO *f)
3452 {
3453  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3454  PerlIOBuf  *b = &m->base;
3455  IV code = PerlIO_flush(f);
3456  if (m->bbuf)
3457   {
3458    b->buf  = m->bbuf;
3459    m->bbuf = NULL;
3460    b->ptr  = b->end = b->buf;
3461   }
3462  if (PerlIOBuf_close(f) != 0)
3463   code = -1;
3464  return code;
3465 }
3466
3467
3468 PerlIO_funcs PerlIO_mmap = {
3469  "mmap",
3470  sizeof(PerlIOMmap),
3471  PERLIO_K_BUFFERED,
3472  PerlIOBuf_pushed,
3473  PerlIOBase_noop_ok,
3474  PerlIOBuf_open,
3475  NULL,
3476  PerlIOBase_fileno,
3477  PerlIOBuf_read,
3478  PerlIOMmap_unread,
3479  PerlIOMmap_write,
3480  PerlIOBuf_seek,
3481  PerlIOBuf_tell,
3482  PerlIOBuf_close,
3483  PerlIOMmap_flush,
3484  PerlIOMmap_fill,
3485  PerlIOBase_eof,
3486  PerlIOBase_error,
3487  PerlIOBase_clearerr,
3488  PerlIOBase_setlinebuf,
3489  PerlIOMmap_get_base,
3490  PerlIOBuf_bufsiz,
3491  PerlIOBuf_get_ptr,
3492  PerlIOBuf_get_cnt,
3493  PerlIOBuf_set_ptrcnt,
3494 };
3495
3496 #endif /* HAS_MMAP */
3497
3498 void
3499 PerlIO_init(void)
3500 {
3501  if (!_perlio)
3502   {
3503 #ifndef WIN32
3504    atexit(&PerlIO_cleanup);
3505 #endif
3506   }
3507 }
3508
3509 #undef PerlIO_stdin
3510 PerlIO *
3511 PerlIO_stdin(void)
3512 {
3513  if (!_perlio)
3514   {
3515    dTHX;
3516    PerlIO_stdstreams(aTHX);
3517   }
3518  return &_perlio[1];
3519 }
3520
3521 #undef PerlIO_stdout
3522 PerlIO *
3523 PerlIO_stdout(void)
3524 {
3525  if (!_perlio)
3526   {
3527    dTHX;
3528    PerlIO_stdstreams(aTHX);
3529   }
3530  return &_perlio[2];
3531 }
3532
3533 #undef PerlIO_stderr
3534 PerlIO *
3535 PerlIO_stderr(void)
3536 {
3537  if (!_perlio)
3538   {
3539    dTHX;
3540    PerlIO_stdstreams(aTHX);
3541   }
3542  return &_perlio[3];
3543 }
3544
3545 /*--------------------------------------------------------------------------------------*/
3546
3547 #undef PerlIO_getname
3548 char *
3549 PerlIO_getname(PerlIO *f, char *buf)
3550 {
3551  dTHX;
3552  Perl_croak(aTHX_ "Don't know how to get file name");
3553  return NULL;
3554 }
3555
3556
3557 /*--------------------------------------------------------------------------------------*/
3558 /* Functions which can be called on any kind of PerlIO implemented
3559    in terms of above
3560 */
3561
3562 #undef PerlIO_getc
3563 int
3564 PerlIO_getc(PerlIO *f)
3565 {
3566  STDCHAR buf[1];
3567  SSize_t count = PerlIO_read(f,buf,1);
3568  if (count == 1)
3569   {
3570    return (unsigned char) buf[0];
3571   }
3572  return EOF;
3573 }
3574
3575 #undef PerlIO_ungetc
3576 int
3577 PerlIO_ungetc(PerlIO *f, int ch)
3578 {
3579  if (ch != EOF)
3580   {
3581    STDCHAR buf = ch;
3582    if (PerlIO_unread(f,&buf,1) == 1)
3583     return ch;
3584   }
3585  return EOF;
3586 }
3587
3588 #undef PerlIO_putc
3589 int
3590 PerlIO_putc(PerlIO *f, int ch)
3591 {
3592  STDCHAR buf = ch;
3593  return PerlIO_write(f,&buf,1);
3594 }
3595
3596 #undef PerlIO_puts
3597 int
3598 PerlIO_puts(PerlIO *f, const char *s)
3599 {
3600  STRLEN len = strlen(s);
3601  return PerlIO_write(f,s,len);
3602 }
3603
3604 #undef PerlIO_rewind
3605 void
3606 PerlIO_rewind(PerlIO *f)
3607 {
3608  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3609  PerlIO_clearerr(f);
3610 }
3611
3612 #undef PerlIO_vprintf
3613 int
3614 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3615 {
3616  dTHX;
3617  SV *sv = newSVpvn("",0);
3618  char *s;
3619  STRLEN len;
3620  SSize_t wrote;
3621 #ifdef NEED_VA_COPY
3622  va_list apc;
3623  Perl_va_copy(ap, apc);
3624  sv_vcatpvf(sv, fmt, &apc);
3625 #else
3626  sv_vcatpvf(sv, fmt, &ap);
3627 #endif
3628  s = SvPV(sv,len);
3629  wrote = PerlIO_write(f,s,len);
3630  SvREFCNT_dec(sv);
3631  return wrote;
3632 }
3633
3634 #undef PerlIO_printf
3635 int
3636 PerlIO_printf(PerlIO *f,const char *fmt,...)
3637 {
3638  va_list ap;
3639  int result;
3640  va_start(ap,fmt);
3641  result = PerlIO_vprintf(f,fmt,ap);
3642  va_end(ap);
3643  return result;
3644 }
3645
3646 #undef PerlIO_stdoutf
3647 int
3648 PerlIO_stdoutf(const char *fmt,...)
3649 {
3650  va_list ap;
3651  int result;
3652  va_start(ap,fmt);
3653  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3654  va_end(ap);
3655  return result;
3656 }
3657
3658 #undef PerlIO_tmpfile
3659 PerlIO *
3660 PerlIO_tmpfile(void)
3661 {
3662  /* I have no idea how portable mkstemp() is ... */
3663 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3664  dTHX;
3665  PerlIO *f = NULL;
3666  FILE *stdio = PerlSIO_tmpfile();
3667  if (stdio)
3668   {
3669    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3670    s->stdio  = stdio;
3671   }
3672  return f;
3673 #else
3674  dTHX;
3675  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3676  int fd = mkstemp(SvPVX(sv));
3677  PerlIO *f = NULL;
3678  if (fd >= 0)
3679   {
3680    f = PerlIO_fdopen(fd,"w+");
3681    if (f)
3682     {
3683      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3684     }
3685    PerlLIO_unlink(SvPVX(sv));
3686    SvREFCNT_dec(sv);
3687   }
3688  return f;
3689 #endif
3690 }
3691
3692 #undef HAS_FSETPOS
3693 #undef HAS_FGETPOS
3694
3695 #endif /* USE_SFIO */
3696 #endif /* PERLIO_IS_STDIO */
3697
3698 /*======================================================================================*/
3699 /* Now some functions in terms of above which may be needed even if
3700    we are not in true PerlIO mode
3701  */
3702
3703 #ifndef HAS_FSETPOS
3704 #undef PerlIO_setpos
3705 int
3706 PerlIO_setpos(PerlIO *f, SV *pos)
3707 {
3708  dTHX;
3709  if (SvOK(pos))
3710   {
3711    STRLEN len;
3712    Off_t *posn = (Off_t *) SvPV(pos,len);
3713    if (f && len == sizeof(Off_t))
3714     return PerlIO_seek(f,*posn,SEEK_SET);
3715   }
3716  errno = EINVAL;
3717  return -1;
3718 }
3719 #else
3720 #undef PerlIO_setpos
3721 int
3722 PerlIO_setpos(PerlIO *f, SV *pos)
3723 {
3724  dTHX;
3725  if (SvOK(pos))
3726   {
3727    STRLEN len;
3728    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3729    if (f && len == sizeof(Fpos_t))
3730     {
3731 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3732      return fsetpos64(f, fpos);
3733 #else
3734      return fsetpos(f, fpos);
3735 #endif
3736     }
3737   }
3738  errno = EINVAL;
3739  return -1;
3740 }
3741 #endif
3742
3743 #ifndef HAS_FGETPOS
3744 #undef PerlIO_getpos
3745 int
3746 PerlIO_getpos(PerlIO *f, SV *pos)
3747 {
3748  dTHX;
3749  Off_t posn = PerlIO_tell(f);
3750  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3751  return (posn == (Off_t)-1) ? -1 : 0;
3752 }
3753 #else
3754 #undef PerlIO_getpos
3755 int
3756 PerlIO_getpos(PerlIO *f, SV *pos)
3757 {
3758  dTHX;
3759  Fpos_t fpos;
3760  int code;
3761 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3762  code = fgetpos64(f, &fpos);
3763 #else
3764  code = fgetpos(f, &fpos);
3765 #endif
3766  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3767  return code;
3768 }
3769 #endif
3770
3771 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3772
3773 int
3774 vprintf(char *pat, char *args)
3775 {
3776     _doprnt(pat, args, stdout);
3777     return 0;           /* wrong, but perl doesn't use the return value */
3778 }
3779
3780 int
3781 vfprintf(FILE *fd, char *pat, char *args)
3782 {
3783     _doprnt(pat, args, fd);
3784     return 0;           /* wrong, but perl doesn't use the return value */
3785 }
3786
3787 #endif
3788
3789 #ifndef PerlIO_vsprintf
3790 int
3791 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3792 {
3793  int val = vsprintf(s, fmt, ap);
3794  if (n >= 0)
3795   {
3796    if (strlen(s) >= (STRLEN)n)
3797     {
3798      dTHX;
3799      (void)PerlIO_puts(Perl_error_log,
3800                        "panic: sprintf overflow - memory corrupted!\n");
3801      my_exit(1);
3802     }
3803   }
3804  return val;
3805 }
3806 #endif
3807
3808 #ifndef PerlIO_sprintf
3809 int
3810 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3811 {
3812  va_list ap;
3813  int result;
3814  va_start(ap,fmt);
3815  result = PerlIO_vsprintf(s, n, fmt, ap);
3816  va_end(ap);
3817  return result;
3818 }
3819 #endif
3820
3821