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,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 #undef PerlIO_fill
1144 int
1145 PerlIO_fill(PerlIO *f)
1146 {
1147  return (*PerlIOBase(f)->tab->Fill)(f);
1148 }
1149
1150 #undef PerlIO_isutf8
1151 int
1152 PerlIO_isutf8(PerlIO *f)
1153 {
1154  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1155 }
1156
1157 #undef PerlIO_eof
1158 int
1159 PerlIO_eof(PerlIO *f)
1160 {
1161  return (*PerlIOBase(f)->tab->Eof)(f);
1162 }
1163
1164 #undef PerlIO_error
1165 int
1166 PerlIO_error(PerlIO *f)
1167 {
1168  return (*PerlIOBase(f)->tab->Error)(f);
1169 }
1170
1171 #undef PerlIO_clearerr
1172 void
1173 PerlIO_clearerr(PerlIO *f)
1174 {
1175  if (f && *f)
1176   (*PerlIOBase(f)->tab->Clearerr)(f);
1177 }
1178
1179 #undef PerlIO_setlinebuf
1180 void
1181 PerlIO_setlinebuf(PerlIO *f)
1182 {
1183  (*PerlIOBase(f)->tab->Setlinebuf)(f);
1184 }
1185
1186 #undef PerlIO_has_base
1187 int
1188 PerlIO_has_base(PerlIO *f)
1189 {
1190  if (f && *f)
1191   {
1192    return (PerlIOBase(f)->tab->Get_base != NULL);
1193   }
1194  return 0;
1195 }
1196
1197 #undef PerlIO_fast_gets
1198 int
1199 PerlIO_fast_gets(PerlIO *f)
1200 {
1201  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1202   {
1203    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1204    return (tab->Set_ptrcnt != NULL);
1205   }
1206  return 0;
1207 }
1208
1209 #undef PerlIO_has_cntptr
1210 int
1211 PerlIO_has_cntptr(PerlIO *f)
1212 {
1213  if (f && *f)
1214   {
1215    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1216    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1217   }
1218  return 0;
1219 }
1220
1221 #undef PerlIO_canset_cnt
1222 int
1223 PerlIO_canset_cnt(PerlIO *f)
1224 {
1225  if (f && *f)
1226   {
1227    PerlIOl *l = PerlIOBase(f);
1228    return (l->tab->Set_ptrcnt != NULL);
1229   }
1230  return 0;
1231 }
1232
1233 #undef PerlIO_get_base
1234 STDCHAR *
1235 PerlIO_get_base(PerlIO *f)
1236 {
1237  return (*PerlIOBase(f)->tab->Get_base)(f);
1238 }
1239
1240 #undef PerlIO_get_bufsiz
1241 int
1242 PerlIO_get_bufsiz(PerlIO *f)
1243 {
1244  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1245 }
1246
1247 #undef PerlIO_get_ptr
1248 STDCHAR *
1249 PerlIO_get_ptr(PerlIO *f)
1250 {
1251  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1252  if (tab->Get_ptr == NULL)
1253   return NULL;
1254  return (*tab->Get_ptr)(f);
1255 }
1256
1257 #undef PerlIO_get_cnt
1258 int
1259 PerlIO_get_cnt(PerlIO *f)
1260 {
1261  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1262  if (tab->Get_cnt == NULL)
1263   return 0;
1264  return (*tab->Get_cnt)(f);
1265 }
1266
1267 #undef PerlIO_set_cnt
1268 void
1269 PerlIO_set_cnt(PerlIO *f,int cnt)
1270 {
1271  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1272 }
1273
1274 #undef PerlIO_set_ptrcnt
1275 void
1276 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1277 {
1278  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1279  if (tab->Set_ptrcnt == NULL)
1280   {
1281    dTHX;
1282    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1283   }
1284  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1285 }
1286
1287 /*--------------------------------------------------------------------------------------*/
1288 /* utf8 and raw dummy layers */
1289
1290 IV
1291 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1292 {
1293  if (PerlIONext(f))
1294   {
1295    dTHX;
1296    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1297    PerlIO_pop(aTHX_ f);
1298    if (tab->kind & PERLIO_K_UTF8)
1299     PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1300    else
1301     PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1302    return 0;
1303   }
1304  return -1;
1305 }
1306
1307 PerlIO_funcs PerlIO_utf8 = {
1308  "utf8",
1309  sizeof(PerlIOl),
1310  PERLIO_K_DUMMY|PERLIO_F_UTF8,
1311  PerlIOUtf8_pushed,
1312  NULL,
1313  NULL,
1314  NULL,
1315  NULL,
1316  NULL,
1317  NULL,
1318  NULL,
1319  NULL,
1320  NULL,
1321  NULL,
1322  NULL, /* flush */
1323  NULL, /* fill */
1324  NULL,
1325  NULL,
1326  NULL,
1327  NULL,
1328  NULL, /* get_base */
1329  NULL, /* get_bufsiz */
1330  NULL, /* get_ptr */
1331  NULL, /* get_cnt */
1332  NULL, /* set_ptrcnt */
1333 };
1334
1335 PerlIO_funcs PerlIO_byte = {
1336  "bytes",
1337  sizeof(PerlIOl),
1338  PERLIO_K_DUMMY,
1339  PerlIOUtf8_pushed,
1340  NULL,
1341  NULL,
1342  NULL,
1343  NULL,
1344  NULL,
1345  NULL,
1346  NULL,
1347  NULL,
1348  NULL,
1349  NULL,
1350  NULL, /* flush */
1351  NULL, /* fill */
1352  NULL,
1353  NULL,
1354  NULL,
1355  NULL,
1356  NULL, /* get_base */
1357  NULL, /* get_bufsiz */
1358  NULL, /* get_ptr */
1359  NULL, /* get_cnt */
1360  NULL, /* set_ptrcnt */
1361 };
1362
1363 PerlIO *
1364 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)
1365 {
1366  PerlIO_funcs *tab = PerlIO_default_btm();
1367  return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1368 }
1369
1370 PerlIO_funcs PerlIO_raw = {
1371  "raw",
1372  sizeof(PerlIOl),
1373  PERLIO_K_DUMMY,
1374  PerlIORaw_pushed,
1375  PerlIOBase_popped,
1376  PerlIORaw_open,
1377  NULL,
1378  NULL,
1379  NULL,
1380  NULL,
1381  NULL,
1382  NULL,
1383  NULL,
1384  NULL,
1385  NULL, /* flush */
1386  NULL, /* fill */
1387  NULL,
1388  NULL,
1389  NULL,
1390  NULL,
1391  NULL, /* get_base */
1392  NULL, /* get_bufsiz */
1393  NULL, /* get_ptr */
1394  NULL, /* get_cnt */
1395  NULL, /* set_ptrcnt */
1396 };
1397 /*--------------------------------------------------------------------------------------*/
1398 /*--------------------------------------------------------------------------------------*/
1399 /* "Methods" of the "base class" */
1400
1401 IV
1402 PerlIOBase_fileno(PerlIO *f)
1403 {
1404  return PerlIO_fileno(PerlIONext(f));
1405 }
1406
1407 char *
1408 PerlIO_modestr(PerlIO *f,char *buf)
1409 {
1410  char *s = buf;
1411  IV flags = PerlIOBase(f)->flags;
1412  if (flags & PERLIO_F_APPEND)
1413   {
1414    *s++ = 'a';
1415    if (flags & PERLIO_F_CANREAD)
1416     {
1417      *s++ = '+';
1418     }
1419   }
1420  else if (flags & PERLIO_F_CANREAD)
1421   {
1422    *s++ = 'r';
1423    if (flags & PERLIO_F_CANWRITE)
1424     *s++ = '+';
1425   }
1426  else if (flags & PERLIO_F_CANWRITE)
1427   {
1428    *s++ = 'w';
1429    if (flags & PERLIO_F_CANREAD)
1430     {
1431      *s++ = '+';
1432     }
1433   }
1434 #if O_TEXT != O_BINARY
1435  if (!(flags & PERLIO_F_CRLF))
1436   *s++ = 'b';
1437 #endif
1438  *s = '\0';
1439  return buf;
1440 }
1441
1442 IV
1443 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1444 {
1445  PerlIOl *l = PerlIOBase(f);
1446  const char *omode = mode;
1447  char temp[8];
1448  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1449  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1450                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1451  if (tab->Set_ptrcnt != NULL)
1452   l->flags |= PERLIO_F_FASTGETS;
1453  if (mode)
1454   {
1455    switch (*mode++)
1456     {
1457      case 'r':
1458       l->flags |= PERLIO_F_CANREAD;
1459       break;
1460      case 'a':
1461       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1462       break;
1463      case 'w':
1464       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1465       break;
1466      default:
1467       errno = EINVAL;
1468       return -1;
1469     }
1470    while (*mode)
1471     {
1472      switch (*mode++)
1473       {
1474        case '+':
1475         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1476         break;
1477        case 'b':
1478         l->flags &= ~PERLIO_F_CRLF;
1479         break;
1480        case 't':
1481         l->flags |= PERLIO_F_CRLF;
1482         break;
1483       default:
1484        errno = EINVAL;
1485        return -1;
1486       }
1487     }
1488   }
1489  else
1490   {
1491    if (l->next)
1492     {
1493      l->flags |= l->next->flags &
1494                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1495     }
1496   }
1497 #if 0
1498  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1499               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1500               l->flags,PerlIO_modestr(f,temp));
1501 #endif
1502  return 0;
1503 }
1504
1505 IV
1506 PerlIOBase_popped(PerlIO *f)
1507 {
1508  return 0;
1509 }
1510
1511 SSize_t
1512 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1513 {
1514  dTHX;
1515  Off_t old = PerlIO_tell(f);
1516  SSize_t done;
1517  PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1518  done = PerlIOBuf_unread(f,vbuf,count);
1519  PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1520  return done;
1521 }
1522
1523 SSize_t
1524 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1525 {
1526  STDCHAR *buf  = (STDCHAR *) vbuf;
1527  if (f)
1528   {
1529    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1530     return 0;
1531    while (count > 0)
1532     {
1533      SSize_t avail = PerlIO_get_cnt(f);
1534      SSize_t take  = (count < avail) ? count : avail;
1535      if (take > 0)
1536       {
1537        STDCHAR *ptr = PerlIO_get_ptr(f);
1538        Copy(ptr,buf,take,STDCHAR);
1539        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1540        count   -= take;
1541        buf     += take;
1542       }
1543      if (count > 0  && avail <= 0)
1544       {
1545        if (PerlIO_fill(f) != 0)
1546         break;
1547       }
1548     }
1549    return (buf - (STDCHAR *) vbuf);
1550   }
1551  return 0;
1552 }
1553
1554 IV
1555 PerlIOBase_noop_ok(PerlIO *f)
1556 {
1557  return 0;
1558 }
1559
1560 IV
1561 PerlIOBase_noop_fail(PerlIO *f)
1562 {
1563  return -1;
1564 }
1565
1566 IV
1567 PerlIOBase_close(PerlIO *f)
1568 {
1569  IV code = 0;
1570  PerlIO *n = PerlIONext(f);
1571  if (PerlIO_flush(f) != 0)
1572   code = -1;
1573  if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1574   code = -1;
1575  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1576  return code;
1577 }
1578
1579 IV
1580 PerlIOBase_eof(PerlIO *f)
1581 {
1582  if (f && *f)
1583   {
1584    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1585   }
1586  return 1;
1587 }
1588
1589 IV
1590 PerlIOBase_error(PerlIO *f)
1591 {
1592  if (f && *f)
1593   {
1594    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1595   }
1596  return 1;
1597 }
1598
1599 void
1600 PerlIOBase_clearerr(PerlIO *f)
1601 {
1602  if (f && *f)
1603   {
1604    PerlIO *n = PerlIONext(f);
1605    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1606    if (n)
1607     PerlIO_clearerr(n);
1608   }
1609 }
1610
1611 void
1612 PerlIOBase_setlinebuf(PerlIO *f)
1613 {
1614  if (f)
1615   {
1616    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1617   }
1618 }
1619
1620 /*--------------------------------------------------------------------------------------*/
1621 /* Bottom-most level for UNIX-like case */
1622
1623 typedef struct
1624 {
1625  struct _PerlIO base;       /* The generic part */
1626  int            fd;         /* UNIX like file descriptor */
1627  int            oflags;     /* open/fcntl flags */
1628 } PerlIOUnix;
1629
1630 int
1631 PerlIOUnix_oflags(const char *mode)
1632 {
1633  int oflags = -1;
1634  switch(*mode)
1635   {
1636    case 'r':
1637     oflags = O_RDONLY;
1638     if (*++mode == '+')
1639      {
1640       oflags = O_RDWR;
1641       mode++;
1642      }
1643     break;
1644
1645    case 'w':
1646     oflags = O_CREAT|O_TRUNC;
1647     if (*++mode == '+')
1648      {
1649       oflags |= O_RDWR;
1650       mode++;
1651      }
1652     else
1653      oflags |= O_WRONLY;
1654     break;
1655
1656    case 'a':
1657     oflags = O_CREAT|O_APPEND;
1658     if (*++mode == '+')
1659      {
1660       oflags |= O_RDWR;
1661       mode++;
1662      }
1663     else
1664      oflags |= O_WRONLY;
1665     break;
1666   }
1667  if (*mode == 'b')
1668   {
1669    oflags |=  O_BINARY;
1670    oflags &= ~O_TEXT;
1671    mode++;
1672   }
1673  else if (*mode == 't')
1674   {
1675    oflags |=  O_TEXT;
1676    oflags &= ~O_BINARY;
1677    mode++;
1678   }
1679  /* Always open in binary mode */
1680  oflags |= O_BINARY;
1681  if (*mode || oflags == -1)
1682   {
1683    errno = EINVAL;
1684    oflags = -1;
1685   }
1686  return oflags;
1687 }
1688
1689 IV
1690 PerlIOUnix_fileno(PerlIO *f)
1691 {
1692  return PerlIOSelf(f,PerlIOUnix)->fd;
1693 }
1694
1695 IV
1696 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1697 {
1698  IV code = PerlIOBase_pushed(f,mode,arg);
1699  if (*PerlIONext(f))
1700   {
1701    PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1702    s->fd     = PerlIO_fileno(PerlIONext(f));
1703    s->oflags = PerlIOUnix_oflags(mode);
1704   }
1705  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1706  return code;
1707 }
1708
1709 PerlIO *
1710 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)
1711 {
1712  if (f)
1713   {
1714    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1715     (*PerlIOBase(f)->tab->Close)(f);
1716   }
1717  if (narg > 0)
1718   {
1719    char *path = SvPV_nolen(*args);
1720    if (*mode == '#')
1721     mode++;
1722    else
1723     {
1724      imode = PerlIOUnix_oflags(mode);
1725      perm  = 0666;
1726     }
1727    if (imode != -1)
1728     {
1729      fd = PerlLIO_open3(path,imode,perm);
1730     }
1731   }
1732  if (fd >= 0)
1733   {
1734    PerlIOUnix *s;
1735    if (*mode == 'I')
1736     mode++;
1737    if (!f)
1738     {
1739      f = PerlIO_allocate(aTHX);
1740      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1741     }
1742    else
1743     s = PerlIOSelf(f,PerlIOUnix);
1744    s->fd     = fd;
1745    s->oflags = imode;
1746    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1747    return f;
1748   }
1749  else
1750   {
1751    if (f)
1752     {
1753      /* FIXME: pop layers ??? */
1754     }
1755    return NULL;
1756   }
1757 }
1758
1759 SSize_t
1760 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1761 {
1762  dTHX;
1763  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1764  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1765   return 0;
1766  while (1)
1767   {
1768    SSize_t len = PerlLIO_read(fd,vbuf,count);
1769    if (len >= 0 || errno != EINTR)
1770     {
1771      if (len < 0)
1772       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1773      else if (len == 0 && count != 0)
1774       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1775      return len;
1776     }
1777    PERL_ASYNC_CHECK();
1778   }
1779 }
1780
1781 SSize_t
1782 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1783 {
1784  dTHX;
1785  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1786  while (1)
1787   {
1788    SSize_t len = PerlLIO_write(fd,vbuf,count);
1789    if (len >= 0 || errno != EINTR)
1790     {
1791      if (len < 0)
1792       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1793      return len;
1794     }
1795    PERL_ASYNC_CHECK();
1796   }
1797 }
1798
1799 IV
1800 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1801 {
1802  dTHX;
1803  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1804  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1805  return (new == (Off_t) -1) ? -1 : 0;
1806 }
1807
1808 Off_t
1809 PerlIOUnix_tell(PerlIO *f)
1810 {
1811  dTHX;
1812  Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1813  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1814 }
1815
1816 IV
1817 PerlIOUnix_close(PerlIO *f)
1818 {
1819  dTHX;
1820  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1821  int code = 0;
1822  while (PerlLIO_close(fd) != 0)
1823   {
1824    if (errno != EINTR)
1825     {
1826      code = -1;
1827      break;
1828     }
1829    PERL_ASYNC_CHECK();
1830   }
1831  if (code == 0)
1832   {
1833    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1834   }
1835  return code;
1836 }
1837
1838 PerlIO_funcs PerlIO_unix = {
1839  "unix",
1840  sizeof(PerlIOUnix),
1841  PERLIO_K_RAW,
1842  PerlIOUnix_pushed,
1843  PerlIOBase_noop_ok,
1844  PerlIOUnix_open,
1845  NULL,
1846  PerlIOUnix_fileno,
1847  PerlIOUnix_read,
1848  PerlIOBase_unread,
1849  PerlIOUnix_write,
1850  PerlIOUnix_seek,
1851  PerlIOUnix_tell,
1852  PerlIOUnix_close,
1853  PerlIOBase_noop_ok,   /* flush */
1854  PerlIOBase_noop_fail, /* fill */
1855  PerlIOBase_eof,
1856  PerlIOBase_error,
1857  PerlIOBase_clearerr,
1858  PerlIOBase_setlinebuf,
1859  NULL, /* get_base */
1860  NULL, /* get_bufsiz */
1861  NULL, /* get_ptr */
1862  NULL, /* get_cnt */
1863  NULL, /* set_ptrcnt */
1864 };
1865
1866 /*--------------------------------------------------------------------------------------*/
1867 /* stdio as a layer */
1868
1869 typedef struct
1870 {
1871  struct _PerlIO base;
1872  FILE *         stdio;      /* The stream */
1873 } PerlIOStdio;
1874
1875 IV
1876 PerlIOStdio_fileno(PerlIO *f)
1877 {
1878  dTHX;
1879  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1880 }
1881
1882 char *
1883 PerlIOStdio_mode(const char *mode,char *tmode)
1884 {
1885  char *ret = tmode;
1886  while (*mode)
1887   {
1888    *tmode++ = *mode++;
1889   }
1890  if (O_BINARY != O_TEXT)
1891   {
1892    *tmode++ = 'b';
1893   }
1894  *tmode = '\0';
1895  return ret;
1896 }
1897
1898 /* This isn't used yet ... */
1899 IV
1900 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1901 {
1902  dTHX;
1903  if (*PerlIONext(f))
1904   {
1905    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1906    char tmode[8];
1907    FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1908    if (stdio)
1909     s->stdio = stdio;
1910    else
1911     return -1;
1912   }
1913  return PerlIOBase_pushed(f,mode,arg);
1914 }
1915
1916 #undef PerlIO_importFILE
1917 PerlIO *
1918 PerlIO_importFILE(FILE *stdio, int fl)
1919 {
1920  dTHX;
1921  PerlIO *f = NULL;
1922  if (stdio)
1923   {
1924    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1925    s->stdio  = stdio;
1926   }
1927  return f;
1928 }
1929
1930 PerlIO *
1931 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)
1932 {
1933  char tmode[8];
1934  if (f)
1935   {
1936    char *path = SvPV_nolen(*args);
1937    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1938    FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1939    if (!s->stdio)
1940     return NULL;
1941    s->stdio = stdio;
1942    return f;
1943   }
1944  else
1945   {
1946    if (narg > 0)
1947     {
1948      char *path = SvPV_nolen(*args);
1949      if (*mode == '#')
1950       {
1951        mode++;
1952        fd = PerlLIO_open3(path,imode,perm);
1953       }
1954      else
1955       {
1956        FILE *stdio = PerlSIO_fopen(path,mode);
1957        if (stdio)
1958         {
1959          PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1960                                      (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
1961                                      PerlIOStdio);
1962          s->stdio  = stdio;
1963         }
1964        return f;
1965       }
1966     }
1967    if (fd >= 0)
1968     {
1969      FILE *stdio = NULL;
1970      int init = 0;
1971      if (*mode == 'I')
1972       {
1973        init = 1;
1974        mode++;
1975       }
1976      if (init)
1977       {
1978        switch(fd)
1979         {
1980          case 0:
1981           stdio = PerlSIO_stdin;
1982           break;
1983          case 1:
1984           stdio = PerlSIO_stdout;
1985           break;
1986          case 2:
1987           stdio = PerlSIO_stderr;
1988           break;
1989         }
1990       }
1991      else
1992       {
1993        stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1994       }
1995      if (stdio)
1996       {
1997        PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
1998        s->stdio  = stdio;
1999        return f;
2000       }
2001     }
2002   }
2003  return NULL;
2004 }
2005
2006 SSize_t
2007 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2008 {
2009  dTHX;
2010  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2011  SSize_t got = 0;
2012  if (count == 1)
2013   {
2014    STDCHAR *buf = (STDCHAR *) vbuf;
2015    /* Perl is expecting PerlIO_getc() to fill the buffer
2016     * Linux's stdio does not do that for fread()
2017     */
2018    int ch = PerlSIO_fgetc(s);
2019    if (ch != EOF)
2020     {
2021      *buf = ch;
2022      got = 1;
2023     }
2024   }
2025  else
2026   got = PerlSIO_fread(vbuf,1,count,s);
2027  return got;
2028 }
2029
2030 SSize_t
2031 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2032 {
2033  dTHX;
2034  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2035  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2036  SSize_t unread = 0;
2037  while (count > 0)
2038   {
2039    int ch = *buf-- & 0xff;
2040    if (PerlSIO_ungetc(ch,s) != ch)
2041     break;
2042    unread++;
2043    count--;
2044   }
2045  return unread;
2046 }
2047
2048 SSize_t
2049 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2050 {
2051  dTHX;
2052  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2053 }
2054
2055 IV
2056 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2057 {
2058  dTHX;
2059  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2060  return PerlSIO_fseek(stdio,offset,whence);
2061 }
2062
2063 Off_t
2064 PerlIOStdio_tell(PerlIO *f)
2065 {
2066  dTHX;
2067  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2068  return PerlSIO_ftell(stdio);
2069 }
2070
2071 IV
2072 PerlIOStdio_close(PerlIO *f)
2073 {
2074  dTHX;
2075 #ifdef HAS_SOCKS5_INIT
2076  int optval, optlen = sizeof(int);
2077 #endif
2078  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2079  return(
2080 #ifdef HAS_SOCKS5_INIT
2081    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2082        PerlSIO_fclose(stdio) :
2083        close(PerlIO_fileno(f))
2084 #else
2085    PerlSIO_fclose(stdio)
2086 #endif
2087      );
2088
2089 }
2090
2091 IV
2092 PerlIOStdio_flush(PerlIO *f)
2093 {
2094  dTHX;
2095  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2096  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2097   {
2098    return PerlSIO_fflush(stdio);
2099   }
2100  else
2101   {
2102 #if 0
2103    /* FIXME: This discards ungetc() and pre-read stuff which is
2104       not right if this is just a "sync" from a layer above
2105       Suspect right design is to do _this_ but not have layer above
2106       flush this layer read-to-read
2107     */
2108    /* Not writeable - sync by attempting a seek */
2109    int err = errno;
2110    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2111     errno = err;
2112 #endif
2113   }
2114  return 0;
2115 }
2116
2117 IV
2118 PerlIOStdio_fill(PerlIO *f)
2119 {
2120  dTHX;
2121  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2122  int c;
2123  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2124  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2125   {
2126    if (PerlSIO_fflush(stdio) != 0)
2127     return EOF;
2128   }
2129  c = PerlSIO_fgetc(stdio);
2130  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2131   return EOF;
2132  return 0;
2133 }
2134
2135 IV
2136 PerlIOStdio_eof(PerlIO *f)
2137 {
2138  dTHX;
2139  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2140 }
2141
2142 IV
2143 PerlIOStdio_error(PerlIO *f)
2144 {
2145  dTHX;
2146  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2147 }
2148
2149 void
2150 PerlIOStdio_clearerr(PerlIO *f)
2151 {
2152  dTHX;
2153  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2154 }
2155
2156 void
2157 PerlIOStdio_setlinebuf(PerlIO *f)
2158 {
2159  dTHX;
2160 #ifdef HAS_SETLINEBUF
2161  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2162 #else
2163  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2164 #endif
2165 }
2166
2167 #ifdef FILE_base
2168 STDCHAR *
2169 PerlIOStdio_get_base(PerlIO *f)
2170 {
2171  dTHX;
2172  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2173  return PerlSIO_get_base(stdio);
2174 }
2175
2176 Size_t
2177 PerlIOStdio_get_bufsiz(PerlIO *f)
2178 {
2179  dTHX;
2180  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2181  return PerlSIO_get_bufsiz(stdio);
2182 }
2183 #endif
2184
2185 #ifdef USE_STDIO_PTR
2186 STDCHAR *
2187 PerlIOStdio_get_ptr(PerlIO *f)
2188 {
2189  dTHX;
2190  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2191  return PerlSIO_get_ptr(stdio);
2192 }
2193
2194 SSize_t
2195 PerlIOStdio_get_cnt(PerlIO *f)
2196 {
2197  dTHX;
2198  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2199  return PerlSIO_get_cnt(stdio);
2200 }
2201
2202 void
2203 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2204 {
2205  dTHX;
2206  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2207  if (ptr != NULL)
2208   {
2209 #ifdef STDIO_PTR_LVALUE
2210    PerlSIO_set_ptr(stdio,ptr);
2211 #ifdef STDIO_PTR_LVAL_SETS_CNT
2212    if (PerlSIO_get_cnt(stdio) != (cnt))
2213     {
2214      dTHX;
2215      assert(PerlSIO_get_cnt(stdio) == (cnt));
2216     }
2217 #endif
2218 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2219    /* Setting ptr _does_ change cnt - we are done */
2220    return;
2221 #endif
2222 #else  /* STDIO_PTR_LVALUE */
2223    PerlProc_abort();
2224 #endif /* STDIO_PTR_LVALUE */
2225   }
2226 /* Now (or only) set cnt */
2227 #ifdef STDIO_CNT_LVALUE
2228  PerlSIO_set_cnt(stdio,cnt);
2229 #else  /* STDIO_CNT_LVALUE */
2230 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2231  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2232 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2233  PerlProc_abort();
2234 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2235 #endif /* STDIO_CNT_LVALUE */
2236 }
2237
2238 #endif
2239
2240 PerlIO_funcs PerlIO_stdio = {
2241  "stdio",
2242  sizeof(PerlIOStdio),
2243  PERLIO_K_BUFFERED,
2244  PerlIOBase_pushed,
2245  PerlIOBase_noop_ok,
2246  PerlIOStdio_open,
2247  NULL,
2248  PerlIOStdio_fileno,
2249  PerlIOStdio_read,
2250  PerlIOStdio_unread,
2251  PerlIOStdio_write,
2252  PerlIOStdio_seek,
2253  PerlIOStdio_tell,
2254  PerlIOStdio_close,
2255  PerlIOStdio_flush,
2256  PerlIOStdio_fill,
2257  PerlIOStdio_eof,
2258  PerlIOStdio_error,
2259  PerlIOStdio_clearerr,
2260  PerlIOStdio_setlinebuf,
2261 #ifdef FILE_base
2262  PerlIOStdio_get_base,
2263  PerlIOStdio_get_bufsiz,
2264 #else
2265  NULL,
2266  NULL,
2267 #endif
2268 #ifdef USE_STDIO_PTR
2269  PerlIOStdio_get_ptr,
2270  PerlIOStdio_get_cnt,
2271 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2272  PerlIOStdio_set_ptrcnt
2273 #else  /* STDIO_PTR_LVALUE */
2274  NULL
2275 #endif /* STDIO_PTR_LVALUE */
2276 #else  /* USE_STDIO_PTR */
2277  NULL,
2278  NULL,
2279  NULL
2280 #endif /* USE_STDIO_PTR */
2281 };
2282
2283 #undef PerlIO_exportFILE
2284 FILE *
2285 PerlIO_exportFILE(PerlIO *f, int fl)
2286 {
2287  FILE *stdio;
2288  PerlIO_flush(f);
2289  stdio = fdopen(PerlIO_fileno(f),"r+");
2290  if (stdio)
2291   {
2292    dTHX;
2293    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2294    s->stdio  = stdio;
2295   }
2296  return stdio;
2297 }
2298
2299 #undef PerlIO_findFILE
2300 FILE *
2301 PerlIO_findFILE(PerlIO *f)
2302 {
2303  PerlIOl *l = *f;
2304  while (l)
2305   {
2306    if (l->tab == &PerlIO_stdio)
2307     {
2308      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2309      return s->stdio;
2310     }
2311    l = *PerlIONext(&l);
2312   }
2313  return PerlIO_exportFILE(f,0);
2314 }
2315
2316 #undef PerlIO_releaseFILE
2317 void
2318 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2319 {
2320 }
2321
2322 /*--------------------------------------------------------------------------------------*/
2323 /* perlio buffer layer */
2324
2325 IV
2326 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2327 {
2328  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2329  int fd  = PerlIO_fileno(f);
2330  Off_t posn;
2331  dTHX;
2332  if (fd >= 0 && PerlLIO_isatty(fd))
2333   {
2334    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2335   }
2336  posn = PerlIO_tell(PerlIONext(f));
2337  if (posn != (Off_t) -1)
2338   {
2339    b->posn = posn;
2340   }
2341  return PerlIOBase_pushed(f,mode,arg);
2342 }
2343
2344 PerlIO *
2345 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)
2346 {
2347  if (f)
2348   {
2349    PerlIO *next = PerlIONext(f);
2350    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2351    next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2352    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2353     {
2354      return NULL;
2355     }
2356   }
2357  else
2358   {
2359    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2360    int init = 0;
2361    if (*mode == 'I')
2362     {
2363      init = 1;
2364      mode++;
2365     }
2366    f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2367    if (f)
2368     {
2369      PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2370      fd = PerlIO_fileno(f);
2371 #if O_BINARY != O_TEXT
2372      /* do something about failing setmode()? --jhi */
2373      PerlLIO_setmode(fd , O_BINARY);
2374 #endif
2375      if (init && fd == 2)
2376       {
2377        /* Initial stderr is unbuffered */
2378        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2379       }
2380     }
2381   }
2382  return f;
2383 }
2384
2385 /* This "flush" is akin to sfio's sync in that it handles files in either
2386    read or write state
2387 */
2388 IV
2389 PerlIOBuf_flush(PerlIO *f)
2390 {
2391  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2392  int code = 0;
2393  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2394   {
2395    /* write() the buffer */
2396    STDCHAR *buf = b->buf;
2397    STDCHAR *p = buf;
2398    PerlIO *n = PerlIONext(f);
2399    while (p < b->ptr)
2400     {
2401      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2402      if (count > 0)
2403       {
2404        p += count;
2405       }
2406      else if (count < 0 || PerlIO_error(n))
2407       {
2408        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2409        code = -1;
2410        break;
2411       }
2412     }
2413    b->posn += (p - buf);
2414   }
2415  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2416   {
2417    STDCHAR *buf = PerlIO_get_base(f);
2418    /* Note position change */
2419    b->posn += (b->ptr - buf);
2420    if (b->ptr < b->end)
2421     {
2422      /* We did not consume all of it */
2423      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2424       {
2425        b->posn = PerlIO_tell(PerlIONext(f));
2426       }
2427     }
2428   }
2429  b->ptr = b->end = b->buf;
2430  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2431  /* FIXME: Is this right for read case ? */
2432  if (PerlIO_flush(PerlIONext(f)) != 0)
2433   code = -1;
2434  return code;
2435 }
2436
2437 IV
2438 PerlIOBuf_fill(PerlIO *f)
2439 {
2440  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2441  PerlIO *n = PerlIONext(f);
2442  SSize_t avail;
2443  /* FIXME: doing the down-stream flush is a bad idea if it causes
2444     pre-read data in stdio buffer to be discarded
2445     but this is too simplistic - as it skips _our_ hosekeeping
2446     and breaks tell tests.
2447  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2448   {
2449   }
2450   */
2451  if (PerlIO_flush(f) != 0)
2452   return -1;
2453
2454  if (!b->buf)
2455   PerlIO_get_base(f); /* allocate via vtable */
2456
2457  b->ptr = b->end = b->buf;
2458  if (PerlIO_fast_gets(n))
2459   {
2460    /* Layer below is also buffered
2461     * We do _NOT_ want to call its ->Read() because that will loop
2462     * till it gets what we asked for which may hang on a pipe etc.
2463     * Instead take anything it has to hand, or ask it to fill _once_.
2464     */
2465    avail  = PerlIO_get_cnt(n);
2466    if (avail <= 0)
2467     {
2468      avail = PerlIO_fill(n);
2469      if (avail == 0)
2470       avail = PerlIO_get_cnt(n);
2471      else
2472       {
2473        if (!PerlIO_error(n) && PerlIO_eof(n))
2474         avail = 0;
2475       }
2476     }
2477    if (avail > 0)
2478     {
2479      STDCHAR *ptr = PerlIO_get_ptr(n);
2480      SSize_t cnt  = avail;
2481      if (avail > b->bufsiz)
2482       avail = b->bufsiz;
2483      Copy(ptr,b->buf,avail,STDCHAR);
2484      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2485     }
2486   }
2487  else
2488   {
2489    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2490   }
2491  if (avail <= 0)
2492   {
2493    if (avail == 0)
2494     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2495    else
2496     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2497    return -1;
2498   }
2499  b->end      = b->buf+avail;
2500  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2501  return 0;
2502 }
2503
2504 SSize_t
2505 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2506 {
2507  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2508  if (f)
2509   {
2510    if (!b->ptr)
2511     PerlIO_get_base(f);
2512    return PerlIOBase_read(f,vbuf,count);
2513   }
2514  return 0;
2515 }
2516
2517 SSize_t
2518 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2519 {
2520  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2521  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2522  SSize_t unread = 0;
2523  SSize_t avail;
2524  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2525   PerlIO_flush(f);
2526  if (!b->buf)
2527   PerlIO_get_base(f);
2528  if (b->buf)
2529   {
2530    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2531     {
2532      avail = (b->ptr - b->buf);
2533     }
2534    else
2535     {
2536      avail = b->bufsiz;
2537      b->end = b->buf + avail;
2538      b->ptr = b->end;
2539      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2540      b->posn -= b->bufsiz;
2541     }
2542    if (avail > (SSize_t) count)
2543     avail = count;
2544    if (avail > 0)
2545     {
2546      b->ptr -= avail;
2547      buf    -= avail;
2548      if (buf != b->ptr)
2549       {
2550        Copy(buf,b->ptr,avail,STDCHAR);
2551       }
2552      count  -= avail;
2553      unread += avail;
2554      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2555     }
2556   }
2557  return unread;
2558 }
2559
2560 SSize_t
2561 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2562 {
2563  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2564  const STDCHAR *buf = (const STDCHAR *) vbuf;
2565  Size_t written = 0;
2566  if (!b->buf)
2567   PerlIO_get_base(f);
2568  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2569   return 0;
2570  while (count > 0)
2571   {
2572    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2573    if ((SSize_t) count < avail)
2574     avail = count;
2575    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2576    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2577     {
2578      while (avail > 0)
2579       {
2580        int ch = *buf++;
2581        *(b->ptr)++ = ch;
2582        count--;
2583        avail--;
2584        written++;
2585        if (ch == '\n')
2586         {
2587          PerlIO_flush(f);
2588          break;
2589         }
2590       }
2591     }
2592    else
2593     {
2594      if (avail)
2595       {
2596        Copy(buf,b->ptr,avail,STDCHAR);
2597        count   -= avail;
2598        buf     += avail;
2599        written += avail;
2600        b->ptr  += avail;
2601       }
2602     }
2603    if (b->ptr >= (b->buf + b->bufsiz))
2604     PerlIO_flush(f);
2605   }
2606  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2607   PerlIO_flush(f);
2608  return written;
2609 }
2610
2611 IV
2612 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2613 {
2614  IV code;
2615  if ((code = PerlIO_flush(f)) == 0)
2616   {
2617    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2618    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2619    code = PerlIO_seek(PerlIONext(f),offset,whence);
2620    if (code == 0)
2621     {
2622      b->posn = PerlIO_tell(PerlIONext(f));
2623     }
2624   }
2625  return code;
2626 }
2627
2628 Off_t
2629 PerlIOBuf_tell(PerlIO *f)
2630 {
2631  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2632  Off_t posn = b->posn;
2633  if (b->buf)
2634   posn += (b->ptr - b->buf);
2635  return posn;
2636 }
2637
2638 IV
2639 PerlIOBuf_close(PerlIO *f)
2640 {
2641  dTHX;
2642  IV code = PerlIOBase_close(f);
2643  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2644  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2645   {
2646    PerlMemShared_free(b->buf);
2647   }
2648  b->buf = NULL;
2649  b->ptr = b->end = b->buf;
2650  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2651  return code;
2652 }
2653
2654 STDCHAR *
2655 PerlIOBuf_get_ptr(PerlIO *f)
2656 {
2657  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2658  if (!b->buf)
2659   PerlIO_get_base(f);
2660  return b->ptr;
2661 }
2662
2663 SSize_t
2664 PerlIOBuf_get_cnt(PerlIO *f)
2665 {
2666  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2667  if (!b->buf)
2668   PerlIO_get_base(f);
2669  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2670   return (b->end - b->ptr);
2671  return 0;
2672 }
2673
2674 STDCHAR *
2675 PerlIOBuf_get_base(PerlIO *f)
2676 {
2677  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2678  if (!b->buf)
2679   {
2680    dTHX;
2681    if (!b->bufsiz)
2682     b->bufsiz = 4096;
2683    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2684    if (!b->buf)
2685     {
2686      b->buf = (STDCHAR *)&b->oneword;
2687      b->bufsiz = sizeof(b->oneword);
2688     }
2689    b->ptr = b->buf;
2690    b->end = b->ptr;
2691   }
2692  return b->buf;
2693 }
2694
2695 Size_t
2696 PerlIOBuf_bufsiz(PerlIO *f)
2697 {
2698  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2699  if (!b->buf)
2700   PerlIO_get_base(f);
2701  return (b->end - b->buf);
2702 }
2703
2704 void
2705 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2706 {
2707  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2708  if (!b->buf)
2709   PerlIO_get_base(f);
2710  b->ptr = ptr;
2711  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2712   {
2713    dTHX;
2714    assert(PerlIO_get_cnt(f) == cnt);
2715    assert(b->ptr >= b->buf);
2716   }
2717  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2718 }
2719
2720 PerlIO_funcs PerlIO_perlio = {
2721  "perlio",
2722  sizeof(PerlIOBuf),
2723  PERLIO_K_BUFFERED,
2724  PerlIOBuf_pushed,
2725  PerlIOBase_noop_ok,
2726  PerlIOBuf_open,
2727  NULL,
2728  PerlIOBase_fileno,
2729  PerlIOBuf_read,
2730  PerlIOBuf_unread,
2731  PerlIOBuf_write,
2732  PerlIOBuf_seek,
2733  PerlIOBuf_tell,
2734  PerlIOBuf_close,
2735  PerlIOBuf_flush,
2736  PerlIOBuf_fill,
2737  PerlIOBase_eof,
2738  PerlIOBase_error,
2739  PerlIOBase_clearerr,
2740  PerlIOBase_setlinebuf,
2741  PerlIOBuf_get_base,
2742  PerlIOBuf_bufsiz,
2743  PerlIOBuf_get_ptr,
2744  PerlIOBuf_get_cnt,
2745  PerlIOBuf_set_ptrcnt,
2746 };
2747
2748 /*--------------------------------------------------------------------------------------*/
2749 /* Temp layer to hold unread chars when cannot do it any other way */
2750
2751 IV
2752 PerlIOPending_fill(PerlIO *f)
2753 {
2754  /* Should never happen */
2755  PerlIO_flush(f);
2756  return 0;
2757 }
2758
2759 IV
2760 PerlIOPending_close(PerlIO *f)
2761 {
2762  /* A tad tricky - flush pops us, then we close new top */
2763  PerlIO_flush(f);
2764  return PerlIO_close(f);
2765 }
2766
2767 IV
2768 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2769 {
2770  /* A tad tricky - flush pops us, then we seek new top */
2771  PerlIO_flush(f);
2772  return PerlIO_seek(f,offset,whence);
2773 }
2774
2775
2776 IV
2777 PerlIOPending_flush(PerlIO *f)
2778 {
2779  dTHX;
2780  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2781  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2782   {
2783    PerlMemShared_free(b->buf);
2784    b->buf = NULL;
2785   }
2786  PerlIO_pop(aTHX_ f);
2787  return 0;
2788 }
2789
2790 void
2791 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2792 {
2793  if (cnt <= 0)
2794   {
2795    PerlIO_flush(f);
2796   }
2797  else
2798   {
2799    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2800   }
2801 }
2802
2803 IV
2804 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2805 {
2806  IV code    = PerlIOBase_pushed(f,mode,arg);
2807  PerlIOl *l = PerlIOBase(f);
2808  /* Our PerlIO_fast_gets must match what we are pushed on,
2809     or sv_gets() etc. get muddled when it changes mid-string
2810     when we auto-pop.
2811   */
2812  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2813               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2814  return code;
2815 }
2816
2817 SSize_t
2818 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2819 {
2820  SSize_t avail = PerlIO_get_cnt(f);
2821  SSize_t got   = 0;
2822  if (count < avail)
2823   avail = count;
2824  if (avail > 0)
2825   got = PerlIOBuf_read(f,vbuf,avail);
2826  if (got >= 0 && got < count)
2827   {
2828    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2829    if (more >= 0 || got == 0)
2830     got += more;
2831   }
2832  return got;
2833 }
2834
2835 PerlIO_funcs PerlIO_pending = {
2836  "pending",
2837  sizeof(PerlIOBuf),
2838  PERLIO_K_BUFFERED,
2839  PerlIOPending_pushed,
2840  PerlIOBase_noop_ok,
2841  NULL,
2842  NULL,
2843  PerlIOBase_fileno,
2844  PerlIOPending_read,
2845  PerlIOBuf_unread,
2846  PerlIOBuf_write,
2847  PerlIOPending_seek,
2848  PerlIOBuf_tell,
2849  PerlIOPending_close,
2850  PerlIOPending_flush,
2851  PerlIOPending_fill,
2852  PerlIOBase_eof,
2853  PerlIOBase_error,
2854  PerlIOBase_clearerr,
2855  PerlIOBase_setlinebuf,
2856  PerlIOBuf_get_base,
2857  PerlIOBuf_bufsiz,
2858  PerlIOBuf_get_ptr,
2859  PerlIOBuf_get_cnt,
2860  PerlIOPending_set_ptrcnt,
2861 };
2862
2863
2864
2865 /*--------------------------------------------------------------------------------------*/
2866 /* crlf - translation
2867    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2868    to hand back a line at a time and keeping a record of which nl we "lied" about.
2869    On write translate "\n" to CR,LF
2870  */
2871
2872 typedef struct
2873 {
2874  PerlIOBuf      base;         /* PerlIOBuf stuff */
2875  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2876 } PerlIOCrlf;
2877
2878 IV
2879 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2880 {
2881  IV code;
2882  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2883  code = PerlIOBuf_pushed(f,mode,arg);
2884 #if 0
2885  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2886               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2887               PerlIOBase(f)->flags);
2888 #endif
2889  return code;
2890 }
2891
2892
2893 SSize_t
2894 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2895 {
2896  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2897  if (c->nl)
2898   {
2899    *(c->nl) = 0xd;
2900    c->nl = NULL;
2901   }
2902  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2903   return PerlIOBuf_unread(f,vbuf,count);
2904  else
2905   {
2906    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2907    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2908    SSize_t unread = 0;
2909    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2910     PerlIO_flush(f);
2911    if (!b->buf)
2912     PerlIO_get_base(f);
2913    if (b->buf)
2914     {
2915      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2916       {
2917        b->end = b->ptr = b->buf + b->bufsiz;
2918        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2919        b->posn -= b->bufsiz;
2920       }
2921      while (count > 0 && b->ptr > b->buf)
2922       {
2923        int ch = *--buf;
2924        if (ch == '\n')
2925         {
2926          if (b->ptr - 2 >= b->buf)
2927           {
2928            *--(b->ptr) = 0xa;
2929            *--(b->ptr) = 0xd;
2930            unread++;
2931            count--;
2932           }
2933          else
2934           {
2935            buf++;
2936            break;
2937           }
2938         }
2939        else
2940         {
2941          *--(b->ptr) = ch;
2942          unread++;
2943          count--;
2944         }
2945       }
2946     }
2947    return unread;
2948   }
2949 }
2950
2951 SSize_t
2952 PerlIOCrlf_get_cnt(PerlIO *f)
2953 {
2954  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2955  if (!b->buf)
2956   PerlIO_get_base(f);
2957  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2958   {
2959    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2960    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2961     {
2962      STDCHAR *nl   = b->ptr;
2963     scan:
2964      while (nl < b->end && *nl != 0xd)
2965       nl++;
2966      if (nl < b->end && *nl == 0xd)
2967       {
2968      test:
2969        if (nl+1 < b->end)
2970         {
2971          if (nl[1] == 0xa)
2972           {
2973            *nl   = '\n';
2974            c->nl = nl;
2975           }
2976          else
2977           {
2978            /* Not CR,LF but just CR */
2979            nl++;
2980            goto scan;
2981           }
2982         }
2983        else
2984         {
2985          /* Blast - found CR as last char in buffer */
2986          if (b->ptr < nl)
2987           {
2988            /* They may not care, defer work as long as possible */
2989            return (nl - b->ptr);
2990           }
2991          else
2992           {
2993            int code;
2994            dTHX;
2995            b->ptr++;               /* say we have read it as far as flush() is concerned */
2996            b->buf++;               /* Leave space an front of buffer */
2997            b->bufsiz--;            /* Buffer is thus smaller */
2998            code = PerlIO_fill(f);  /* Fetch some more */
2999            b->bufsiz++;            /* Restore size for next time */
3000            b->buf--;               /* Point at space */
3001            b->ptr = nl = b->buf;   /* Which is what we hand off */
3002            b->posn--;              /* Buffer starts here */
3003            *nl = 0xd;              /* Fill in the CR */
3004            if (code == 0)
3005             goto test;             /* fill() call worked */
3006            /* CR at EOF - just fall through */
3007           }
3008         }
3009       }
3010     }
3011    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3012   }
3013  return 0;
3014 }
3015
3016 void
3017 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3018 {
3019  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3020  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3021  IV flags = PerlIOBase(f)->flags;
3022  if (!b->buf)
3023   PerlIO_get_base(f);
3024  if (!ptr)
3025   {
3026    if (c->nl)
3027     ptr = c->nl+1;
3028    else
3029     {
3030      ptr = b->end;
3031      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3032       ptr--;
3033     }
3034    ptr -= cnt;
3035   }
3036  else
3037   {
3038    /* Test code - delete when it works ... */
3039    STDCHAR *chk;
3040    if (c->nl)
3041     chk = c->nl+1;
3042    else
3043     {
3044      chk = b->end;
3045      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3046       chk--;
3047     }
3048    chk -= cnt;
3049
3050    if (ptr != chk)
3051     {
3052      dTHX;
3053      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3054                 ptr, chk, flags, c->nl, b->end, cnt);
3055     }
3056   }
3057  if (c->nl)
3058   {
3059    if (ptr > c->nl)
3060     {
3061      /* They have taken what we lied about */
3062      *(c->nl) = 0xd;
3063      c->nl = NULL;
3064      ptr++;
3065     }
3066   }
3067  b->ptr = ptr;
3068  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3069 }
3070
3071 SSize_t
3072 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3073 {
3074  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3075   return PerlIOBuf_write(f,vbuf,count);
3076  else
3077   {
3078    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3079    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3080    const STDCHAR *ebuf = buf+count;
3081    if (!b->buf)
3082     PerlIO_get_base(f);
3083    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3084     return 0;
3085    while (buf < ebuf)
3086     {
3087      STDCHAR *eptr = b->buf+b->bufsiz;
3088      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3089      while (buf < ebuf && b->ptr < eptr)
3090       {
3091        if (*buf == '\n')
3092         {
3093          if ((b->ptr + 2) > eptr)
3094           {
3095            /* Not room for both */
3096            PerlIO_flush(f);
3097            break;
3098           }
3099          else
3100           {
3101            *(b->ptr)++ = 0xd; /* CR */
3102            *(b->ptr)++ = 0xa; /* LF */
3103            buf++;
3104            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3105             {
3106              PerlIO_flush(f);
3107              break;
3108             }
3109           }
3110         }
3111        else
3112         {
3113          int ch = *buf++;
3114          *(b->ptr)++ = ch;
3115         }
3116        if (b->ptr >= eptr)
3117         {
3118          PerlIO_flush(f);
3119          break;
3120         }
3121       }
3122     }
3123    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3124     PerlIO_flush(f);
3125    return (buf - (STDCHAR *) vbuf);
3126   }
3127 }
3128
3129 IV
3130 PerlIOCrlf_flush(PerlIO *f)
3131 {
3132  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3133  if (c->nl)
3134   {
3135    *(c->nl) = 0xd;
3136    c->nl = NULL;
3137   }
3138  return PerlIOBuf_flush(f);
3139 }
3140
3141 PerlIO_funcs PerlIO_crlf = {
3142  "crlf",
3143  sizeof(PerlIOCrlf),
3144  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3145  PerlIOCrlf_pushed,
3146  PerlIOBase_noop_ok,   /* popped */
3147  PerlIOBuf_open,
3148  NULL,
3149  PerlIOBase_fileno,
3150  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3151  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3152  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3153  PerlIOBuf_seek,
3154  PerlIOBuf_tell,
3155  PerlIOBuf_close,
3156  PerlIOCrlf_flush,
3157  PerlIOBuf_fill,
3158  PerlIOBase_eof,
3159  PerlIOBase_error,
3160  PerlIOBase_clearerr,
3161  PerlIOBase_setlinebuf,
3162  PerlIOBuf_get_base,
3163  PerlIOBuf_bufsiz,
3164  PerlIOBuf_get_ptr,
3165  PerlIOCrlf_get_cnt,
3166  PerlIOCrlf_set_ptrcnt,
3167 };
3168
3169 #ifdef HAS_MMAP
3170 /*--------------------------------------------------------------------------------------*/
3171 /* mmap as "buffer" layer */
3172
3173 typedef struct
3174 {
3175  PerlIOBuf      base;         /* PerlIOBuf stuff */
3176  Mmap_t         mptr;        /* Mapped address */
3177  Size_t         len;          /* mapped length */
3178  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3179 } PerlIOMmap;
3180
3181 static size_t page_size = 0;
3182
3183 IV
3184 PerlIOMmap_map(PerlIO *f)
3185 {
3186  dTHX;
3187  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3188  PerlIOBuf  *b = &m->base;
3189  IV flags = PerlIOBase(f)->flags;
3190  IV code  = 0;
3191  if (m->len)
3192   abort();
3193  if (flags & PERLIO_F_CANREAD)
3194   {
3195    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3196    int fd   = PerlIO_fileno(f);
3197    struct stat st;
3198    code = fstat(fd,&st);
3199    if (code == 0 && S_ISREG(st.st_mode))
3200     {
3201      SSize_t len = st.st_size - b->posn;
3202      if (len > 0)
3203       {
3204        Off_t posn;
3205        if (!page_size) {
3206 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3207            {
3208                SETERRNO(0,SS$_NORMAL);
3209 #   ifdef _SC_PAGESIZE
3210                page_size = sysconf(_SC_PAGESIZE);
3211 #   else
3212                page_size = sysconf(_SC_PAGE_SIZE);
3213 #   endif
3214                if ((long)page_size < 0) {
3215                    if (errno) {
3216                        SV *error = ERRSV;
3217                        char *msg;
3218                        STRLEN n_a;
3219                        (void)SvUPGRADE(error, SVt_PV);
3220                        msg = SvPVx(error, n_a);
3221                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3222                    }
3223                    else
3224                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3225                }
3226            }
3227 #else
3228 #   ifdef HAS_GETPAGESIZE
3229         page_size = getpagesize();
3230 #   else
3231 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3232         page_size = PAGESIZE; /* compiletime, bad */
3233 #       endif
3234 #   endif
3235 #endif
3236         if ((IV)page_size <= 0)
3237             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3238        }
3239        if (b->posn < 0)
3240         {
3241          /* This is a hack - should never happen - open should have set it ! */
3242          b->posn = PerlIO_tell(PerlIONext(f));
3243         }
3244        posn = (b->posn / page_size) * page_size;
3245        len  = st.st_size - posn;
3246        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3247        if (m->mptr && m->mptr != (Mmap_t) -1)
3248         {
3249 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3250          madvise(m->mptr, len, MADV_SEQUENTIAL);
3251 #endif
3252 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3253          madvise(m->mptr, len, MADV_WILLNEED);
3254 #endif
3255          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3256          b->end  = ((STDCHAR *)m->mptr) + len;
3257          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3258          b->ptr  = b->buf;
3259          m->len  = len;
3260         }
3261        else
3262         {
3263          b->buf = NULL;
3264         }
3265       }
3266      else
3267       {
3268        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3269        b->buf = NULL;
3270        b->ptr = b->end = b->ptr;
3271        code = -1;
3272       }
3273     }
3274   }
3275  return code;
3276 }
3277
3278 IV
3279 PerlIOMmap_unmap(PerlIO *f)
3280 {
3281  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3282  PerlIOBuf  *b = &m->base;
3283  IV code = 0;
3284  if (m->len)
3285   {
3286    if (b->buf)
3287     {
3288      code = munmap(m->mptr, m->len);
3289      b->buf  = NULL;
3290      m->len  = 0;
3291      m->mptr = NULL;
3292      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3293       code = -1;
3294     }
3295    b->ptr = b->end = b->buf;
3296    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3297   }
3298  return code;
3299 }
3300
3301 STDCHAR *
3302 PerlIOMmap_get_base(PerlIO *f)
3303 {
3304  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3305  PerlIOBuf  *b = &m->base;
3306  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3307   {
3308    /* Already have a readbuffer in progress */
3309    return b->buf;
3310   }
3311  if (b->buf)
3312   {
3313    /* We have a write buffer or flushed PerlIOBuf read buffer */
3314    m->bbuf = b->buf;  /* save it in case we need it again */
3315    b->buf  = NULL;    /* Clear to trigger below */
3316   }
3317  if (!b->buf)
3318   {
3319    PerlIOMmap_map(f);     /* Try and map it */
3320    if (!b->buf)
3321     {
3322      /* Map did not work - recover PerlIOBuf buffer if we have one */
3323      b->buf = m->bbuf;
3324     }
3325   }
3326  b->ptr  = b->end = b->buf;
3327  if (b->buf)
3328   return b->buf;
3329  return PerlIOBuf_get_base(f);
3330 }
3331
3332 SSize_t
3333 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3334 {
3335  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3336  PerlIOBuf  *b = &m->base;
3337  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3338   PerlIO_flush(f);
3339  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3340   {
3341    b->ptr -= count;
3342    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3343    return count;
3344   }
3345  if (m->len)
3346   {
3347    /* Loose the unwritable mapped buffer */
3348    PerlIO_flush(f);
3349    /* If flush took the "buffer" see if we have one from before */
3350    if (!b->buf && m->bbuf)
3351     b->buf = m->bbuf;
3352    if (!b->buf)
3353     {
3354      PerlIOBuf_get_base(f);
3355      m->bbuf = b->buf;
3356     }
3357   }
3358 return PerlIOBuf_unread(f,vbuf,count);
3359 }
3360
3361 SSize_t
3362 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3363 {
3364  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3365  PerlIOBuf  *b = &m->base;
3366  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3367   {
3368    /* No, or wrong sort of, buffer */
3369    if (m->len)
3370     {
3371      if (PerlIOMmap_unmap(f) != 0)
3372       return 0;
3373     }
3374    /* If unmap took the "buffer" see if we have one from before */
3375    if (!b->buf && m->bbuf)
3376     b->buf = m->bbuf;
3377    if (!b->buf)
3378     {
3379      PerlIOBuf_get_base(f);
3380      m->bbuf = b->buf;
3381     }
3382   }
3383  return PerlIOBuf_write(f,vbuf,count);
3384 }
3385
3386 IV
3387 PerlIOMmap_flush(PerlIO *f)
3388 {
3389  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3390  PerlIOBuf  *b = &m->base;
3391  IV code = PerlIOBuf_flush(f);
3392  /* Now we are "synced" at PerlIOBuf level */
3393  if (b->buf)
3394   {
3395    if (m->len)
3396     {
3397      /* Unmap the buffer */
3398      if (PerlIOMmap_unmap(f) != 0)
3399       code = -1;
3400     }
3401    else
3402     {
3403      /* We seem to have a PerlIOBuf buffer which was not mapped
3404       * remember it in case we need one later
3405       */
3406      m->bbuf = b->buf;
3407     }
3408   }
3409  return code;
3410 }
3411
3412 IV
3413 PerlIOMmap_fill(PerlIO *f)
3414 {
3415  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3416  IV code = PerlIO_flush(f);
3417  if (code == 0 && !b->buf)
3418   {
3419    code = PerlIOMmap_map(f);
3420   }
3421  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3422   {
3423    code = PerlIOBuf_fill(f);
3424   }
3425  return code;
3426 }
3427
3428 IV
3429 PerlIOMmap_close(PerlIO *f)
3430 {
3431  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3432  PerlIOBuf  *b = &m->base;
3433  IV code = PerlIO_flush(f);
3434  if (m->bbuf)
3435   {
3436    b->buf  = m->bbuf;
3437    m->bbuf = NULL;
3438    b->ptr  = b->end = b->buf;
3439   }
3440  if (PerlIOBuf_close(f) != 0)
3441   code = -1;
3442  return code;
3443 }
3444
3445
3446 PerlIO_funcs PerlIO_mmap = {
3447  "mmap",
3448  sizeof(PerlIOMmap),
3449  PERLIO_K_BUFFERED,
3450  PerlIOBuf_pushed,
3451  PerlIOBase_noop_ok,
3452  PerlIOBuf_open,
3453  NULL,
3454  PerlIOBase_fileno,
3455  PerlIOBuf_read,
3456  PerlIOMmap_unread,
3457  PerlIOMmap_write,
3458  PerlIOBuf_seek,
3459  PerlIOBuf_tell,
3460  PerlIOBuf_close,
3461  PerlIOMmap_flush,
3462  PerlIOMmap_fill,
3463  PerlIOBase_eof,
3464  PerlIOBase_error,
3465  PerlIOBase_clearerr,
3466  PerlIOBase_setlinebuf,
3467  PerlIOMmap_get_base,
3468  PerlIOBuf_bufsiz,
3469  PerlIOBuf_get_ptr,
3470  PerlIOBuf_get_cnt,
3471  PerlIOBuf_set_ptrcnt,
3472 };
3473
3474 #endif /* HAS_MMAP */
3475
3476 void
3477 PerlIO_init(void)
3478 {
3479  if (!_perlio)
3480   {
3481 #ifndef WIN32
3482    atexit(&PerlIO_cleanup);
3483 #endif
3484   }
3485 }
3486
3487 #undef PerlIO_stdin
3488 PerlIO *
3489 PerlIO_stdin(void)
3490 {
3491  if (!_perlio)
3492   {
3493    dTHX;
3494    PerlIO_stdstreams(aTHX);
3495   }
3496  return &_perlio[1];
3497 }
3498
3499 #undef PerlIO_stdout
3500 PerlIO *
3501 PerlIO_stdout(void)
3502 {
3503  if (!_perlio)
3504   {
3505    dTHX;
3506    PerlIO_stdstreams(aTHX);
3507   }
3508  return &_perlio[2];
3509 }
3510
3511 #undef PerlIO_stderr
3512 PerlIO *
3513 PerlIO_stderr(void)
3514 {
3515  if (!_perlio)
3516   {
3517    dTHX;
3518    PerlIO_stdstreams(aTHX);
3519   }
3520  return &_perlio[3];
3521 }
3522
3523 /*--------------------------------------------------------------------------------------*/
3524
3525 #undef PerlIO_getname
3526 char *
3527 PerlIO_getname(PerlIO *f, char *buf)
3528 {
3529  dTHX;
3530  Perl_croak(aTHX_ "Don't know how to get file name");
3531  return NULL;
3532 }
3533
3534
3535 /*--------------------------------------------------------------------------------------*/
3536 /* Functions which can be called on any kind of PerlIO implemented
3537    in terms of above
3538 */
3539
3540 #undef PerlIO_getc
3541 int
3542 PerlIO_getc(PerlIO *f)
3543 {
3544  STDCHAR buf[1];
3545  SSize_t count = PerlIO_read(f,buf,1);
3546  if (count == 1)
3547   {
3548    return (unsigned char) buf[0];
3549   }
3550  return EOF;
3551 }
3552
3553 #undef PerlIO_ungetc
3554 int
3555 PerlIO_ungetc(PerlIO *f, int ch)
3556 {
3557  if (ch != EOF)
3558   {
3559    STDCHAR buf = ch;
3560    if (PerlIO_unread(f,&buf,1) == 1)
3561     return ch;
3562   }
3563  return EOF;
3564 }
3565
3566 #undef PerlIO_putc
3567 int
3568 PerlIO_putc(PerlIO *f, int ch)
3569 {
3570  STDCHAR buf = ch;
3571  return PerlIO_write(f,&buf,1);
3572 }
3573
3574 #undef PerlIO_puts
3575 int
3576 PerlIO_puts(PerlIO *f, const char *s)
3577 {
3578  STRLEN len = strlen(s);
3579  return PerlIO_write(f,s,len);
3580 }
3581
3582 #undef PerlIO_rewind
3583 void
3584 PerlIO_rewind(PerlIO *f)
3585 {
3586  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3587  PerlIO_clearerr(f);
3588 }
3589
3590 #undef PerlIO_vprintf
3591 int
3592 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3593 {
3594  dTHX;
3595  SV *sv = newSVpvn("",0);
3596  char *s;
3597  STRLEN len;
3598  SSize_t wrote;
3599 #ifdef NEED_VA_COPY
3600  va_list apc;
3601  Perl_va_copy(ap, apc);
3602  sv_vcatpvf(sv, fmt, &apc);
3603 #else
3604  sv_vcatpvf(sv, fmt, &ap);
3605 #endif
3606  s = SvPV(sv,len);
3607  wrote = PerlIO_write(f,s,len);
3608  SvREFCNT_dec(sv);
3609  return wrote;
3610 }
3611
3612 #undef PerlIO_printf
3613 int
3614 PerlIO_printf(PerlIO *f,const char *fmt,...)
3615 {
3616  va_list ap;
3617  int result;
3618  va_start(ap,fmt);
3619  result = PerlIO_vprintf(f,fmt,ap);
3620  va_end(ap);
3621  return result;
3622 }
3623
3624 #undef PerlIO_stdoutf
3625 int
3626 PerlIO_stdoutf(const char *fmt,...)
3627 {
3628  va_list ap;
3629  int result;
3630  va_start(ap,fmt);
3631  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3632  va_end(ap);
3633  return result;
3634 }
3635
3636 #undef PerlIO_tmpfile
3637 PerlIO *
3638 PerlIO_tmpfile(void)
3639 {
3640  /* I have no idea how portable mkstemp() is ... */
3641 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3642  dTHX;
3643  PerlIO *f = NULL;
3644  FILE *stdio = PerlSIO_tmpfile();
3645  if (stdio)
3646   {
3647    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3648    s->stdio  = stdio;
3649   }
3650  return f;
3651 #else
3652  dTHX;
3653  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3654  int fd = mkstemp(SvPVX(sv));
3655  PerlIO *f = NULL;
3656  if (fd >= 0)
3657   {
3658    f = PerlIO_fdopen(fd,"w+");
3659    if (f)
3660     {
3661      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3662     }
3663    PerlLIO_unlink(SvPVX(sv));
3664    SvREFCNT_dec(sv);
3665   }
3666  return f;
3667 #endif
3668 }
3669
3670 #undef HAS_FSETPOS
3671 #undef HAS_FGETPOS
3672
3673 #endif /* USE_SFIO */
3674 #endif /* PERLIO_IS_STDIO */
3675
3676 /*======================================================================================*/
3677 /* Now some functions in terms of above which may be needed even if
3678    we are not in true PerlIO mode
3679  */
3680
3681 #ifndef HAS_FSETPOS
3682 #undef PerlIO_setpos
3683 int
3684 PerlIO_setpos(PerlIO *f, SV *pos)
3685 {
3686  dTHX;
3687  if (SvOK(pos))
3688   {
3689    STRLEN len;
3690    Off_t *posn = (Off_t *) SvPV(pos,len);
3691    if (f && len == sizeof(Off_t))
3692     return PerlIO_seek(f,*posn,SEEK_SET);
3693   }
3694  errno = EINVAL;
3695  return -1;
3696 }
3697 #else
3698 #undef PerlIO_setpos
3699 int
3700 PerlIO_setpos(PerlIO *f, SV *pos)
3701 {
3702  dTHX;
3703  if (SvOK(pos))
3704   {
3705    STRLEN len;
3706    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3707    if (f && len == sizeof(Fpos_t))
3708     {
3709 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3710      return fsetpos64(f, fpos);
3711 #else
3712      return fsetpos(f, fpos);
3713 #endif
3714     }
3715   }
3716  errno = EINVAL;
3717  return -1;
3718 }
3719 #endif
3720
3721 #ifndef HAS_FGETPOS
3722 #undef PerlIO_getpos
3723 int
3724 PerlIO_getpos(PerlIO *f, SV *pos)
3725 {
3726  dTHX;
3727  Off_t posn = PerlIO_tell(f);
3728  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3729  return (posn == (Off_t)-1) ? -1 : 0;
3730 }
3731 #else
3732 #undef PerlIO_getpos
3733 int
3734 PerlIO_getpos(PerlIO *f, SV *pos)
3735 {
3736  dTHX;
3737  Fpos_t fpos;
3738  int code;
3739 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3740  code = fgetpos64(f, &fpos);
3741 #else
3742  code = fgetpos(f, &fpos);
3743 #endif
3744  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3745  return code;
3746 }
3747 #endif
3748
3749 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3750
3751 int
3752 vprintf(char *pat, char *args)
3753 {
3754     _doprnt(pat, args, stdout);
3755     return 0;           /* wrong, but perl doesn't use the return value */
3756 }
3757
3758 int
3759 vfprintf(FILE *fd, char *pat, char *args)
3760 {
3761     _doprnt(pat, args, fd);
3762     return 0;           /* wrong, but perl doesn't use the return value */
3763 }
3764
3765 #endif
3766
3767 #ifndef PerlIO_vsprintf
3768 int
3769 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3770 {
3771  int val = vsprintf(s, fmt, ap);
3772  if (n >= 0)
3773   {
3774    if (strlen(s) >= (STRLEN)n)
3775     {
3776      dTHX;
3777      (void)PerlIO_puts(Perl_error_log,
3778                        "panic: sprintf overflow - memory corrupted!\n");
3779      my_exit(1);
3780     }
3781   }
3782  return val;
3783 }
3784 #endif
3785
3786 #ifndef PerlIO_sprintf
3787 int
3788 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3789 {
3790  va_list ap;
3791  int result;
3792  va_start(ap,fmt);
3793  result = PerlIO_vsprintf(s, n, fmt, ap);
3794  va_end(ap);
3795  return result;
3796 }
3797 #endif
3798
3799