perlio.c

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