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