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