perlio.c

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