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)
 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 && 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 NULL;
 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);
 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);
 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)));
 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)));
 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 AV *
 897 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
 898 {
 899  AV *def = PerlIO_default_layers(aTHX);
 900  int incdef = 1;
 901  if (!_perlio)
 902   PerlIO_stdstreams(aTHX);
 903  if (narg)
 904   {
 905    if (SvROK(*args) && !sv_isobject(*args))
 906     {
 907      if (SvTYPE(SvRV(*args)) < SVt_PVAV)
 908       {
 909        SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
 910        if (handler)
 911         {
 912          def    = newAV();
 913          av_push(def,SvREFCNT_inc(handler));
 914          av_push(def,&PL_sv_undef);
 915          incdef = 0;
 916         }
 917       }
 918      else
 919       {
 920        Perl_croak(aTHX_ "Unsupported reference arg to open()");
 921       }
 922     }
 923   }
 924  if (!layers)
 925   layers = PerlIO_context_layers(aTHX_ mode);
 926  if (layers && *layers)
 927   {
 928    AV *av;
 929    if (incdef)
 930     {
 931      IV n = av_len(def)+1;
 932      av = newAV();
 933      while (n-- > 0)
 934       {
 935        SV **svp = av_fetch(def,n,0);
 936        av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
 937       }
 938     }
 939    else
 940     {
 941      av = def;
 942     }
 943    PerlIO_parse_layers(aTHX_ av,layers);
 944    return av;
 945   }
 946  else
 947   {
 948    if (incdef)
 949     SvREFCNT_inc(def);
 950    return def;
 951   }
 952 }
 953
 954 PerlIO *
 955 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
 956 {
 957  if (!f && narg == 1 && *args == &PL_sv_undef)
 958   {
 959    if ((f = PerlIO_tmpfile()))
 960     {
 961      if (!layers)
 962       layers = PerlIO_context_layers(aTHX_ mode);
 963      if (layers && *layers)
 964       PerlIO_apply_layers(aTHX_ f,mode,layers);
 965     }
 966   }
 967  else
 968   {
 969    AV *layera;
 970    IV n;
 971    PerlIO_funcs *tab;
 972    if (f && *f)
 973     {
 974      /* This is "reopen" - it is not tested as perl does not use it yet */
 975      PerlIOl *l = *f;
 976      layera = newAV();
 977      while (l)
 978       {
 979        SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
 980        av_unshift(layera,2);
 981        av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
 982        av_store(layera,1,arg);
 983        l = *PerlIONext(&l);
 984       }
 985     }
 986    else
 987     {
 988      layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
 989     }
 990    n = av_len(layera)-1;
 991    while (n >= 0)
 992     {
 993      PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
 994      if (t && t->Open)
 995       {
 996        tab = t;
 997        break;
 998       }
 999      n -= 2;
1000     }
1001    if (tab)
1002     {
1003      PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1004                   tab->name,layers,mode,fd,imode,perm,f,narg,args);
1005      f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1006      if (f)
1007       {
1008        if (n+2 < av_len(layera)+1)
1009         {
1010          if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1011           {
1012            f = NULL;
1013           }
1014         }
1015       }
1016     }
1017    SvREFCNT_dec(layera);
1018   }
1019  return f;
1020 }
1021
1022
1023 #undef PerlIO_fdopen
1024 PerlIO *
1025 PerlIO_fdopen(int fd, const char *mode)
1026 {
1027  dTHX;
1028  return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1029 }
1030
1031 #undef PerlIO_open
1032 PerlIO *
1033 PerlIO_open(const char *path, const char *mode)
1034 {
1035  dTHX;
1036  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1037  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1038 }
1039
1040 #undef PerlIO_reopen
1041 PerlIO *
1042 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1043 {
1044  dTHX;
1045  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1046  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1047 }
1048
1049 #undef PerlIO_read
1050 SSize_t
1051 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1052 {
1053  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1054 }
1055
1056 #undef PerlIO_unread
1057 SSize_t
1058 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1059 {
1060  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1061 }
1062
1063 #undef PerlIO_write
1064 SSize_t
1065 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1066 {
1067  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1068 }
1069
1070 #undef PerlIO_seek
1071 int
1072 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1073 {
1074  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1075 }
1076
1077 #undef PerlIO_tell
1078 Off_t
1079 PerlIO_tell(PerlIO *f)
1080 {
1081  return (*PerlIOBase(f)->tab->Tell)(f);
1082 }
1083
1084 #undef PerlIO_flush
1085 int
1086 PerlIO_flush(PerlIO *f)
1087 {
1088  if (f)
1089   {
1090    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1091    if (tab && tab->Flush)
1092     {
1093      return (*tab->Flush)(f);
1094     }
1095    else
1096     {
1097      PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1098      errno = EINVAL;
1099      return -1;
1100     }
1101   }
1102  else
1103   {
1104    PerlIO **table = &_perlio;
1105    int code = 0;
1106    while ((f = *table))
1107     {
1108      int i;
1109      table = (PerlIO **)(f++);
1110      for (i=1; i < PERLIO_TABLE_SIZE; i++)
1111       {
1112        if (*f && PerlIO_flush(f) != 0)
1113         code = -1;
1114        f++;
1115       }
1116     }
1117    return code;
1118   }
1119 }
1120
1121 void
1122 PerlIOBase_flush_linebuf()
1123 {
1124  PerlIO **table = &_perlio;
1125  PerlIO *f;
1126  while ((f = *table))
1127   {
1128    int i;
1129    table = (PerlIO **)(f++);
1130    for (i=1; i < PERLIO_TABLE_SIZE; i++)
1131     {
1132      if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1133                 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1134       PerlIO_flush(f);
1135      f++;
1136     }
1137   }
1138 }
1139
1140 #undef PerlIO_fill
1141 int
1142 PerlIO_fill(PerlIO *f)
1143 {
1144  return (*PerlIOBase(f)->tab->Fill)(f);
1145 }
1146
1147 #undef PerlIO_isutf8
1148 int
1149 PerlIO_isutf8(PerlIO *f)
1150 {
1151  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1152 }
1153
1154 #undef PerlIO_eof
1155 int
1156 PerlIO_eof(PerlIO *f)
1157 {
1158  return (*PerlIOBase(f)->tab->Eof)(f);
1159 }
1160
1161 #undef PerlIO_error
1162 int
1163 PerlIO_error(PerlIO *f)
1164 {
1165  return (*PerlIOBase(f)->tab->Error)(f);
1166 }
1167
1168 #undef PerlIO_clearerr
1169 void
1170 PerlIO_clearerr(PerlIO *f)
1171 {
1172  if (f && *f)
1173   (*PerlIOBase(f)->tab->Clearerr)(f);
1174 }
1175
1176 #undef PerlIO_setlinebuf
1177 void
1178 PerlIO_setlinebuf(PerlIO *f)
1179 {
1180  (*PerlIOBase(f)->tab->Setlinebuf)(f);
1181 }
1182
1183 #undef PerlIO_has_base
1184 int
1185 PerlIO_has_base(PerlIO *f)
1186 {
1187  if (f && *f)
1188   {
1189    return (PerlIOBase(f)->tab->Get_base != NULL);
1190   }
1191  return 0;
1192 }
1193
1194 #undef PerlIO_fast_gets
1195 int
1196 PerlIO_fast_gets(PerlIO *f)
1197 {
1198  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1199   {
1200    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1201    return (tab->Set_ptrcnt != NULL);
1202   }
1203  return 0;
1204 }
1205
1206 #undef PerlIO_has_cntptr
1207 int
1208 PerlIO_has_cntptr(PerlIO *f)
1209 {
1210  if (f && *f)
1211   {
1212    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1213    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1214   }
1215  return 0;
1216 }
1217
1218 #undef PerlIO_canset_cnt
1219 int
1220 PerlIO_canset_cnt(PerlIO *f)
1221 {
1222  if (f && *f)
1223   {
1224    PerlIOl *l = PerlIOBase(f);
1225    return (l->tab->Set_ptrcnt != NULL);
1226   }
1227  return 0;
1228 }
1229
1230 #undef PerlIO_get_base
1231 STDCHAR *
1232 PerlIO_get_base(PerlIO *f)
1233 {
1234  return (*PerlIOBase(f)->tab->Get_base)(f);
1235 }
1236
1237 #undef PerlIO_get_bufsiz
1238 int
1239 PerlIO_get_bufsiz(PerlIO *f)
1240 {
1241  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1242 }
1243
1244 #undef PerlIO_get_ptr
1245 STDCHAR *
1246 PerlIO_get_ptr(PerlIO *f)
1247 {
1248  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1249  if (tab->Get_ptr == NULL)
1250   return NULL;
1251  return (*tab->Get_ptr)(f);
1252 }
1253
1254 #undef PerlIO_get_cnt
1255 int
1256 PerlIO_get_cnt(PerlIO *f)
1257 {
1258  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1259  if (tab->Get_cnt == NULL)
1260   return 0;
1261  return (*tab->Get_cnt)(f);
1262 }
1263
1264 #undef PerlIO_set_cnt
1265 void
1266 PerlIO_set_cnt(PerlIO *f,int cnt)
1267 {
1268  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1269 }
1270
1271 #undef PerlIO_set_ptrcnt
1272 void
1273 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1274 {
1275  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1276  if (tab->Set_ptrcnt == NULL)
1277   {
1278    dTHX;
1279    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1280   }
1281  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1282 }
1283
1284 /*--------------------------------------------------------------------------------------*/
1285 /* utf8 and raw dummy layers */
1286
1287 IV
1288 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1289 {
1290  if (PerlIONext(f))
1291   {
1292    dTHX;
1293    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1294    PerlIO_pop(aTHX_ f);
1295    if (tab->kind & PERLIO_K_UTF8)
1296     PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1297    else
1298     PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1299    return 0;
1300   }
1301  return -1;
1302 }
1303
1304 PerlIO_funcs PerlIO_utf8 = {
1305  "utf8",
1306  sizeof(PerlIOl),
1307  PERLIO_K_DUMMY|PERLIO_F_UTF8,
1308  PerlIOUtf8_pushed,
1309  NULL,
1310  NULL,
1311  NULL,
1312  NULL,
1313  NULL,
1314  NULL,
1315  NULL,
1316  NULL,
1317  NULL,
1318  NULL,
1319  NULL, /* flush */
1320  NULL, /* fill */
1321  NULL,
1322  NULL,
1323  NULL,
1324  NULL,
1325  NULL, /* get_base */
1326  NULL, /* get_bufsiz */
1327  NULL, /* get_ptr */
1328  NULL, /* get_cnt */
1329  NULL, /* set_ptrcnt */
1330 };
1331
1332 PerlIO_funcs PerlIO_byte = {
1333  "bytes",
1334  sizeof(PerlIOl),
1335  PERLIO_K_DUMMY,
1336  PerlIOUtf8_pushed,
1337  NULL,
1338  NULL,
1339  NULL,
1340  NULL,
1341  NULL,
1342  NULL,
1343  NULL,
1344  NULL,
1345  NULL,
1346  NULL,
1347  NULL, /* flush */
1348  NULL, /* fill */
1349  NULL,
1350  NULL,
1351  NULL,
1352  NULL,
1353  NULL, /* get_base */
1354  NULL, /* get_bufsiz */
1355  NULL, /* get_ptr */
1356  NULL, /* get_cnt */
1357  NULL, /* set_ptrcnt */
1358 };
1359
1360 PerlIO *
1361 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)
1362 {
1363  PerlIO_funcs *tab = PerlIO_default_btm();
1364  return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1365 }
1366
1367 PerlIO_funcs PerlIO_raw = {
1368  "raw",
1369  sizeof(PerlIOl),
1370  PERLIO_K_DUMMY,
1371  PerlIORaw_pushed,
1372  PerlIOBase_popped,
1373  PerlIORaw_open,
1374  NULL,
1375  NULL,
1376  NULL,
1377  NULL,
1378  NULL,
1379  NULL,
1380  NULL,
1381  NULL,
1382  NULL, /* flush */
1383  NULL, /* fill */
1384  NULL,
1385  NULL,
1386  NULL,
1387  NULL,
1388  NULL, /* get_base */
1389  NULL, /* get_bufsiz */
1390  NULL, /* get_ptr */
1391  NULL, /* get_cnt */
1392  NULL, /* set_ptrcnt */
1393 };
1394 /*--------------------------------------------------------------------------------------*/
1395 /*--------------------------------------------------------------------------------------*/
1396 /* "Methods" of the "base class" */
1397
1398 IV
1399 PerlIOBase_fileno(PerlIO *f)
1400 {
1401  return PerlIO_fileno(PerlIONext(f));
1402 }
1403
1404 char *
1405 PerlIO_modestr(PerlIO *f,char *buf)
1406 {
1407  char *s = buf;
1408  IV flags = PerlIOBase(f)->flags;
1409  if (flags & PERLIO_F_APPEND)
1410   {
1411    *s++ = 'a';
1412    if (flags & PERLIO_F_CANREAD)
1413     {
1414      *s++ = '+';
1415     }
1416   }
1417  else if (flags & PERLIO_F_CANREAD)
1418   {
1419    *s++ = 'r';
1420    if (flags & PERLIO_F_CANWRITE)
1421     *s++ = '+';
1422   }
1423  else if (flags & PERLIO_F_CANWRITE)
1424   {
1425    *s++ = 'w';
1426    if (flags & PERLIO_F_CANREAD)
1427     {
1428      *s++ = '+';
1429     }
1430   }
1431 #if O_TEXT != O_BINARY
1432  if (!(flags & PERLIO_F_CRLF))
1433   *s++ = 'b';
1434 #endif
1435  *s = '\0';
1436  return buf;
1437 }
1438
1439 IV
1440 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1441 {
1442  PerlIOl *l = PerlIOBase(f);
1443  const char *omode = mode;
1444  char temp[8];
1445  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1446  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1447                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1448  if (tab->Set_ptrcnt != NULL)
1449   l->flags |= PERLIO_F_FASTGETS;
1450  if (mode)
1451   {
1452    switch (*mode++)
1453     {
1454      case 'r':
1455       l->flags |= PERLIO_F_CANREAD;
1456       break;
1457      case 'a':
1458       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1459       break;
1460      case 'w':
1461       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1462       break;
1463      default:
1464       errno = EINVAL;
1465       return -1;
1466     }
1467    while (*mode)
1468     {
1469      switch (*mode++)
1470       {
1471        case '+':
1472         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1473         break;
1474        case 'b':
1475         l->flags &= ~PERLIO_F_CRLF;
1476         break;
1477        case 't':
1478         l->flags |= PERLIO_F_CRLF;
1479         break;
1480       default:
1481        errno = EINVAL;
1482        return -1;
1483       }
1484     }
1485   }
1486  else
1487   {
1488    if (l->next)
1489     {
1490      l->flags |= l->next->flags &
1491                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1492     }
1493   }
1494 #if 0
1495  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1496               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1497               l->flags,PerlIO_modestr(f,temp));
1498 #endif
1499  return 0;
1500 }
1501
1502 IV
1503 PerlIOBase_popped(PerlIO *f)
1504 {
1505  return 0;
1506 }
1507
1508 SSize_t
1509 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1510 {
1511  dTHX;
1512  Off_t old = PerlIO_tell(f);
1513  SSize_t done;
1514  PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1515  done = PerlIOBuf_unread(f,vbuf,count);
1516  PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1517  return done;
1518 }
1519
1520 SSize_t
1521 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1522 {
1523  STDCHAR *buf  = (STDCHAR *) vbuf;
1524  if (f)
1525   {
1526    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1527     return 0;
1528    while (count > 0)
1529     {
1530      SSize_t avail = PerlIO_get_cnt(f);
1531      SSize_t take  = (count < avail) ? count : avail;
1532      if (take > 0)
1533       {
1534        STDCHAR *ptr = PerlIO_get_ptr(f);
1535        Copy(ptr,buf,take,STDCHAR);
1536        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1537        count   -= take;
1538        buf     += take;
1539       }
1540      if (count > 0  && avail <= 0)
1541       {
1542        if (PerlIO_fill(f) != 0)
1543         break;
1544       }
1545     }
1546    return (buf - (STDCHAR *) vbuf);
1547   }
1548  return 0;
1549 }
1550
1551 IV
1552 PerlIOBase_noop_ok(PerlIO *f)
1553 {
1554  return 0;
1555 }
1556
1557 IV
1558 PerlIOBase_noop_fail(PerlIO *f)
1559 {
1560  return -1;
1561 }
1562
1563 IV
1564 PerlIOBase_close(PerlIO *f)
1565 {
1566  IV code = 0;
1567  PerlIO *n = PerlIONext(f);
1568  if (PerlIO_flush(f) != 0)
1569   code = -1;
1570  if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1571   code = -1;
1572  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1573  return code;
1574 }
1575
1576 IV
1577 PerlIOBase_eof(PerlIO *f)
1578 {
1579  if (f && *f)
1580   {
1581    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1582   }
1583  return 1;
1584 }
1585
1586 IV
1587 PerlIOBase_error(PerlIO *f)
1588 {
1589  if (f && *f)
1590   {
1591    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1592   }
1593  return 1;
1594 }
1595
1596 void
1597 PerlIOBase_clearerr(PerlIO *f)
1598 {
1599  if (f && *f)
1600   {
1601    PerlIO *n = PerlIONext(f);
1602    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1603    if (n)
1604     PerlIO_clearerr(n);
1605   }
1606 }
1607
1608 void
1609 PerlIOBase_setlinebuf(PerlIO *f)
1610 {
1611  if (f)
1612   {
1613    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1614   }
1615 }
1616
1617 /*--------------------------------------------------------------------------------------*/
1618 /* Bottom-most level for UNIX-like case */
1619
1620 typedef struct
1621 {
1622  struct _PerlIO base;       /* The generic part */
1623  int            fd;         /* UNIX like file descriptor */
1624  int            oflags;     /* open/fcntl flags */
1625 } PerlIOUnix;
1626
1627 int
1628 PerlIOUnix_oflags(const char *mode)
1629 {
1630  int oflags = -1;
1631  switch(*mode)
1632   {
1633    case 'r':
1634     oflags = O_RDONLY;
1635     if (*++mode == '+')
1636      {
1637       oflags = O_RDWR;
1638       mode++;
1639      }
1640     break;
1641
1642    case 'w':
1643     oflags = O_CREAT|O_TRUNC;
1644     if (*++mode == '+')
1645      {
1646       oflags |= O_RDWR;
1647       mode++;
1648      }
1649     else
1650      oflags |= O_WRONLY;
1651     break;
1652
1653    case 'a':
1654     oflags = O_CREAT|O_APPEND;
1655     if (*++mode == '+')
1656      {
1657       oflags |= O_RDWR;
1658       mode++;
1659      }
1660     else
1661      oflags |= O_WRONLY;
1662     break;
1663   }
1664  if (*mode == 'b')
1665   {
1666    oflags |=  O_BINARY;
1667    oflags &= ~O_TEXT;
1668    mode++;
1669   }
1670  else if (*mode == 't')
1671   {
1672    oflags |=  O_TEXT;
1673    oflags &= ~O_BINARY;
1674    mode++;
1675   }
1676  /* Always open in binary mode */
1677  oflags |= O_BINARY;
1678  if (*mode || oflags == -1)
1679   {
1680    errno = EINVAL;
1681    oflags = -1;
1682   }
1683  return oflags;
1684 }
1685
1686 IV
1687 PerlIOUnix_fileno(PerlIO *f)
1688 {
1689  return PerlIOSelf(f,PerlIOUnix)->fd;
1690 }
1691
1692 IV
1693 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1694 {
1695  IV code = PerlIOBase_pushed(f,mode,arg);
1696  if (*PerlIONext(f))
1697   {
1698    PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1699    s->fd     = PerlIO_fileno(PerlIONext(f));
1700    s->oflags = PerlIOUnix_oflags(mode);
1701   }
1702  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1703  return code;
1704 }
1705
1706 PerlIO *
1707 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)
1708 {
1709  if (f)
1710   {
1711    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1712     (*PerlIOBase(f)->tab->Close)(f);
1713   }
1714  if (narg > 0)
1715   {
1716    char *path = SvPV_nolen(*args);
1717    if (*mode == '#')
1718     mode++;
1719    else
1720     {
1721      imode = PerlIOUnix_oflags(mode);
1722      perm  = 0666;
1723     }
1724    if (imode != -1)
1725     {
1726      fd = PerlLIO_open3(path,imode,perm);
1727     }
1728   }
1729  if (fd >= 0)
1730   {
1731    PerlIOUnix *s;
1732    if (*mode == 'I')
1733     mode++;
1734    if (!f)
1735     {
1736      f = PerlIO_allocate(aTHX);
1737      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1738     }
1739    else
1740     s = PerlIOSelf(f,PerlIOUnix);
1741    s->fd     = fd;
1742    s->oflags = imode;
1743    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1744    return f;
1745   }
1746  else
1747   {
1748    if (f)
1749     {
1750      /* FIXME: pop layers ??? */
1751     }
1752    return NULL;
1753   }
1754 }
1755
1756 SSize_t
1757 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1758 {
1759  dTHX;
1760  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1761  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1762   return 0;
1763  while (1)
1764   {
1765    SSize_t len = PerlLIO_read(fd,vbuf,count);
1766    if (len >= 0 || errno != EINTR)
1767     {
1768      if (len < 0)
1769       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1770      else if (len == 0 && count != 0)
1771       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1772      return len;
1773     }
1774    PERL_ASYNC_CHECK();
1775   }
1776 }
1777
1778 SSize_t
1779 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1780 {
1781  dTHX;
1782  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1783  while (1)
1784   {
1785    SSize_t len = PerlLIO_write(fd,vbuf,count);
1786    if (len >= 0 || errno != EINTR)
1787     {
1788      if (len < 0)
1789       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1790      return len;
1791     }
1792    PERL_ASYNC_CHECK();
1793   }
1794 }
1795
1796 IV
1797 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1798 {
1799  dTHX;
1800  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1801  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1802  return (new == (Off_t) -1) ? -1 : 0;
1803 }
1804
1805 Off_t
1806 PerlIOUnix_tell(PerlIO *f)
1807 {
1808  dTHX;
1809  Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1810  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1811 }
1812
1813 IV
1814 PerlIOUnix_close(PerlIO *f)
1815 {
1816  dTHX;
1817  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1818  int code = 0;
1819  while (PerlLIO_close(fd) != 0)
1820   {
1821    if (errno != EINTR)
1822     {
1823      code = -1;
1824      break;
1825     }
1826    PERL_ASYNC_CHECK();
1827   }
1828  if (code == 0)
1829   {
1830    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1831   }
1832  return code;
1833 }
1834
1835 PerlIO_funcs PerlIO_unix = {
1836  "unix",
1837  sizeof(PerlIOUnix),
1838  PERLIO_K_RAW,
1839  PerlIOUnix_pushed,
1840  PerlIOBase_noop_ok,
1841  PerlIOUnix_open,
1842  NULL,
1843  PerlIOUnix_fileno,
1844  PerlIOUnix_read,
1845  PerlIOBase_unread,
1846  PerlIOUnix_write,
1847  PerlIOUnix_seek,
1848  PerlIOUnix_tell,
1849  PerlIOUnix_close,
1850  PerlIOBase_noop_ok,   /* flush */
1851  PerlIOBase_noop_fail, /* fill */
1852  PerlIOBase_eof,
1853  PerlIOBase_error,
1854  PerlIOBase_clearerr,
1855  PerlIOBase_setlinebuf,
1856  NULL, /* get_base */
1857  NULL, /* get_bufsiz */
1858  NULL, /* get_ptr */
1859  NULL, /* get_cnt */
1860  NULL, /* set_ptrcnt */
1861 };
1862
1863 /*--------------------------------------------------------------------------------------*/
1864 /* stdio as a layer */
1865
1866 typedef struct
1867 {
1868  struct _PerlIO base;
1869  FILE *         stdio;      /* The stream */
1870 } PerlIOStdio;
1871
1872 IV
1873 PerlIOStdio_fileno(PerlIO *f)
1874 {
1875  dTHX;
1876  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1877 }
1878
1879 char *
1880 PerlIOStdio_mode(const char *mode,char *tmode)
1881 {
1882  char *ret = tmode;
1883  while (*mode)
1884   {
1885    *tmode++ = *mode++;
1886   }
1887  if (O_BINARY != O_TEXT)
1888   {
1889    *tmode++ = 'b';
1890   }
1891  *tmode = '\0';
1892  return ret;
1893 }
1894
1895 /* This isn't used yet ... */
1896 IV
1897 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1898 {
1899  dTHX;
1900  if (*PerlIONext(f))
1901   {
1902    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1903    char tmode[8];
1904    FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1905    if (stdio)
1906     s->stdio = stdio;
1907    else
1908     return -1;
1909   }
1910  return PerlIOBase_pushed(f,mode,arg);
1911 }
1912
1913 #undef PerlIO_importFILE
1914 PerlIO *
1915 PerlIO_importFILE(FILE *stdio, int fl)
1916 {
1917  dTHX;
1918  PerlIO *f = NULL;
1919  if (stdio)
1920   {
1921    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1922    s->stdio  = stdio;
1923   }
1924  return f;
1925 }
1926
1927 PerlIO *
1928 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)
1929 {
1930  char tmode[8];
1931  if (f)
1932   {
1933    char *path = SvPV_nolen(*args);
1934    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1935    FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1936    if (!s->stdio)
1937     return NULL;
1938    s->stdio = stdio;
1939    return f;
1940   }
1941  else
1942   {
1943    if (narg > 0)
1944     {
1945      char *path = SvPV_nolen(*args);
1946      if (*mode == '#')
1947       {
1948        mode++;
1949        fd = PerlLIO_open3(path,imode,perm);
1950       }
1951      else
1952       {
1953        FILE *stdio = PerlSIO_fopen(path,mode);
1954        if (stdio)
1955         {
1956          PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1957                                      (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
1958                                      PerlIOStdio);
1959          s->stdio  = stdio;
1960         }
1961        return f;
1962       }
1963     }
1964    if (fd >= 0)
1965     {
1966      FILE *stdio = NULL;
1967      int init = 0;
1968      if (*mode == 'I')
1969       {
1970        init = 1;
1971        mode++;
1972       }
1973      if (init)
1974       {
1975        switch(fd)
1976         {
1977          case 0:
1978           stdio = PerlSIO_stdin;
1979           break;
1980          case 1:
1981           stdio = PerlSIO_stdout;
1982           break;
1983          case 2:
1984           stdio = PerlSIO_stderr;
1985           break;
1986         }
1987       }
1988      else
1989       {
1990        stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1991       }
1992      if (stdio)
1993       {
1994        PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
1995        s->stdio  = stdio;
1996        return f;
1997       }
1998     }
1999   }
2000  return NULL;
2001 }
2002
2003 SSize_t
2004 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2005 {
2006  dTHX;
2007  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2008  SSize_t got = 0;
2009  if (count == 1)
2010   {
2011    STDCHAR *buf = (STDCHAR *) vbuf;
2012    /* Perl is expecting PerlIO_getc() to fill the buffer
2013     * Linux's stdio does not do that for fread()
2014     */
2015    int ch = PerlSIO_fgetc(s);
2016    if (ch != EOF)
2017     {
2018      *buf = ch;
2019      got = 1;
2020     }
2021   }
2022  else
2023   got = PerlSIO_fread(vbuf,1,count,s);
2024  return got;
2025 }
2026
2027 SSize_t
2028 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2029 {
2030  dTHX;
2031  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2032  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2033  SSize_t unread = 0;
2034  while (count > 0)
2035   {
2036    int ch = *buf-- & 0xff;
2037    if (PerlSIO_ungetc(ch,s) != ch)
2038     break;
2039    unread++;
2040    count--;
2041   }
2042  return unread;
2043 }
2044
2045 SSize_t
2046 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2047 {
2048  dTHX;
2049  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2050 }
2051
2052 IV
2053 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2054 {
2055  dTHX;
2056  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2057  return PerlSIO_fseek(stdio,offset,whence);
2058 }
2059
2060 Off_t
2061 PerlIOStdio_tell(PerlIO *f)
2062 {
2063  dTHX;
2064  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2065  return PerlSIO_ftell(stdio);
2066 }
2067
2068 IV
2069 PerlIOStdio_close(PerlIO *f)
2070 {
2071  dTHX;
2072 #ifdef HAS_SOCKS5_INIT
2073  int optval, optlen = sizeof(int);
2074 #endif
2075  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2076  return(
2077 #ifdef HAS_SOCKS5_INIT
2078    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2079        PerlSIO_fclose(stdio) :
2080        close(PerlIO_fileno(f))
2081 #else
2082    PerlSIO_fclose(stdio)
2083 #endif
2084      );
2085
2086 }
2087
2088 IV
2089 PerlIOStdio_flush(PerlIO *f)
2090 {
2091  dTHX;
2092  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2093  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2094   {
2095    return PerlSIO_fflush(stdio);
2096   }
2097  else
2098   {
2099 #if 0
2100    /* FIXME: This discards ungetc() and pre-read stuff which is
2101       not right if this is just a "sync" from a layer above
2102       Suspect right design is to do _this_ but not have layer above
2103       flush this layer read-to-read
2104     */
2105    /* Not writeable - sync by attempting a seek */
2106    int err = errno;
2107    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2108     errno = err;
2109 #endif
2110   }
2111  return 0;
2112 }
2113
2114 IV
2115 PerlIOStdio_fill(PerlIO *f)
2116 {
2117  dTHX;
2118  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2119  int c;
2120  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2121  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2122   {
2123    if (PerlSIO_fflush(stdio) != 0)
2124     return EOF;
2125   }
2126  c = PerlSIO_fgetc(stdio);
2127  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2128   return EOF;
2129  return 0;
2130 }
2131
2132 IV
2133 PerlIOStdio_eof(PerlIO *f)
2134 {
2135  dTHX;
2136  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2137 }
2138
2139 IV
2140 PerlIOStdio_error(PerlIO *f)
2141 {
2142  dTHX;
2143  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2144 }
2145
2146 void
2147 PerlIOStdio_clearerr(PerlIO *f)
2148 {
2149  dTHX;
2150  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2151 }
2152
2153 void
2154 PerlIOStdio_setlinebuf(PerlIO *f)
2155 {
2156  dTHX;
2157 #ifdef HAS_SETLINEBUF
2158  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2159 #else
2160  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2161 #endif
2162 }
2163
2164 #ifdef FILE_base
2165 STDCHAR *
2166 PerlIOStdio_get_base(PerlIO *f)
2167 {
2168  dTHX;
2169  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2170  return PerlSIO_get_base(stdio);
2171 }
2172
2173 Size_t
2174 PerlIOStdio_get_bufsiz(PerlIO *f)
2175 {
2176  dTHX;
2177  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2178  return PerlSIO_get_bufsiz(stdio);
2179 }
2180 #endif
2181
2182 #ifdef USE_STDIO_PTR
2183 STDCHAR *
2184 PerlIOStdio_get_ptr(PerlIO *f)
2185 {
2186  dTHX;
2187  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2188  return PerlSIO_get_ptr(stdio);
2189 }
2190
2191 SSize_t
2192 PerlIOStdio_get_cnt(PerlIO *f)
2193 {
2194  dTHX;
2195  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2196  return PerlSIO_get_cnt(stdio);
2197 }
2198
2199 void
2200 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2201 {
2202  dTHX;
2203  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2204  if (ptr != NULL)
2205   {
2206 #ifdef STDIO_PTR_LVALUE
2207    PerlSIO_set_ptr(stdio,ptr);
2208 #ifdef STDIO_PTR_LVAL_SETS_CNT
2209    if (PerlSIO_get_cnt(stdio) != (cnt))
2210     {
2211      dTHX;
2212      assert(PerlSIO_get_cnt(stdio) == (cnt));
2213     }
2214 #endif
2215 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2216    /* Setting ptr _does_ change cnt - we are done */
2217    return;
2218 #endif
2219 #else  /* STDIO_PTR_LVALUE */
2220    PerlProc_abort();
2221 #endif /* STDIO_PTR_LVALUE */
2222   }
2223 /* Now (or only) set cnt */
2224 #ifdef STDIO_CNT_LVALUE
2225  PerlSIO_set_cnt(stdio,cnt);
2226 #else  /* STDIO_CNT_LVALUE */
2227 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2228  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2229 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2230  PerlProc_abort();
2231 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2232 #endif /* STDIO_CNT_LVALUE */
2233 }
2234
2235 #endif
2236
2237 PerlIO_funcs PerlIO_stdio = {
2238  "stdio",
2239  sizeof(PerlIOStdio),
2240  PERLIO_K_BUFFERED,
2241  PerlIOBase_pushed,
2242  PerlIOBase_noop_ok,
2243  PerlIOStdio_open,
2244  NULL,
2245  PerlIOStdio_fileno,
2246  PerlIOStdio_read,
2247  PerlIOStdio_unread,
2248  PerlIOStdio_write,
2249  PerlIOStdio_seek,
2250  PerlIOStdio_tell,
2251  PerlIOStdio_close,
2252  PerlIOStdio_flush,
2253  PerlIOStdio_fill,
2254  PerlIOStdio_eof,
2255  PerlIOStdio_error,
2256  PerlIOStdio_clearerr,
2257  PerlIOStdio_setlinebuf,
2258 #ifdef FILE_base
2259  PerlIOStdio_get_base,
2260  PerlIOStdio_get_bufsiz,
2261 #else
2262  NULL,
2263  NULL,
2264 #endif
2265 #ifdef USE_STDIO_PTR
2266  PerlIOStdio_get_ptr,
2267  PerlIOStdio_get_cnt,
2268 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2269  PerlIOStdio_set_ptrcnt
2270 #else  /* STDIO_PTR_LVALUE */
2271  NULL
2272 #endif /* STDIO_PTR_LVALUE */
2273 #else  /* USE_STDIO_PTR */
2274  NULL,
2275  NULL,
2276  NULL
2277 #endif /* USE_STDIO_PTR */
2278 };
2279
2280 #undef PerlIO_exportFILE
2281 FILE *
2282 PerlIO_exportFILE(PerlIO *f, int fl)
2283 {
2284  FILE *stdio;
2285  PerlIO_flush(f);
2286  stdio = fdopen(PerlIO_fileno(f),"r+");
2287  if (stdio)
2288   {
2289    dTHX;
2290    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2291    s->stdio  = stdio;
2292   }
2293  return stdio;
2294 }
2295
2296 #undef PerlIO_findFILE
2297 FILE *
2298 PerlIO_findFILE(PerlIO *f)
2299 {
2300  PerlIOl *l = *f;
2301  while (l)
2302   {
2303    if (l->tab == &PerlIO_stdio)
2304     {
2305      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2306      return s->stdio;
2307     }
2308    l = *PerlIONext(&l);
2309   }
2310  return PerlIO_exportFILE(f,0);
2311 }
2312
2313 #undef PerlIO_releaseFILE
2314 void
2315 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2316 {
2317 }
2318
2319 /*--------------------------------------------------------------------------------------*/
2320 /* perlio buffer layer */
2321
2322 IV
2323 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2324 {
2325  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2326  int fd  = PerlIO_fileno(f);
2327  Off_t posn;
2328  dTHX;
2329  if (fd >= 0 && PerlLIO_isatty(fd))
2330   {
2331    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2332   }
2333  posn = PerlIO_tell(PerlIONext(f));
2334  if (posn != (Off_t) -1)
2335   {
2336    b->posn = posn;
2337   }
2338  return PerlIOBase_pushed(f,mode,arg);
2339 }
2340
2341 PerlIO *
2342 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)
2343 {
2344  if (f)
2345   {
2346    PerlIO *next = PerlIONext(f);
2347    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2348    next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2349    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2350     {
2351      return NULL;
2352     }
2353   }
2354  else
2355   {
2356    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2357    int init = 0;
2358    if (*mode == 'I')
2359     {
2360      init = 1;
2361      mode++;
2362     }
2363    f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2364    if (f)
2365     {
2366      PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2367      fd = PerlIO_fileno(f);
2368 #if O_BINARY != O_TEXT
2369      /* do something about failing setmode()? --jhi */
2370      PerlLIO_setmode(fd , O_BINARY);
2371 #endif
2372      if (init && fd == 2)
2373       {
2374        /* Initial stderr is unbuffered */
2375        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2376       }
2377     }
2378   }
2379  return f;
2380 }
2381
2382 /* This "flush" is akin to sfio's sync in that it handles files in either
2383    read or write state
2384 */
2385 IV
2386 PerlIOBuf_flush(PerlIO *f)
2387 {
2388  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2389  int code = 0;
2390  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2391   {
2392    /* write() the buffer */
2393    STDCHAR *buf = b->buf;
2394    STDCHAR *p = buf;
2395    PerlIO *n = PerlIONext(f);
2396    while (p < b->ptr)
2397     {
2398      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2399      if (count > 0)
2400       {
2401        p += count;
2402       }
2403      else if (count < 0 || PerlIO_error(n))
2404       {
2405        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2406        code = -1;
2407        break;
2408       }
2409     }
2410    b->posn += (p - buf);
2411   }
2412  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2413   {
2414    STDCHAR *buf = PerlIO_get_base(f);
2415    /* Note position change */
2416    b->posn += (b->ptr - buf);
2417    if (b->ptr < b->end)
2418     {
2419      /* We did not consume all of it */
2420      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2421       {
2422        b->posn = PerlIO_tell(PerlIONext(f));
2423       }
2424     }
2425   }
2426  b->ptr = b->end = b->buf;
2427  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2428  /* FIXME: Is this right for read case ? */
2429  if (PerlIO_flush(PerlIONext(f)) != 0)
2430   code = -1;
2431  return code;
2432 }
2433
2434 IV
2435 PerlIOBuf_fill(PerlIO *f)
2436 {
2437  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2438  PerlIO *n = PerlIONext(f);
2439  SSize_t avail;
2440  /* FIXME: doing the down-stream flush is a bad idea if it causes
2441     pre-read data in stdio buffer to be discarded
2442     but this is too simplistic - as it skips _our_ hosekeeping
2443     and breaks tell tests.
2444  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2445   {
2446   }
2447   */
2448  if (PerlIO_flush(f) != 0)
2449   return -1;
2450  if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2451   PerlIOBase_flush_linebuf();
2452
2453  if (!b->buf)
2454   PerlIO_get_base(f); /* allocate via vtable */
2455
2456  b->ptr = b->end = b->buf;
2457  if (PerlIO_fast_gets(n))
2458   {
2459    /* Layer below is also buffered
2460     * We do _NOT_ want to call its ->Read() because that will loop
2461     * till it gets what we asked for which may hang on a pipe etc.
2462     * Instead take anything it has to hand, or ask it to fill _once_.
2463     */
2464    avail  = PerlIO_get_cnt(n);
2465    if (avail <= 0)
2466     {
2467      avail = PerlIO_fill(n);
2468      if (avail == 0)
2469       avail = PerlIO_get_cnt(n);
2470      else
2471       {
2472        if (!PerlIO_error(n) && PerlIO_eof(n))
2473         avail = 0;
2474       }
2475     }
2476    if (avail > 0)
2477     {
2478      STDCHAR *ptr = PerlIO_get_ptr(n);
2479      SSize_t cnt  = avail;
2480      if (avail > b->bufsiz)
2481       avail = b->bufsiz;
2482      Copy(ptr,b->buf,avail,STDCHAR);
2483      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2484     }
2485   }
2486  else
2487   {
2488    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2489   }
2490  if (avail <= 0)
2491   {
2492    if (avail == 0)
2493     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2494    else
2495     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2496    return -1;
2497   }
2498  b->end      = b->buf+avail;
2499  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2500  return 0;
2501 }
2502
2503 SSize_t
2504 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2505 {
2506  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2507  if (f)
2508   {
2509    if (!b->ptr)
2510     PerlIO_get_base(f);
2511    return PerlIOBase_read(f,vbuf,count);
2512   }
2513  return 0;
2514 }
2515
2516 SSize_t
2517 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2518 {
2519  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2520  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2521  SSize_t unread = 0;
2522  SSize_t avail;
2523  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2524   PerlIO_flush(f);
2525  if (!b->buf)
2526   PerlIO_get_base(f);
2527  if (b->buf)
2528   {
2529    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2530     {
2531      avail = (b->ptr - b->buf);
2532     }
2533    else
2534     {
2535      avail = b->bufsiz;
2536      b->end = b->buf + avail;
2537      b->ptr = b->end;
2538      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2539      b->posn -= b->bufsiz;
2540     }
2541    if (avail > (SSize_t) count)
2542     avail = count;
2543    if (avail > 0)
2544     {
2545      b->ptr -= avail;
2546      buf    -= avail;
2547      if (buf != b->ptr)
2548       {
2549        Copy(buf,b->ptr,avail,STDCHAR);
2550       }
2551      count  -= avail;
2552      unread += avail;
2553      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2554     }
2555   }
2556  return unread;
2557 }
2558
2559 SSize_t
2560 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2561 {
2562  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2563  const STDCHAR *buf = (const STDCHAR *) vbuf;
2564  Size_t written = 0;
2565  if (!b->buf)
2566   PerlIO_get_base(f);
2567  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2568   return 0;
2569  while (count > 0)
2570   {
2571    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2572    if ((SSize_t) count < avail)
2573     avail = count;
2574    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2575    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2576     {
2577      while (avail > 0)
2578       {
2579        int ch = *buf++;
2580        *(b->ptr)++ = ch;
2581        count--;
2582        avail--;
2583        written++;
2584        if (ch == '\n')
2585         {
2586          PerlIO_flush(f);
2587          break;
2588         }
2589       }
2590     }
2591    else
2592     {
2593      if (avail)
2594       {
2595        Copy(buf,b->ptr,avail,STDCHAR);
2596        count   -= avail;
2597        buf     += avail;
2598        written += avail;
2599        b->ptr  += avail;
2600       }
2601     }
2602    if (b->ptr >= (b->buf + b->bufsiz))
2603     PerlIO_flush(f);
2604   }
2605  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2606   PerlIO_flush(f);
2607  return written;
2608 }
2609
2610 IV
2611 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2612 {
2613  IV code;
2614  if ((code = PerlIO_flush(f)) == 0)
2615   {
2616    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2617    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2618    code = PerlIO_seek(PerlIONext(f),offset,whence);
2619    if (code == 0)
2620     {
2621      b->posn = PerlIO_tell(PerlIONext(f));
2622     }
2623   }
2624  return code;
2625 }
2626
2627 Off_t
2628 PerlIOBuf_tell(PerlIO *f)
2629 {
2630  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2631  Off_t posn = b->posn;
2632  if (b->buf)
2633   posn += (b->ptr - b->buf);
2634  return posn;
2635 }
2636
2637 IV
2638 PerlIOBuf_close(PerlIO *f)
2639 {
2640  dTHX;
2641  IV code = PerlIOBase_close(f);
2642  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2643  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2644   {
2645    PerlMemShared_free(b->buf);
2646   }
2647  b->buf = NULL;
2648  b->ptr = b->end = b->buf;
2649  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2650  return code;
2651 }
2652
2653 STDCHAR *
2654 PerlIOBuf_get_ptr(PerlIO *f)
2655 {
2656  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2657  if (!b->buf)
2658   PerlIO_get_base(f);
2659  return b->ptr;
2660 }
2661
2662 SSize_t
2663 PerlIOBuf_get_cnt(PerlIO *f)
2664 {
2665  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2666  if (!b->buf)
2667   PerlIO_get_base(f);
2668  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2669   return (b->end - b->ptr);
2670  return 0;
2671 }
2672
2673 STDCHAR *
2674 PerlIOBuf_get_base(PerlIO *f)
2675 {
2676  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2677  if (!b->buf)
2678   {
2679    dTHX;
2680    if (!b->bufsiz)
2681     b->bufsiz = 4096;
2682    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2683    if (!b->buf)
2684     {
2685      b->buf = (STDCHAR *)&b->oneword;
2686      b->bufsiz = sizeof(b->oneword);
2687     }
2688    b->ptr = b->buf;
2689    b->end = b->ptr;
2690   }
2691  return b->buf;
2692 }
2693
2694 Size_t
2695 PerlIOBuf_bufsiz(PerlIO *f)
2696 {
2697  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2698  if (!b->buf)
2699   PerlIO_get_base(f);
2700  return (b->end - b->buf);
2701 }
2702
2703 void
2704 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2705 {
2706  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2707  if (!b->buf)
2708   PerlIO_get_base(f);
2709  b->ptr = ptr;
2710  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2711   {
2712    dTHX;
2713    assert(PerlIO_get_cnt(f) == cnt);
2714    assert(b->ptr >= b->buf);
2715   }
2716  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2717 }
2718
2719 PerlIO_funcs PerlIO_perlio = {
2720  "perlio",
2721  sizeof(PerlIOBuf),
2722  PERLIO_K_BUFFERED,
2723  PerlIOBuf_pushed,
2724  PerlIOBase_noop_ok,
2725  PerlIOBuf_open,
2726  NULL,
2727  PerlIOBase_fileno,
2728  PerlIOBuf_read,
2729  PerlIOBuf_unread,
2730  PerlIOBuf_write,
2731  PerlIOBuf_seek,
2732  PerlIOBuf_tell,
2733  PerlIOBuf_close,
2734  PerlIOBuf_flush,
2735  PerlIOBuf_fill,
2736  PerlIOBase_eof,
2737  PerlIOBase_error,
2738  PerlIOBase_clearerr,
2739  PerlIOBase_setlinebuf,
2740  PerlIOBuf_get_base,
2741  PerlIOBuf_bufsiz,
2742  PerlIOBuf_get_ptr,
2743  PerlIOBuf_get_cnt,
2744  PerlIOBuf_set_ptrcnt,
2745 };
2746
2747 /*--------------------------------------------------------------------------------------*/
2748 /* Temp layer to hold unread chars when cannot do it any other way */
2749
2750 IV
2751 PerlIOPending_fill(PerlIO *f)
2752 {
2753  /* Should never happen */
2754  PerlIO_flush(f);
2755  return 0;
2756 }
2757
2758 IV
2759 PerlIOPending_close(PerlIO *f)
2760 {
2761  /* A tad tricky - flush pops us, then we close new top */
2762  PerlIO_flush(f);
2763  return PerlIO_close(f);
2764 }
2765
2766 IV
2767 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2768 {
2769  /* A tad tricky - flush pops us, then we seek new top */
2770  PerlIO_flush(f);
2771  return PerlIO_seek(f,offset,whence);
2772 }
2773
2774
2775 IV
2776 PerlIOPending_flush(PerlIO *f)
2777 {
2778  dTHX;
2779  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2780  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2781   {
2782    PerlMemShared_free(b->buf);
2783    b->buf = NULL;
2784   }
2785  PerlIO_pop(aTHX_ f);
2786  return 0;
2787 }
2788
2789 void
2790 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2791 {
2792  if (cnt <= 0)
2793   {
2794    PerlIO_flush(f);
2795   }
2796  else
2797   {
2798    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2799   }
2800 }
2801
2802 IV
2803 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2804 {
2805  IV code    = PerlIOBase_pushed(f,mode,arg);
2806  PerlIOl *l = PerlIOBase(f);
2807  /* Our PerlIO_fast_gets must match what we are pushed on,
2808     or sv_gets() etc. get muddled when it changes mid-string
2809     when we auto-pop.
2810   */
2811  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2812               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2813  return code;
2814 }
2815
2816 SSize_t
2817 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2818 {
2819  SSize_t avail = PerlIO_get_cnt(f);
2820  SSize_t got   = 0;
2821  if (count < avail)
2822   avail = count;
2823  if (avail > 0)
2824   got = PerlIOBuf_read(f,vbuf,avail);
2825  if (got >= 0 && got < count)
2826   {
2827    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2828    if (more >= 0 || got == 0)
2829     got += more;
2830   }
2831  return got;
2832 }
2833
2834 PerlIO_funcs PerlIO_pending = {
2835  "pending",
2836  sizeof(PerlIOBuf),
2837  PERLIO_K_BUFFERED,
2838  PerlIOPending_pushed,
2839  PerlIOBase_noop_ok,
2840  NULL,
2841  NULL,
2842  PerlIOBase_fileno,
2843  PerlIOPending_read,
2844  PerlIOBuf_unread,
2845  PerlIOBuf_write,
2846  PerlIOPending_seek,
2847  PerlIOBuf_tell,
2848  PerlIOPending_close,
2849  PerlIOPending_flush,
2850  PerlIOPending_fill,
2851  PerlIOBase_eof,
2852  PerlIOBase_error,
2853  PerlIOBase_clearerr,
2854  PerlIOBase_setlinebuf,
2855  PerlIOBuf_get_base,
2856  PerlIOBuf_bufsiz,
2857  PerlIOBuf_get_ptr,
2858  PerlIOBuf_get_cnt,
2859  PerlIOPending_set_ptrcnt,
2860 };
2861
2862
2863
2864 /*--------------------------------------------------------------------------------------*/
2865 /* crlf - translation
2866    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2867    to hand back a line at a time and keeping a record of which nl we "lied" about.
2868    On write translate "\n" to CR,LF
2869  */
2870
2871 typedef struct
2872 {
2873  PerlIOBuf      base;         /* PerlIOBuf stuff */
2874  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2875 } PerlIOCrlf;
2876
2877 IV
2878 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2879 {
2880  IV code;
2881  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2882  code = PerlIOBuf_pushed(f,mode,arg);
2883 #if 0
2884  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2885               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2886               PerlIOBase(f)->flags);
2887 #endif
2888  return code;
2889 }
2890
2891
2892 SSize_t
2893 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2894 {
2895  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2896  if (c->nl)
2897   {
2898    *(c->nl) = 0xd;
2899    c->nl = NULL;
2900   }
2901  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2902   return PerlIOBuf_unread(f,vbuf,count);
2903  else
2904   {
2905    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2906    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2907    SSize_t unread = 0;
2908    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2909     PerlIO_flush(f);
2910    if (!b->buf)
2911     PerlIO_get_base(f);
2912    if (b->buf)
2913     {
2914      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2915       {
2916        b->end = b->ptr = b->buf + b->bufsiz;
2917        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2918        b->posn -= b->bufsiz;
2919       }
2920      while (count > 0 && b->ptr > b->buf)
2921       {
2922        int ch = *--buf;
2923        if (ch == '\n')
2924         {
2925          if (b->ptr - 2 >= b->buf)
2926           {
2927            *--(b->ptr) = 0xa;
2928            *--(b->ptr) = 0xd;
2929            unread++;
2930            count--;
2931           }
2932          else
2933           {
2934            buf++;
2935            break;
2936           }
2937         }
2938        else
2939         {
2940          *--(b->ptr) = ch;
2941          unread++;
2942          count--;
2943         }
2944       }
2945     }
2946    return unread;
2947   }
2948 }
2949
2950 SSize_t
2951 PerlIOCrlf_get_cnt(PerlIO *f)
2952 {
2953  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2954  if (!b->buf)
2955   PerlIO_get_base(f);
2956  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2957   {
2958    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2959    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2960     {
2961      STDCHAR *nl   = b->ptr;
2962     scan:
2963      while (nl < b->end && *nl != 0xd)
2964       nl++;
2965      if (nl < b->end && *nl == 0xd)
2966       {
2967      test:
2968        if (nl+1 < b->end)
2969         {
2970          if (nl[1] == 0xa)
2971           {
2972            *nl   = '\n';
2973            c->nl = nl;
2974           }
2975          else
2976           {
2977            /* Not CR,LF but just CR */
2978            nl++;
2979            goto scan;
2980           }
2981         }
2982        else
2983         {
2984          /* Blast - found CR as last char in buffer */
2985          if (b->ptr < nl)
2986           {
2987            /* They may not care, defer work as long as possible */
2988            return (nl - b->ptr);
2989           }
2990          else
2991           {
2992            int code;
2993            dTHX;
2994            b->ptr++;               /* say we have read it as far as flush() is concerned */
2995            b->buf++;               /* Leave space an front of buffer */
2996            b->bufsiz--;            /* Buffer is thus smaller */
2997            code = PerlIO_fill(f);  /* Fetch some more */
2998            b->bufsiz++;            /* Restore size for next time */
2999            b->buf--;               /* Point at space */
3000            b->ptr = nl = b->buf;   /* Which is what we hand off */
3001            b->posn--;              /* Buffer starts here */
3002            *nl = 0xd;              /* Fill in the CR */
3003            if (code == 0)
3004             goto test;             /* fill() call worked */
3005            /* CR at EOF - just fall through */
3006           }
3007         }
3008       }
3009     }
3010    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3011   }
3012  return 0;
3013 }
3014
3015 void
3016 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3017 {
3018  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3019  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3020  IV flags = PerlIOBase(f)->flags;
3021  if (!b->buf)
3022   PerlIO_get_base(f);
3023  if (!ptr)
3024   {
3025    if (c->nl)
3026     ptr = c->nl+1;
3027    else
3028     {
3029      ptr = b->end;
3030      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3031       ptr--;
3032     }
3033    ptr -= cnt;
3034   }
3035  else
3036   {
3037    /* Test code - delete when it works ... */
3038    STDCHAR *chk;
3039    if (c->nl)
3040     chk = c->nl+1;
3041    else
3042     {
3043      chk = b->end;
3044      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3045       chk--;
3046     }
3047    chk -= cnt;
3048
3049    if (ptr != chk)
3050     {
3051      dTHX;
3052      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3053                 ptr, chk, flags, c->nl, b->end, cnt);
3054     }
3055   }
3056  if (c->nl)
3057   {
3058    if (ptr > c->nl)
3059     {
3060      /* They have taken what we lied about */
3061      *(c->nl) = 0xd;
3062      c->nl = NULL;
3063      ptr++;
3064     }
3065   }
3066  b->ptr = ptr;
3067  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3068 }
3069
3070 SSize_t
3071 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3072 {
3073  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3074   return PerlIOBuf_write(f,vbuf,count);
3075  else
3076   {
3077    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3078    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3079    const STDCHAR *ebuf = buf+count;
3080    if (!b->buf)
3081     PerlIO_get_base(f);
3082    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3083     return 0;
3084    while (buf < ebuf)
3085     {
3086      STDCHAR *eptr = b->buf+b->bufsiz;
3087      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3088      while (buf < ebuf && b->ptr < eptr)
3089       {
3090        if (*buf == '\n')
3091         {
3092          if ((b->ptr + 2) > eptr)
3093           {
3094            /* Not room for both */
3095            PerlIO_flush(f);
3096            break;
3097           }
3098          else
3099           {
3100            *(b->ptr)++ = 0xd; /* CR */
3101            *(b->ptr)++ = 0xa; /* LF */
3102            buf++;
3103            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3104             {
3105              PerlIO_flush(f);
3106              break;
3107             }
3108           }
3109         }
3110        else
3111         {
3112          int ch = *buf++;
3113          *(b->ptr)++ = ch;
3114         }
3115        if (b->ptr >= eptr)
3116         {
3117          PerlIO_flush(f);
3118          break;
3119         }
3120       }
3121     }
3122    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3123     PerlIO_flush(f);
3124    return (buf - (STDCHAR *) vbuf);
3125   }
3126 }
3127
3128 IV
3129 PerlIOCrlf_flush(PerlIO *f)
3130 {
3131  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3132  if (c->nl)
3133   {
3134    *(c->nl) = 0xd;
3135    c->nl = NULL;
3136   }
3137  return PerlIOBuf_flush(f);
3138 }
3139
3140 PerlIO_funcs PerlIO_crlf = {
3141  "crlf",
3142  sizeof(PerlIOCrlf),
3143  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3144  PerlIOCrlf_pushed,
3145  PerlIOBase_noop_ok,   /* popped */
3146  PerlIOBuf_open,
3147  NULL,
3148  PerlIOBase_fileno,
3149  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3150  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3151  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3152  PerlIOBuf_seek,
3153  PerlIOBuf_tell,
3154  PerlIOBuf_close,
3155  PerlIOCrlf_flush,
3156  PerlIOBuf_fill,
3157  PerlIOBase_eof,
3158  PerlIOBase_error,
3159  PerlIOBase_clearerr,
3160  PerlIOBase_setlinebuf,
3161  PerlIOBuf_get_base,
3162  PerlIOBuf_bufsiz,
3163  PerlIOBuf_get_ptr,
3164  PerlIOCrlf_get_cnt,
3165  PerlIOCrlf_set_ptrcnt,
3166 };
3167
3168 #ifdef HAS_MMAP
3169 /*--------------------------------------------------------------------------------------*/
3170 /* mmap as "buffer" layer */
3171
3172 typedef struct
3173 {
3174  PerlIOBuf      base;         /* PerlIOBuf stuff */
3175  Mmap_t         mptr;        /* Mapped address */
3176  Size_t         len;          /* mapped length */
3177  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3178 } PerlIOMmap;
3179
3180 static size_t page_size = 0;
3181
3182 IV
3183 PerlIOMmap_map(PerlIO *f)
3184 {
3185  dTHX;
3186  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3187  PerlIOBuf  *b = &m->base;
3188  IV flags = PerlIOBase(f)->flags;
3189  IV code  = 0;
3190  if (m->len)
3191   abort();
3192  if (flags & PERLIO_F_CANREAD)
3193   {
3194    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3195    int fd   = PerlIO_fileno(f);
3196    struct stat st;
3197    code = fstat(fd,&st);
3198    if (code == 0 && S_ISREG(st.st_mode))
3199     {
3200      SSize_t len = st.st_size - b->posn;
3201      if (len > 0)
3202       {
3203        Off_t posn;
3204        if (!page_size) {
3205 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3206            {
3207                SETERRNO(0,SS$_NORMAL);
3208 #   ifdef _SC_PAGESIZE
3209                page_size = sysconf(_SC_PAGESIZE);
3210 #   else
3211                page_size = sysconf(_SC_PAGE_SIZE);
3212 #   endif
3213                if ((long)page_size < 0) {
3214                    if (errno) {
3215                        SV *error = ERRSV;
3216                        char *msg;
3217                        STRLEN n_a;
3218                        (void)SvUPGRADE(error, SVt_PV);
3219                        msg = SvPVx(error, n_a);
3220                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3221                    }
3222                    else
3223                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3224                }
3225            }
3226 #else
3227 #   ifdef HAS_GETPAGESIZE
3228         page_size = getpagesize();
3229 #   else
3230 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3231         page_size = PAGESIZE; /* compiletime, bad */
3232 #       endif
3233 #   endif
3234 #endif
3235         if ((IV)page_size <= 0)
3236             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3237        }
3238        if (b->posn < 0)
3239         {
3240          /* This is a hack - should never happen - open should have set it ! */
3241          b->posn = PerlIO_tell(PerlIONext(f));
3242         }
3243        posn = (b->posn / page_size) * page_size;
3244        len  = st.st_size - posn;
3245        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3246        if (m->mptr && m->mptr != (Mmap_t) -1)
3247         {
3248 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3249          madvise(m->mptr, len, MADV_SEQUENTIAL);
3250 #endif
3251 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3252          madvise(m->mptr, len, MADV_WILLNEED);
3253 #endif
3254          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3255          b->end  = ((STDCHAR *)m->mptr) + len;
3256          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3257          b->ptr  = b->buf;
3258          m->len  = len;
3259         }
3260        else
3261         {
3262          b->buf = NULL;
3263         }
3264       }
3265      else
3266       {
3267        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3268        b->buf = NULL;
3269        b->ptr = b->end = b->ptr;
3270        code = -1;
3271       }
3272     }
3273   }
3274  return code;
3275 }
3276
3277 IV
3278 PerlIOMmap_unmap(PerlIO *f)
3279 {
3280  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3281  PerlIOBuf  *b = &m->base;
3282  IV code = 0;
3283  if (m->len)
3284   {
3285    if (b->buf)
3286     {
3287      code = munmap(m->mptr, m->len);
3288      b->buf  = NULL;
3289      m->len  = 0;
3290      m->mptr = NULL;
3291      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3292       code = -1;
3293     }
3294    b->ptr = b->end = b->buf;
3295    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3296   }
3297  return code;
3298 }
3299
3300 STDCHAR *
3301 PerlIOMmap_get_base(PerlIO *f)
3302 {
3303  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3304  PerlIOBuf  *b = &m->base;
3305  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3306   {
3307    /* Already have a readbuffer in progress */
3308    return b->buf;
3309   }
3310  if (b->buf)
3311   {
3312    /* We have a write buffer or flushed PerlIOBuf read buffer */
3313    m->bbuf = b->buf;  /* save it in case we need it again */
3314    b->buf  = NULL;    /* Clear to trigger below */
3315   }
3316  if (!b->buf)
3317   {
3318    PerlIOMmap_map(f);     /* Try and map it */
3319    if (!b->buf)
3320     {
3321      /* Map did not work - recover PerlIOBuf buffer if we have one */
3322      b->buf = m->bbuf;
3323     }
3324   }
3325  b->ptr  = b->end = b->buf;
3326  if (b->buf)
3327   return b->buf;
3328  return PerlIOBuf_get_base(f);
3329 }
3330
3331 SSize_t
3332 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3333 {
3334  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3335  PerlIOBuf  *b = &m->base;
3336  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3337   PerlIO_flush(f);
3338  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3339   {
3340    b->ptr -= count;
3341    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3342    return count;
3343   }
3344  if (m->len)
3345   {
3346    /* Loose the unwritable mapped buffer */
3347    PerlIO_flush(f);
3348    /* If flush took the "buffer" see if we have one from before */
3349    if (!b->buf && m->bbuf)
3350     b->buf = m->bbuf;
3351    if (!b->buf)
3352     {
3353      PerlIOBuf_get_base(f);
3354      m->bbuf = b->buf;
3355     }
3356   }
3357 return PerlIOBuf_unread(f,vbuf,count);
3358 }
3359
3360 SSize_t
3361 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3362 {
3363  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3364  PerlIOBuf  *b = &m->base;
3365  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3366   {
3367    /* No, or wrong sort of, buffer */
3368    if (m->len)
3369     {
3370      if (PerlIOMmap_unmap(f) != 0)
3371       return 0;
3372     }
3373    /* If unmap took the "buffer" see if we have one from before */
3374    if (!b->buf && m->bbuf)
3375     b->buf = m->bbuf;
3376    if (!b->buf)
3377     {
3378      PerlIOBuf_get_base(f);
3379      m->bbuf = b->buf;
3380     }
3381   }
3382  return PerlIOBuf_write(f,vbuf,count);
3383 }
3384
3385 IV
3386 PerlIOMmap_flush(PerlIO *f)
3387 {
3388  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3389  PerlIOBuf  *b = &m->base;
3390  IV code = PerlIOBuf_flush(f);
3391  /* Now we are "synced" at PerlIOBuf level */
3392  if (b->buf)
3393   {
3394    if (m->len)
3395     {
3396      /* Unmap the buffer */
3397      if (PerlIOMmap_unmap(f) != 0)
3398       code = -1;
3399     }
3400    else
3401     {
3402      /* We seem to have a PerlIOBuf buffer which was not mapped
3403       * remember it in case we need one later
3404       */
3405      m->bbuf = b->buf;
3406     }
3407   }
3408  return code;
3409 }
3410
3411 IV
3412 PerlIOMmap_fill(PerlIO *f)
3413 {
3414  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3415  IV code = PerlIO_flush(f);
3416  if (code == 0 && !b->buf)
3417   {
3418    code = PerlIOMmap_map(f);
3419   }
3420  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3421   {
3422    code = PerlIOBuf_fill(f);
3423   }
3424  return code;
3425 }
3426
3427 IV
3428 PerlIOMmap_close(PerlIO *f)
3429 {
3430  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3431  PerlIOBuf  *b = &m->base;
3432  IV code = PerlIO_flush(f);
3433  if (m->bbuf)
3434   {
3435    b->buf  = m->bbuf;
3436    m->bbuf = NULL;
3437    b->ptr  = b->end = b->buf;
3438   }
3439  if (PerlIOBuf_close(f) != 0)
3440   code = -1;
3441  return code;
3442 }
3443
3444
3445 PerlIO_funcs PerlIO_mmap = {
3446  "mmap",
3447  sizeof(PerlIOMmap),
3448  PERLIO_K_BUFFERED,
3449  PerlIOBuf_pushed,
3450  PerlIOBase_noop_ok,
3451  PerlIOBuf_open,
3452  NULL,
3453  PerlIOBase_fileno,
3454  PerlIOBuf_read,
3455  PerlIOMmap_unread,
3456  PerlIOMmap_write,
3457  PerlIOBuf_seek,
3458  PerlIOBuf_tell,
3459  PerlIOBuf_close,
3460  PerlIOMmap_flush,
3461  PerlIOMmap_fill,
3462  PerlIOBase_eof,
3463  PerlIOBase_error,
3464  PerlIOBase_clearerr,
3465  PerlIOBase_setlinebuf,
3466  PerlIOMmap_get_base,
3467  PerlIOBuf_bufsiz,
3468  PerlIOBuf_get_ptr,
3469  PerlIOBuf_get_cnt,
3470  PerlIOBuf_set_ptrcnt,
3471 };
3472
3473 #endif /* HAS_MMAP */
3474
3475 void
3476 PerlIO_init(void)
3477 {
3478  if (!_perlio)
3479   {
3480 #ifndef WIN32
3481    atexit(&PerlIO_cleanup);
3482 #endif
3483   }
3484 }
3485
3486 #undef PerlIO_stdin
3487 PerlIO *
3488 PerlIO_stdin(void)
3489 {
3490  if (!_perlio)
3491   {
3492    dTHX;
3493    PerlIO_stdstreams(aTHX);
3494   }
3495  return &_perlio[1];
3496 }
3497
3498 #undef PerlIO_stdout
3499 PerlIO *
3500 PerlIO_stdout(void)
3501 {
3502  if (!_perlio)
3503   {
3504    dTHX;
3505    PerlIO_stdstreams(aTHX);
3506   }
3507  return &_perlio[2];
3508 }
3509
3510 #undef PerlIO_stderr
3511 PerlIO *
3512 PerlIO_stderr(void)
3513 {
3514  if (!_perlio)
3515   {
3516    dTHX;
3517    PerlIO_stdstreams(aTHX);
3518   }
3519  return &_perlio[3];
3520 }
3521
3522 /*--------------------------------------------------------------------------------------*/
3523
3524 #undef PerlIO_getname
3525 char *
3526 PerlIO_getname(PerlIO *f, char *buf)
3527 {
3528  dTHX;
3529  Perl_croak(aTHX_ "Don't know how to get file name");
3530  return NULL;
3531 }
3532
3533
3534 /*--------------------------------------------------------------------------------------*/
3535 /* Functions which can be called on any kind of PerlIO implemented
3536    in terms of above
3537 */
3538
3539 #undef PerlIO_getc
3540 int
3541 PerlIO_getc(PerlIO *f)
3542 {
3543  STDCHAR buf[1];
3544  SSize_t count = PerlIO_read(f,buf,1);
3545  if (count == 1)
3546   {
3547    return (unsigned char) buf[0];
3548   }
3549  return EOF;
3550 }
3551
3552 #undef PerlIO_ungetc
3553 int
3554 PerlIO_ungetc(PerlIO *f, int ch)
3555 {
3556  if (ch != EOF)
3557   {
3558    STDCHAR buf = ch;
3559    if (PerlIO_unread(f,&buf,1) == 1)
3560     return ch;
3561   }
3562  return EOF;
3563 }
3564
3565 #undef PerlIO_putc
3566 int
3567 PerlIO_putc(PerlIO *f, int ch)
3568 {
3569  STDCHAR buf = ch;
3570  return PerlIO_write(f,&buf,1);
3571 }
3572
3573 #undef PerlIO_puts
3574 int
3575 PerlIO_puts(PerlIO *f, const char *s)
3576 {
3577  STRLEN len = strlen(s);
3578  return PerlIO_write(f,s,len);
3579 }
3580
3581 #undef PerlIO_rewind
3582 void
3583 PerlIO_rewind(PerlIO *f)
3584 {
3585  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3586  PerlIO_clearerr(f);
3587 }
3588
3589 #undef PerlIO_vprintf
3590 int
3591 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3592 {
3593  dTHX;
3594  SV *sv = newSVpvn("",0);
3595  char *s;
3596  STRLEN len;
3597  SSize_t wrote;
3598 #ifdef NEED_VA_COPY
3599  va_list apc;
3600  Perl_va_copy(ap, apc);
3601  sv_vcatpvf(sv, fmt, &apc);
3602 #else
3603  sv_vcatpvf(sv, fmt, &ap);
3604 #endif
3605  s = SvPV(sv,len);
3606  wrote = PerlIO_write(f,s,len);
3607  SvREFCNT_dec(sv);
3608  return wrote;
3609 }
3610
3611 #undef PerlIO_printf
3612 int
3613 PerlIO_printf(PerlIO *f,const char *fmt,...)
3614 {
3615  va_list ap;
3616  int result;
3617  va_start(ap,fmt);
3618  result = PerlIO_vprintf(f,fmt,ap);
3619  va_end(ap);
3620  return result;
3621 }
3622
3623 #undef PerlIO_stdoutf
3624 int
3625 PerlIO_stdoutf(const char *fmt,...)
3626 {
3627  va_list ap;
3628  int result;
3629  va_start(ap,fmt);
3630  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3631  va_end(ap);
3632  return result;
3633 }
3634
3635 #undef PerlIO_tmpfile
3636 PerlIO *
3637 PerlIO_tmpfile(void)
3638 {
3639  /* I have no idea how portable mkstemp() is ... */
3640 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3641  dTHX;
3642  PerlIO *f = NULL;
3643  FILE *stdio = PerlSIO_tmpfile();
3644  if (stdio)
3645   {
3646    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3647    s->stdio  = stdio;
3648   }
3649  return f;
3650 #else
3651  dTHX;
3652  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3653  int fd = mkstemp(SvPVX(sv));
3654  PerlIO *f = NULL;
3655  if (fd >= 0)
3656   {
3657    f = PerlIO_fdopen(fd,"w+");
3658    if (f)
3659     {
3660      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3661     }
3662    PerlLIO_unlink(SvPVX(sv));
3663    SvREFCNT_dec(sv);
3664   }
3665  return f;
3666 #endif
3667 }
3668
3669 #undef HAS_FSETPOS
3670 #undef HAS_FGETPOS
3671
3672 #endif /* USE_SFIO */
3673 #endif /* PERLIO_IS_STDIO */
3674
3675 /*======================================================================================*/
3676 /* Now some functions in terms of above which may be needed even if
3677    we are not in true PerlIO mode
3678  */
3679
3680 #ifndef HAS_FSETPOS
3681 #undef PerlIO_setpos
3682 int
3683 PerlIO_setpos(PerlIO *f, SV *pos)
3684 {
3685  dTHX;
3686  if (SvOK(pos))
3687   {
3688    STRLEN len;
3689    Off_t *posn = (Off_t *) SvPV(pos,len);
3690    if (f && len == sizeof(Off_t))
3691     return PerlIO_seek(f,*posn,SEEK_SET);
3692   }
3693  errno = EINVAL;
3694  return -1;
3695 }
3696 #else
3697 #undef PerlIO_setpos
3698 int
3699 PerlIO_setpos(PerlIO *f, SV *pos)
3700 {
3701  dTHX;
3702  if (SvOK(pos))
3703   {
3704    STRLEN len;
3705    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3706    if (f && len == sizeof(Fpos_t))
3707     {
3708 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3709      return fsetpos64(f, fpos);
3710 #else
3711      return fsetpos(f, fpos);
3712 #endif
3713     }
3714   }
3715  errno = EINVAL;
3716  return -1;
3717 }
3718 #endif
3719
3720 #ifndef HAS_FGETPOS
3721 #undef PerlIO_getpos
3722 int
3723 PerlIO_getpos(PerlIO *f, SV *pos)
3724 {
3725  dTHX;
3726  Off_t posn = PerlIO_tell(f);
3727  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3728  return (posn == (Off_t)-1) ? -1 : 0;
3729 }
3730 #else
3731 #undef PerlIO_getpos
3732 int
3733 PerlIO_getpos(PerlIO *f, SV *pos)
3734 {
3735  dTHX;
3736  Fpos_t fpos;
3737  int code;
3738 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3739  code = fgetpos64(f, &fpos);
3740 #else
3741  code = fgetpos(f, &fpos);
3742 #endif
3743  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3744  return code;
3745 }
3746 #endif
3747
3748 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3749
3750 int
3751 vprintf(char *pat, char *args)
3752 {
3753     _doprnt(pat, args, stdout);
3754     return 0;           /* wrong, but perl doesn't use the return value */
3755 }
3756
3757 int
3758 vfprintf(FILE *fd, char *pat, char *args)
3759 {
3760     _doprnt(pat, args, fd);
3761     return 0;           /* wrong, but perl doesn't use the return value */
3762 }
3763
3764 #endif
3765
3766 #ifndef PerlIO_vsprintf
3767 int
3768 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3769 {
3770  int val = vsprintf(s, fmt, ap);
3771  if (n >= 0)
3772   {
3773    if (strlen(s) >= (STRLEN)n)
3774     {
3775      dTHX;
3776      (void)PerlIO_puts(Perl_error_log,
3777                        "panic: sprintf overflow - memory corrupted!\n");
3778      my_exit(1);
3779     }
3780   }
3781  return val;
3782 }
3783 #endif
3784
3785 #ifndef PerlIO_sprintf
3786 int
3787 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3788 {
3789  va_list ap;
3790  int result;
3791  va_start(ap,fmt);
3792  result = PerlIO_vsprintf(s, n, fmt, ap);
3793  va_end(ap);
3794  return result;
3795 }
3796 #endif
3797
3798