perlio.c

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