perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2000, 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 iperlsys.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 #if !defined(PERL_IMPLICIT_SYS)
  32
  33 #ifdef PERLIO_IS_STDIO
  34
  35 void
  36 PerlIO_init(void)
  37 {
  38  /* Does nothing (yet) except force this file to be included
  39     in perl binary. That allows this file to force inclusion
  40     of other functions that may be required by loadable
  41     extensions e.g. for FileHandle::tmpfile
  42  */
  43 }
  44
  45 #undef PerlIO_tmpfile
  46 PerlIO *
  47 PerlIO_tmpfile(void)
  48 {
  49  return tmpfile();
  50 }
  51
  52 #else /* PERLIO_IS_STDIO */
  53
  54 #ifdef USE_SFIO
  55
  56 #undef HAS_FSETPOS
  57 #undef HAS_FGETPOS
  58
  59 /* This section is just to make sure these functions
  60    get pulled in from libsfio.a
  61 */
  62
  63 #undef PerlIO_tmpfile
  64 PerlIO *
  65 PerlIO_tmpfile(void)
  66 {
  67  return sftmp(0);
  68 }
  69
  70 void
  71 PerlIO_init(void)
  72 {
  73  /* Force this file to be included  in perl binary. Which allows
  74   *  this file to force inclusion  of other functions that may be
  75   *  required by loadable  extensions e.g. for FileHandle::tmpfile
  76   */
  77
  78  /* Hack
  79   * sfio does its own 'autoflush' on stdout in common cases.
  80   * Flush results in a lot of lseek()s to regular files and
  81   * lot of small writes to pipes.
  82   */
  83  sfset(sfstdout,SF_SHARE,0);
  84 }
  85
  86 #else /* USE_SFIO */
  87 /*======================================================================================*/
  88 /* Implement all the PerlIO interface ourselves.
  89  */
  90
  91 #include "perliol.h"
  92
  93 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
  94 #ifdef I_UNISTD
  95 #include <unistd.h>
  96 #endif
  97 #ifdef HAS_MMAP
  98 #include <sys/mman.h>
  99 #endif
 100
 101 #include "XSUB.h"
 102
 103 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
 104
 105 void
 106 PerlIO_debug(char *fmt,...)
 107 {
 108  static int dbg = 0;
 109  if (!dbg)
 110   {
 111    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 112    if (s && *s)
 113     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 114    else
 115     dbg = -1;
 116   }
 117  if (dbg > 0)
 118   {
 119    dTHX;
 120    va_list ap;
 121    SV *sv = newSVpvn("",0);
 122    char *s;
 123    STRLEN len;
 124    va_start(ap,fmt);
 125    s = CopFILE(PL_curcop);
 126    if (!s)
 127     s = "(none)";
 128    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 129    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 130
 131    s = SvPV(sv,len);
 132    PerlLIO_write(dbg,s,len);
 133    va_end(ap);
 134    SvREFCNT_dec(sv);
 135   }
 136 }
 137
 138 /*--------------------------------------------------------------------------------------*/
 139
 140 /* Inner level routines */
 141
 142 /* Table of pointers to the PerlIO structs (malloc'ed) */
 143 PerlIO *_perlio      = NULL;
 144 #define PERLIO_TABLE_SIZE 64
 145
 146 PerlIO *
 147 PerlIO_allocate(void)
 148 {
 149  /* Find a free slot in the table, allocating new table as necessary */
 150  PerlIO **last = &_perlio;
 151  PerlIO *f;
 152  while ((f = *last))
 153   {
 154    int i;
 155    last = (PerlIO **)(f);
 156    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 157     {
 158      if (!*++f)
 159       {
 160        return f;
 161       }
 162     }
 163   }
 164  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 165  if (!f)
 166   return NULL;
 167  *last = f;
 168  return f+1;
 169 }
 170
 171 void
 172 PerlIO_cleantable(PerlIO **tablep)
 173 {
 174  PerlIO *table = *tablep;
 175  if (table)
 176   {
 177    int i;
 178    PerlIO_cleantable((PerlIO **) &(table[0]));
 179    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 180     {
 181      PerlIO *f = table+i;
 182      if (*f)
 183       PerlIO_close(f);
 184     }
 185    Safefree(table);
 186    *tablep = NULL;
 187   }
 188 }
 189
 190 HV *PerlIO_layer_hv;
 191 AV *PerlIO_layer_av;
 192
 193 void
 194 PerlIO_cleanup(void)
 195 {
 196  PerlIO_cleantable(&_perlio);
 197 }
 198
 199 void
 200 PerlIO_pop(PerlIO *f)
 201 {
 202  PerlIOl *l = *f;
 203  if (l)
 204   {
 205    (*l->tab->Popped)(f);
 206    *f = l->next;
 207    Safefree(l);
 208   }
 209 }
 210
 211 #undef PerlIO_close
 212 int
 213 PerlIO_close(PerlIO *f)
 214 {
 215  int code = (*PerlIOBase(f)->tab->Close)(f);
 216  while (*f)
 217   {
 218    PerlIO_pop(f);
 219   }
 220  return code;
 221 }
 222
 223
 224 /*--------------------------------------------------------------------------------------*/
 225 /* Given the abstraction above the public API functions */
 226
 227 #undef PerlIO_fileno
 228 int
 229 PerlIO_fileno(PerlIO *f)
 230 {
 231  return (*PerlIOBase(f)->tab->Fileno)(f);
 232 }
 233
 234 XS(XS_io_import)
 235 {
 236  dXSARGS;
 237  GV *gv = CvGV(cv);
 238  char *s = GvNAME(gv);
 239  STRLEN l = GvNAMELEN(gv);
 240  PerlIO_debug("%.*s\n",(int) l,s);
 241  XSRETURN_EMPTY;
 242 }
 243
 244 XS(XS_io_unimport)
 245 {
 246  dXSARGS;
 247  GV *gv = CvGV(cv);
 248  char *s = GvNAME(gv);
 249  STRLEN l = GvNAMELEN(gv);
 250  PerlIO_debug("%.*s\n",(int) l,s);
 251  XSRETURN_EMPTY;
 252 }
 253
 254 SV *
 255 PerlIO_find_layer(char *name, STRLEN len)
 256 {
 257  dTHX;
 258  SV **svp;
 259  SV *sv;
 260  if (len <= 0)
 261   len = strlen(name);
 262  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 263  if (svp && (sv = *svp) && SvROK(sv))
 264   return *svp;
 265  return NULL;
 266 }
 267
 268
 269 static int
 270 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 271 {
 272  if (SvROK(sv))
 273   {
 274    IO *io = GvIOn(SvRV(sv));
 275    PerlIO *ifp = IoIFP(io);
 276    PerlIO *ofp = IoOFP(io);
 277    AV *av = (AV *) mg->mg_obj;
 278    Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
 279   }
 280  return 0;
 281 }
 282
 283 static int
 284 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 285 {
 286  if (SvROK(sv))
 287   {
 288    IO *io = GvIOn(SvRV(sv));
 289    PerlIO *ifp = IoIFP(io);
 290    PerlIO *ofp = IoOFP(io);
 291    AV *av = (AV *) mg->mg_obj;
 292    Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
 293   }
 294  return 0;
 295 }
 296
 297 static int
 298 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 299 {
 300  Perl_warn(aTHX_ "clear %_",sv);
 301  return 0;
 302 }
 303
 304 static int
 305 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 306 {
 307  Perl_warn(aTHX_ "free %_",sv);
 308  return 0;
 309 }
 310
 311 MGVTBL perlio_vtab = {
 312  perlio_mg_get,
 313  perlio_mg_set,
 314  NULL, /* len */
 315  NULL,
 316  perlio_mg_free
 317 };
 318
 319 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 320 {
 321  dXSARGS;
 322  SV *sv    = SvRV(ST(1));
 323  AV *av    = newAV();
 324  MAGIC *mg;
 325  int count = 0;
 326  int i;
 327  sv_magic(sv, (SV *)av, '~', NULL, 0);
 328  SvRMAGICAL_off(sv);
 329  mg = mg_find(sv,'~');
 330  mg->mg_virtual = &perlio_vtab;
 331  mg_magical(sv);
 332  Perl_warn(aTHX_ "attrib %_",sv);
 333  for (i=2; i < items; i++)
 334   {
 335    STRLEN len;
 336    char *name = SvPV(ST(i),len);
 337    SV *layer  = PerlIO_find_layer(name,len);
 338    if (layer)
 339     {
 340      av_push(av,SvREFCNT_inc(layer));
 341     }
 342    else
 343     {
 344      ST(count) = ST(i);
 345      count++;
 346     }
 347   }
 348  SvREFCNT_dec(av);
 349  XSRETURN(count);
 350 }
 351
 352 void
 353 PerlIO_define_layer(PerlIO_funcs *tab)
 354 {
 355  dTHX;
 356  HV *stash = gv_stashpv("io::Layer", TRUE);
 357  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 358  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 359 }
 360
 361 PerlIO_funcs *
 362 PerlIO_default_layer(I32 n)
 363 {
 364  dTHX;
 365  SV **svp;
 366  SV *layer;
 367  PerlIO_funcs *tab = &PerlIO_stdio;
 368  int len;
 369  if (!PerlIO_layer_hv)
 370   {
 371    char *s  = PerlEnv_getenv("PERLIO");
 372    newXS("io::import",XS_io_import,__FILE__);
 373    newXS("io::unimport",XS_io_unimport,__FILE__);
 374    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 375    PerlIO_layer_hv = get_hv("io::layers",GV_ADD|GV_ADDMULTI);
 376    PerlIO_layer_av = get_av("io::layers",GV_ADD|GV_ADDMULTI);
 377    PerlIO_define_layer(&PerlIO_unix);
 378    PerlIO_define_layer(&PerlIO_perlio);
 379    PerlIO_define_layer(&PerlIO_stdio);
 380 #ifdef HAS_MMAP
 381    PerlIO_define_layer(&PerlIO_mmap);
 382 #endif
 383    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
 384    if (s)
 385     {
 386      while (*s)
 387       {
 388        while (*s && isSPACE((unsigned char)*s))
 389         s++;
 390        if (*s)
 391         {
 392          char *e = s;
 393          SV *layer;
 394          while (*e && !isSPACE((unsigned char)*e))
 395           e++;
 396          layer = PerlIO_find_layer(s,e-s);
 397          if (layer)
 398           {
 399            PerlIO_debug("Pushing %.*s\n",(e-s),s);
 400            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
 401           }
 402          else
 403           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 404          s = e;
 405         }
 406       }
 407     }
 408   }
 409  len  = av_len(PerlIO_layer_av);
 410  if (len < 1)
 411   {
 412    if (PerlIO_stdio.Set_ptrcnt)
 413     {
 414      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
 415     }
 416    else
 417     {
 418      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
 419     }
 420    len  = av_len(PerlIO_layer_av);
 421   }
 422  if (n < 0)
 423   n += len+1;
 424  svp = av_fetch(PerlIO_layer_av,n,0);
 425  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 426   {
 427    tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 428   }
 429  /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
 430  return tab;
 431 }
 432
 433 #define PerlIO_default_top() PerlIO_default_layer(-1)
 434 #define PerlIO_default_btm() PerlIO_default_layer(0)
 435
 436 void
 437 PerlIO_stdstreams()
 438 {
 439  if (!_perlio)
 440   {
 441    PerlIO_allocate();
 442    PerlIO_fdopen(0,"Ir");
 443    PerlIO_fdopen(1,"Iw");
 444    PerlIO_fdopen(2,"Iw");
 445   }
 446 }
 447
 448 PerlIO *
 449 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 450 {
 451  PerlIOl *l = NULL;
 452  Newc('L',l,tab->size,char,PerlIOl);
 453  if (l)
 454   {
 455    Zero(l,tab->size,char);
 456    l->next = *f;
 457    l->tab  = tab;
 458    *f      = l;
 459    if ((*l->tab->Pushed)(f,mode) != 0)
 460     {
 461      PerlIO_pop(f);
 462      return NULL;
 463     }
 464   }
 465  return f;
 466 }
 467
 468 #undef PerlIO_fdopen
 469 PerlIO *
 470 PerlIO_fdopen(int fd, const char *mode)
 471 {
 472  PerlIO_funcs *tab = PerlIO_default_top();
 473  if (!_perlio)
 474   PerlIO_stdstreams();
 475  return (*tab->Fdopen)(tab,fd,mode);
 476 }
 477
 478 #undef PerlIO_open
 479 PerlIO *
 480 PerlIO_open(const char *path, const char *mode)
 481 {
 482  PerlIO_funcs *tab = PerlIO_default_top();
 483  if (!_perlio)
 484   PerlIO_stdstreams();
 485  return (*tab->Open)(tab,path,mode);
 486 }
 487
 488 #undef PerlIO_reopen
 489 PerlIO *
 490 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 491 {
 492  if (f)
 493   {
 494    PerlIO_flush(f);
 495    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 496     {
 497      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 498       return f;
 499     }
 500    return NULL;
 501   }
 502  else
 503   return PerlIO_open(path,mode);
 504 }
 505
 506 #undef PerlIO_read
 507 SSize_t
 508 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 509 {
 510  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 511 }
 512
 513 #undef PerlIO_unread
 514 SSize_t
 515 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 516 {
 517  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 518 }
 519
 520 #undef PerlIO_write
 521 SSize_t
 522 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 523 {
 524  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 525 }
 526
 527 #undef PerlIO_seek
 528 int
 529 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 530 {
 531  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 532 }
 533
 534 #undef PerlIO_tell
 535 Off_t
 536 PerlIO_tell(PerlIO *f)
 537 {
 538  return (*PerlIOBase(f)->tab->Tell)(f);
 539 }
 540
 541 #undef PerlIO_flush
 542 int
 543 PerlIO_flush(PerlIO *f)
 544 {
 545  if (f)
 546   {
 547    return (*PerlIOBase(f)->tab->Flush)(f);
 548   }
 549  else
 550   {
 551    PerlIO **table = &_perlio;
 552    int code = 0;
 553    while ((f = *table))
 554     {
 555      int i;
 556      table = (PerlIO **)(f++);
 557      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 558       {
 559        if (*f && PerlIO_flush(f) != 0)
 560         code = -1;
 561        f++;
 562       }
 563     }
 564    return code;
 565   }
 566 }
 567
 568 #undef PerlIO_fill
 569 int
 570 PerlIO_fill(PerlIO *f)
 571 {
 572  return (*PerlIOBase(f)->tab->Fill)(f);
 573 }
 574
 575 #undef PerlIO_isutf8
 576 int
 577 PerlIO_isutf8(PerlIO *f)
 578 {
 579  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 580 }
 581
 582 #undef PerlIO_eof
 583 int
 584 PerlIO_eof(PerlIO *f)
 585 {
 586  return (*PerlIOBase(f)->tab->Eof)(f);
 587 }
 588
 589 #undef PerlIO_error
 590 int
 591 PerlIO_error(PerlIO *f)
 592 {
 593  return (*PerlIOBase(f)->tab->Error)(f);
 594 }
 595
 596 #undef PerlIO_clearerr
 597 void
 598 PerlIO_clearerr(PerlIO *f)
 599 {
 600  (*PerlIOBase(f)->tab->Clearerr)(f);
 601 }
 602
 603 #undef PerlIO_setlinebuf
 604 void
 605 PerlIO_setlinebuf(PerlIO *f)
 606 {
 607  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 608 }
 609
 610 #undef PerlIO_has_base
 611 int
 612 PerlIO_has_base(PerlIO *f)
 613 {
 614  if (f && *f)
 615   {
 616    return (PerlIOBase(f)->tab->Get_base != NULL);
 617   }
 618  return 0;
 619 }
 620
 621 #undef PerlIO_fast_gets
 622 int
 623 PerlIO_fast_gets(PerlIO *f)
 624 {
 625  if (f && *f)
 626   {
 627    PerlIOl *l = PerlIOBase(f);
 628    return (l->tab->Set_ptrcnt != NULL);
 629   }
 630  return 0;
 631 }
 632
 633 #undef PerlIO_has_cntptr
 634 int
 635 PerlIO_has_cntptr(PerlIO *f)
 636 {
 637  if (f && *f)
 638   {
 639    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 640    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 641   }
 642  return 0;
 643 }
 644
 645 #undef PerlIO_canset_cnt
 646 int
 647 PerlIO_canset_cnt(PerlIO *f)
 648 {
 649  if (f && *f)
 650   {
 651    PerlIOl *l = PerlIOBase(f);
 652    return (l->tab->Set_ptrcnt != NULL);
 653   }
 654  return 0;
 655 }
 656
 657 #undef PerlIO_get_base
 658 STDCHAR *
 659 PerlIO_get_base(PerlIO *f)
 660 {
 661  return (*PerlIOBase(f)->tab->Get_base)(f);
 662 }
 663
 664 #undef PerlIO_get_bufsiz
 665 int
 666 PerlIO_get_bufsiz(PerlIO *f)
 667 {
 668  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 669 }
 670
 671 #undef PerlIO_get_ptr
 672 STDCHAR *
 673 PerlIO_get_ptr(PerlIO *f)
 674 {
 675  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 676 }
 677
 678 #undef PerlIO_get_cnt
 679 int
 680 PerlIO_get_cnt(PerlIO *f)
 681 {
 682  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 683 }
 684
 685 #undef PerlIO_set_cnt
 686 void
 687 PerlIO_set_cnt(PerlIO *f,int cnt)
 688 {
 689  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 690 }
 691
 692 #undef PerlIO_set_ptrcnt
 693 void
 694 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 695 {
 696  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 697 }
 698
 699 /*--------------------------------------------------------------------------------------*/
 700 /* "Methods" of the "base class" */
 701
 702 IV
 703 PerlIOBase_fileno(PerlIO *f)
 704 {
 705  return PerlIO_fileno(PerlIONext(f));
 706 }
 707
 708 IV
 709 PerlIOBase_pushed(PerlIO *f, const char *mode)
 710 {
 711  PerlIOl *l = PerlIOBase(f);
 712  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 713                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 714  if (mode)
 715   {
 716    switch (*mode++)
 717     {
 718      case 'r':
 719       l->flags = PERLIO_F_CANREAD;
 720       break;
 721      case 'a':
 722       l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 723       break;
 724      case 'w':
 725       l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 726       break;
 727      default:
 728       errno = EINVAL;
 729       return -1;
 730     }
 731    while (*mode)
 732     {
 733      switch (*mode++)
 734       {
 735        case '+':
 736         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 737         break;
 738        case 'b':
 739         l->flags |= PERLIO_F_BINARY;
 740         break;
 741       default:
 742        errno = EINVAL;
 743        return -1;
 744       }
 745     }
 746   }
 747  else
 748   {
 749    if (l->next)
 750     {
 751      l->flags |= l->next->flags &
 752                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 753                    PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 754     }
 755   }
 756  return 0;
 757 }
 758
 759 IV
 760 PerlIOBase_popped(PerlIO *f)
 761 {
 762  return 0;
 763 }
 764
 765 SSize_t
 766 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 767 {
 768  Off_t old = PerlIO_tell(f);
 769  if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 770   {
 771    Off_t new = PerlIO_tell(f);
 772    return old - new;
 773   }
 774  return 0;
 775 }
 776
 777 IV
 778 PerlIOBase_noop_ok(PerlIO *f)
 779 {
 780  return 0;
 781 }
 782
 783 IV
 784 PerlIOBase_noop_fail(PerlIO *f)
 785 {
 786  return -1;
 787 }
 788
 789 IV
 790 PerlIOBase_close(PerlIO *f)
 791 {
 792  IV code = 0;
 793  if (PerlIO_flush(f) != 0)
 794   code = -1;
 795  if (PerlIO_close(PerlIONext(f)) != 0)
 796   code = -1;
 797  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
 798  return code;
 799 }
 800
 801 IV
 802 PerlIOBase_eof(PerlIO *f)
 803 {
 804  if (f && *f)
 805   {
 806    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
 807   }
 808  return 1;
 809 }
 810
 811 IV
 812 PerlIOBase_error(PerlIO *f)
 813 {
 814  if (f && *f)
 815   {
 816    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
 817   }
 818  return 1;
 819 }
 820
 821 void
 822 PerlIOBase_clearerr(PerlIO *f)
 823 {
 824  if (f && *f)
 825   {
 826    PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
 827   }
 828 }
 829
 830 void
 831 PerlIOBase_setlinebuf(PerlIO *f)
 832 {
 833
 834 }
 835
 836 /*--------------------------------------------------------------------------------------*/
 837 /* Bottom-most level for UNIX-like case */
 838
 839 typedef struct
 840 {
 841  struct _PerlIO base;       /* The generic part */
 842  int            fd;         /* UNIX like file descriptor */
 843  int            oflags;     /* open/fcntl flags */
 844 } PerlIOUnix;
 845
 846 int
 847 PerlIOUnix_oflags(const char *mode)
 848 {
 849  int oflags = -1;
 850  switch(*mode)
 851   {
 852    case 'r':
 853     oflags = O_RDONLY;
 854     if (*++mode == '+')
 855      {
 856       oflags = O_RDWR;
 857       mode++;
 858      }
 859     break;
 860
 861    case 'w':
 862     oflags = O_CREAT|O_TRUNC;
 863     if (*++mode == '+')
 864      {
 865       oflags |= O_RDWR;
 866       mode++;
 867      }
 868     else
 869      oflags |= O_WRONLY;
 870     break;
 871
 872    case 'a':
 873     oflags = O_CREAT|O_APPEND;
 874     if (*++mode == '+')
 875      {
 876       oflags |= O_RDWR;
 877       mode++;
 878      }
 879     else
 880      oflags |= O_WRONLY;
 881     break;
 882   }
 883  if (*mode || oflags == -1)
 884   {
 885    errno = EINVAL;
 886    oflags = -1;
 887   }
 888  return oflags;
 889 }
 890
 891 IV
 892 PerlIOUnix_fileno(PerlIO *f)
 893 {
 894  return PerlIOSelf(f,PerlIOUnix)->fd;
 895 }
 896
 897 PerlIO *
 898 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 899 {
 900  PerlIO *f = NULL;
 901  if (*mode == 'I')
 902   mode++;
 903  if (fd >= 0)
 904   {
 905    int oflags = PerlIOUnix_oflags(mode);
 906    if (oflags != -1)
 907     {
 908      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 909      s->fd     = fd;
 910      s->oflags = oflags;
 911      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 912     }
 913   }
 914  return f;
 915 }
 916
 917 PerlIO *
 918 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
 919 {
 920  PerlIO *f = NULL;
 921  int oflags = PerlIOUnix_oflags(mode);
 922  if (oflags != -1)
 923   {
 924    int fd = PerlLIO_open3(path,oflags,0666);
 925    if (fd >= 0)
 926     {
 927      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 928      s->fd     = fd;
 929      s->oflags = oflags;
 930      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 931     }
 932   }
 933  return f;
 934 }
 935
 936 int
 937 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
 938 {
 939  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
 940  int oflags = PerlIOUnix_oflags(mode);
 941  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
 942   (*PerlIOBase(f)->tab->Close)(f);
 943  if (oflags != -1)
 944   {
 945    int fd = PerlLIO_open3(path,oflags,0666);
 946    if (fd >= 0)
 947     {
 948      s->fd = fd;
 949      s->oflags = oflags;
 950      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 951      return 0;
 952     }
 953   }
 954  return -1;
 955 }
 956
 957 SSize_t
 958 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
 959 {
 960  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 961  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
 962   return 0;
 963  while (1)
 964   {
 965    SSize_t len = PerlLIO_read(fd,vbuf,count);
 966    if (len >= 0 || errno != EINTR)
 967     {
 968      if (len < 0)
 969       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 970      else if (len == 0 && count != 0)
 971       PerlIOBase(f)->flags |= PERLIO_F_EOF;
 972      return len;
 973     }
 974   }
 975 }
 976
 977 SSize_t
 978 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
 979 {
 980  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 981  while (1)
 982   {
 983    SSize_t len = PerlLIO_write(fd,vbuf,count);
 984    if (len >= 0 || errno != EINTR)
 985     {
 986      if (len < 0)
 987       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 988      return len;
 989     }
 990   }
 991 }
 992
 993 IV
 994 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
 995 {
 996  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
 997  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
 998  return (new == (Off_t) -1) ? -1 : 0;
 999 }
1000
1001 Off_t
1002 PerlIOUnix_tell(PerlIO *f)
1003 {
1004  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1005 }
1006
1007 IV
1008 PerlIOUnix_close(PerlIO *f)
1009 {
1010  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1011  int code = 0;
1012  while (PerlLIO_close(fd) != 0)
1013   {
1014    if (errno != EINTR)
1015     {
1016      code = -1;
1017      break;
1018     }
1019   }
1020  if (code == 0)
1021   {
1022    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1023   }
1024  return code;
1025 }
1026
1027 PerlIO_funcs PerlIO_unix = {
1028  "unix",
1029  sizeof(PerlIOUnix),
1030  0,
1031  PerlIOUnix_fileno,
1032  PerlIOUnix_fdopen,
1033  PerlIOUnix_open,
1034  PerlIOUnix_reopen,
1035  PerlIOBase_pushed,
1036  PerlIOBase_noop_ok,
1037  PerlIOUnix_read,
1038  PerlIOBase_unread,
1039  PerlIOUnix_write,
1040  PerlIOUnix_seek,
1041  PerlIOUnix_tell,
1042  PerlIOUnix_close,
1043  PerlIOBase_noop_ok,   /* flush */
1044  PerlIOBase_noop_fail, /* fill */
1045  PerlIOBase_eof,
1046  PerlIOBase_error,
1047  PerlIOBase_clearerr,
1048  PerlIOBase_setlinebuf,
1049  NULL, /* get_base */
1050  NULL, /* get_bufsiz */
1051  NULL, /* get_ptr */
1052  NULL, /* get_cnt */
1053  NULL, /* set_ptrcnt */
1054 };
1055
1056 /*--------------------------------------------------------------------------------------*/
1057 /* stdio as a layer */
1058
1059 typedef struct
1060 {
1061  struct _PerlIO base;
1062  FILE *         stdio;      /* The stream */
1063 } PerlIOStdio;
1064
1065 IV
1066 PerlIOStdio_fileno(PerlIO *f)
1067 {
1068  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1069 }
1070
1071
1072 PerlIO *
1073 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1074 {
1075  PerlIO *f = NULL;
1076  int init = 0;
1077  if (*mode == 'I')
1078   {
1079    init = 1;
1080    mode++;
1081   }
1082  if (fd >= 0)
1083   {
1084    FILE *stdio = NULL;
1085    if (init)
1086     {
1087      switch(fd)
1088       {
1089        case 0:
1090         stdio = stdin;
1091         break;
1092        case 1:
1093         stdio = stdout;
1094         break;
1095        case 2:
1096         stdio = stderr;
1097         break;
1098       }
1099     }
1100    else
1101     stdio = fdopen(fd,mode);
1102    if (stdio)
1103     {
1104      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1105      s->stdio  = stdio;
1106     }
1107   }
1108  return f;
1109 }
1110
1111 #undef PerlIO_importFILE
1112 PerlIO *
1113 PerlIO_importFILE(FILE *stdio, int fl)
1114 {
1115  PerlIO *f = NULL;
1116  if (stdio)
1117   {
1118    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1119    s->stdio  = stdio;
1120   }
1121  return f;
1122 }
1123
1124 PerlIO *
1125 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1126 {
1127  PerlIO *f = NULL;
1128  FILE *stdio = fopen(path,mode);
1129  if (stdio)
1130   {
1131    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1132    s->stdio  = stdio;
1133   }
1134  return f;
1135 }
1136
1137 int
1138 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1139 {
1140  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1141  FILE *stdio = freopen(path,mode,s->stdio);
1142  if (!s->stdio)
1143   return -1;
1144  s->stdio = stdio;
1145  return 0;
1146 }
1147
1148 SSize_t
1149 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1150 {
1151  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1152  SSize_t got = 0;
1153  if (count == 1)
1154   {
1155    STDCHAR *buf = (STDCHAR *) vbuf;
1156    /* Perl is expecting PerlIO_getc() to fill the buffer
1157     * Linux's stdio does not do that for fread()
1158     */
1159    int ch = fgetc(s);
1160    if (ch != EOF)
1161     {
1162      *buf = ch;
1163      got = 1;
1164     }
1165   }
1166  else
1167   got = fread(vbuf,1,count,s);
1168  return got;
1169 }
1170
1171 SSize_t
1172 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1173 {
1174  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1175  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1176  SSize_t unread = 0;
1177  while (count > 0)
1178   {
1179    int ch = *buf-- & 0xff;
1180    if (ungetc(ch,s) != ch)
1181     break;
1182    unread++;
1183    count--;
1184   }
1185  return unread;
1186 }
1187
1188 SSize_t
1189 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1190 {
1191  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1192 }
1193
1194 IV
1195 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1196 {
1197  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1198  return fseek(stdio,offset,whence);
1199 }
1200
1201 Off_t
1202 PerlIOStdio_tell(PerlIO *f)
1203 {
1204  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1205  return ftell(stdio);
1206 }
1207
1208 IV
1209 PerlIOStdio_close(PerlIO *f)
1210 {
1211  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1212 }
1213
1214 IV
1215 PerlIOStdio_flush(PerlIO *f)
1216 {
1217  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1218  return fflush(stdio);
1219 }
1220
1221 IV
1222 PerlIOStdio_fill(PerlIO *f)
1223 {
1224  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1225  int c;
1226  if (fflush(stdio) != 0)
1227   return EOF;
1228  c = fgetc(stdio);
1229  if (c == EOF || ungetc(c,stdio) != c)
1230   return EOF;
1231  return 0;
1232 }
1233
1234 IV
1235 PerlIOStdio_eof(PerlIO *f)
1236 {
1237  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1238 }
1239
1240 IV
1241 PerlIOStdio_error(PerlIO *f)
1242 {
1243  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1244 }
1245
1246 void
1247 PerlIOStdio_clearerr(PerlIO *f)
1248 {
1249  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1250 }
1251
1252 void
1253 PerlIOStdio_setlinebuf(PerlIO *f)
1254 {
1255 #ifdef HAS_SETLINEBUF
1256  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1257 #else
1258  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1259 #endif
1260 }
1261
1262 #ifdef FILE_base
1263 STDCHAR *
1264 PerlIOStdio_get_base(PerlIO *f)
1265 {
1266  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1267  return FILE_base(stdio);
1268 }
1269
1270 Size_t
1271 PerlIOStdio_get_bufsiz(PerlIO *f)
1272 {
1273  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1274  return FILE_bufsiz(stdio);
1275 }
1276 #endif
1277
1278 #ifdef USE_STDIO_PTR
1279 STDCHAR *
1280 PerlIOStdio_get_ptr(PerlIO *f)
1281 {
1282  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1283  return FILE_ptr(stdio);
1284 }
1285
1286 SSize_t
1287 PerlIOStdio_get_cnt(PerlIO *f)
1288 {
1289  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1290  return FILE_cnt(stdio);
1291 }
1292
1293 void
1294 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1295 {
1296  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1297  if (ptr != NULL)
1298   {
1299 #ifdef STDIO_PTR_LVALUE
1300    FILE_ptr(stdio) = ptr;
1301 #ifdef STDIO_PTR_LVAL_SETS_CNT
1302    if (FILE_cnt(stdio) != (cnt))
1303     {
1304      dTHX;
1305      assert(FILE_cnt(stdio) == (cnt));
1306     }
1307 #endif
1308 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1309    /* Setting ptr _does_ change cnt - we are done */
1310    return;
1311 #endif
1312 #else  /* STDIO_PTR_LVALUE */
1313    abort();
1314 #endif /* STDIO_PTR_LVALUE */
1315   }
1316 /* Now (or only) set cnt */
1317 #ifdef STDIO_CNT_LVALUE
1318  FILE_cnt(stdio) = cnt;
1319 #else  /* STDIO_CNT_LVALUE */
1320 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1321  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1322 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1323  abort();
1324 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1325 #endif /* STDIO_CNT_LVALUE */
1326 }
1327
1328 #endif
1329
1330 PerlIO_funcs PerlIO_stdio = {
1331  "stdio",
1332  sizeof(PerlIOStdio),
1333  0,
1334  PerlIOStdio_fileno,
1335  PerlIOStdio_fdopen,
1336  PerlIOStdio_open,
1337  PerlIOStdio_reopen,
1338  PerlIOBase_pushed,
1339  PerlIOBase_noop_ok,
1340  PerlIOStdio_read,
1341  PerlIOStdio_unread,
1342  PerlIOStdio_write,
1343  PerlIOStdio_seek,
1344  PerlIOStdio_tell,
1345  PerlIOStdio_close,
1346  PerlIOStdio_flush,
1347  PerlIOStdio_fill,
1348  PerlIOStdio_eof,
1349  PerlIOStdio_error,
1350  PerlIOStdio_clearerr,
1351  PerlIOStdio_setlinebuf,
1352 #ifdef FILE_base
1353  PerlIOStdio_get_base,
1354  PerlIOStdio_get_bufsiz,
1355 #else
1356  NULL,
1357  NULL,
1358 #endif
1359 #ifdef USE_STDIO_PTR
1360  PerlIOStdio_get_ptr,
1361  PerlIOStdio_get_cnt,
1362 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1363  PerlIOStdio_set_ptrcnt
1364 #else  /* STDIO_PTR_LVALUE */
1365  NULL
1366 #endif /* STDIO_PTR_LVALUE */
1367 #else  /* USE_STDIO_PTR */
1368  NULL,
1369  NULL,
1370  NULL
1371 #endif /* USE_STDIO_PTR */
1372 };
1373
1374 #undef PerlIO_exportFILE
1375 FILE *
1376 PerlIO_exportFILE(PerlIO *f, int fl)
1377 {
1378  PerlIO_flush(f);
1379  /* Should really push stdio discipline when we have them */
1380  return fdopen(PerlIO_fileno(f),"r+");
1381 }
1382
1383 #undef PerlIO_findFILE
1384 FILE *
1385 PerlIO_findFILE(PerlIO *f)
1386 {
1387  return PerlIO_exportFILE(f,0);
1388 }
1389
1390 #undef PerlIO_releaseFILE
1391 void
1392 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1393 {
1394 }
1395
1396 /*--------------------------------------------------------------------------------------*/
1397 /* perlio buffer layer */
1398
1399 PerlIO *
1400 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1401 {
1402  PerlIO_funcs *tab = PerlIO_default_btm();
1403  int init = 0;
1404  PerlIO *f;
1405  if (*mode == 'I')
1406   {
1407    init = 1;
1408    mode++;
1409   }
1410  f = (*tab->Fdopen)(tab,fd,mode);
1411  if (f)
1412   {
1413    /* Initial stderr is unbuffered */
1414    if (!init || fd != 2)
1415     {
1416      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1417      b->posn = PerlIO_tell(PerlIONext(f));
1418     }
1419   }
1420  return f;
1421 }
1422
1423 PerlIO *
1424 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1425 {
1426  PerlIO_funcs *tab = PerlIO_default_btm();
1427  PerlIO *f = (*tab->Open)(tab,path,mode);
1428  if (f)
1429   {
1430    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1431    b->posn = PerlIO_tell(PerlIONext(f));
1432   }
1433  return f;
1434 }
1435
1436 int
1437 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1438 {
1439  PerlIO *next = PerlIONext(f);
1440  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1441  if (code = 0)
1442   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1443  if (code == 0)
1444   {
1445    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1446    b->posn = PerlIO_tell(PerlIONext(f));
1447   }
1448  return code;
1449 }
1450
1451 /* This "flush" is akin to sfio's sync in that it handles files in either
1452    read or write state
1453 */
1454 IV
1455 PerlIOBuf_flush(PerlIO *f)
1456 {
1457  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1458  int code = 0;
1459  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1460   {
1461    /* write() the buffer */
1462    STDCHAR *p = b->buf;
1463    int count;
1464    while (p < b->ptr)
1465     {
1466      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1467      if (count > 0)
1468       {
1469        p += count;
1470       }
1471      else if (count < 0)
1472       {
1473        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1474        code = -1;
1475        break;
1476       }
1477     }
1478    b->posn += (p - b->buf);
1479   }
1480  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1481   {
1482    /* Note position change */
1483    b->posn += (b->ptr - b->buf);
1484    if (b->ptr < b->end)
1485     {
1486      /* We did not consume all of it */
1487      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1488       {
1489        b->posn = PerlIO_tell(PerlIONext(f));
1490       }
1491     }
1492   }
1493  b->ptr = b->end = b->buf;
1494  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1495  if (PerlIO_flush(PerlIONext(f)) != 0)
1496   code = -1;
1497  return code;
1498 }
1499
1500 IV
1501 PerlIOBuf_fill(PerlIO *f)
1502 {
1503  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1504  SSize_t avail;
1505  if (PerlIO_flush(f) != 0)
1506   return -1;
1507  b->ptr = b->end = b->buf;
1508  avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1509  if (avail <= 0)
1510   {
1511    if (avail == 0)
1512     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1513    else
1514     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1515    return -1;
1516   }
1517  b->end      = b->buf+avail;
1518  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1519  return 0;
1520 }
1521
1522 SSize_t
1523 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1524 {
1525  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1526  STDCHAR *buf = (STDCHAR *) vbuf;
1527  if (f)
1528   {
1529    Size_t got = 0;
1530    if (!b->ptr)
1531     PerlIO_get_base(f);
1532    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1533     return 0;
1534    while (count > 0)
1535     {
1536      SSize_t avail = (b->end - b->ptr);
1537      if ((SSize_t) count < avail)
1538       avail = count;
1539      if (avail > 0)
1540       {
1541        Copy(b->ptr,buf,avail,char);
1542        got     += avail;
1543        b->ptr  += avail;
1544        count   -= avail;
1545        buf     += avail;
1546       }
1547      if (count && (b->ptr >= b->end))
1548       {
1549        if (PerlIO_fill(f) != 0)
1550         break;
1551       }
1552     }
1553    return got;
1554   }
1555  return 0;
1556 }
1557
1558 SSize_t
1559 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1560 {
1561  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1562  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1563  SSize_t unread = 0;
1564  SSize_t avail;
1565  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1566   PerlIO_flush(f);
1567  if (!b->buf)
1568   PerlIO_get_base(f);
1569  if (b->buf)
1570   {
1571    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1572     {
1573      avail = (b->ptr - b->buf);
1574      if (avail > (SSize_t) count)
1575       avail = count;
1576      b->ptr -= avail;
1577     }
1578    else
1579     {
1580      avail = b->bufsiz;
1581      if (avail > (SSize_t) count)
1582       avail = count;
1583      b->end = b->ptr + avail;
1584     }
1585    if (avail > 0)
1586     {
1587      buf    -= avail;
1588      if (buf != b->ptr)
1589       {
1590        Copy(buf,b->ptr,avail,char);
1591       }
1592      count  -= avail;
1593      unread += avail;
1594      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1595     }
1596   }
1597  return unread;
1598 }
1599
1600 SSize_t
1601 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1602 {
1603  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1604  const STDCHAR *buf = (const STDCHAR *) vbuf;
1605  Size_t written = 0;
1606  if (!b->buf)
1607   PerlIO_get_base(f);
1608  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1609   return 0;
1610  while (count > 0)
1611   {
1612    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1613    if ((SSize_t) count < avail)
1614     avail = count;
1615    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1616    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1617     {
1618      while (avail > 0)
1619       {
1620        int ch = *buf++;
1621        *(b->ptr)++ = ch;
1622        count--;
1623        avail--;
1624        written++;
1625        if (ch == '\n')
1626         {
1627          PerlIO_flush(f);
1628          break;
1629         }
1630       }
1631     }
1632    else
1633     {
1634      if (avail)
1635       {
1636        Copy(buf,b->ptr,avail,char);
1637        count   -= avail;
1638        buf     += avail;
1639        written += avail;
1640        b->ptr  += avail;
1641       }
1642     }
1643    if (b->ptr >= (b->buf + b->bufsiz))
1644     PerlIO_flush(f);
1645   }
1646  return written;
1647 }
1648
1649 IV
1650 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1651 {
1652  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1653  int code = PerlIO_flush(f);
1654  if (code == 0)
1655   {
1656    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1657    code = PerlIO_seek(PerlIONext(f),offset,whence);
1658    if (code == 0)
1659     {
1660      b->posn = PerlIO_tell(PerlIONext(f));
1661     }
1662   }
1663  return code;
1664 }
1665
1666 Off_t
1667 PerlIOBuf_tell(PerlIO *f)
1668 {
1669  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1670  Off_t posn = b->posn;
1671  if (b->buf)
1672   posn += (b->ptr - b->buf);
1673  return posn;
1674 }
1675
1676 IV
1677 PerlIOBuf_close(PerlIO *f)
1678 {
1679  IV code = PerlIOBase_close(f);
1680  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1681  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1682   {
1683    Safefree(b->buf);
1684   }
1685  b->buf = NULL;
1686  b->ptr = b->end = b->buf;
1687  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1688  return code;
1689 }
1690
1691 void
1692 PerlIOBuf_setlinebuf(PerlIO *f)
1693 {
1694  if (f)
1695   {
1696    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1697   }
1698 }
1699
1700 STDCHAR *
1701 PerlIOBuf_get_ptr(PerlIO *f)
1702 {
1703  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1704  if (!b->buf)
1705   PerlIO_get_base(f);
1706  return b->ptr;
1707 }
1708
1709 SSize_t
1710 PerlIOBuf_get_cnt(PerlIO *f)
1711 {
1712  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1713  if (!b->buf)
1714   PerlIO_get_base(f);
1715  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1716   return (b->end - b->ptr);
1717  return 0;
1718 }
1719
1720 STDCHAR *
1721 PerlIOBuf_get_base(PerlIO *f)
1722 {
1723  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1724  if (!b->buf)
1725   {
1726    if (!b->bufsiz)
1727     b->bufsiz = 4096;
1728    New('B',b->buf,b->bufsiz,STDCHAR);
1729    if (!b->buf)
1730     {
1731      b->buf = (STDCHAR *)&b->oneword;
1732      b->bufsiz = sizeof(b->oneword);
1733     }
1734    b->ptr = b->buf;
1735    b->end = b->ptr;
1736   }
1737  return b->buf;
1738 }
1739
1740 Size_t
1741 PerlIOBuf_bufsiz(PerlIO *f)
1742 {
1743  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1744  if (!b->buf)
1745   PerlIO_get_base(f);
1746  return (b->end - b->buf);
1747 }
1748
1749 void
1750 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1751 {
1752  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1753  if (!b->buf)
1754   PerlIO_get_base(f);
1755  b->ptr = ptr;
1756  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1757   {
1758    dTHX;
1759    assert(PerlIO_get_cnt(f) == cnt);
1760    assert(b->ptr >= b->buf);
1761   }
1762  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1763 }
1764
1765 PerlIO_funcs PerlIO_perlio = {
1766  "perlio",
1767  sizeof(PerlIOBuf),
1768  0,
1769  PerlIOBase_fileno,
1770  PerlIOBuf_fdopen,
1771  PerlIOBuf_open,
1772  PerlIOBuf_reopen,
1773  PerlIOBase_pushed,
1774  PerlIOBase_noop_ok,
1775  PerlIOBuf_read,
1776  PerlIOBuf_unread,
1777  PerlIOBuf_write,
1778  PerlIOBuf_seek,
1779  PerlIOBuf_tell,
1780  PerlIOBuf_close,
1781  PerlIOBuf_flush,
1782  PerlIOBuf_fill,
1783  PerlIOBase_eof,
1784  PerlIOBase_error,
1785  PerlIOBase_clearerr,
1786  PerlIOBuf_setlinebuf,
1787  PerlIOBuf_get_base,
1788  PerlIOBuf_bufsiz,
1789  PerlIOBuf_get_ptr,
1790  PerlIOBuf_get_cnt,
1791  PerlIOBuf_set_ptrcnt,
1792 };
1793
1794 #ifdef HAS_MMAP
1795 /*--------------------------------------------------------------------------------------*/
1796 /* mmap as "buffer" layer */
1797
1798 typedef struct
1799 {
1800  PerlIOBuf      base;         /* PerlIOBuf stuff */
1801  Mmap_t         mptr;        /* Mapped address */
1802  Size_t         len;          /* mapped length */
1803  STDCHAR        *bbuf;        /* malloced buffer if map fails */
1804
1805 } PerlIOMmap;
1806
1807 static size_t page_size = 0;
1808
1809 IV
1810 PerlIOMmap_map(PerlIO *f)
1811 {
1812  dTHX;
1813  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1814  PerlIOBuf  *b = &m->base;
1815  IV flags = PerlIOBase(f)->flags;
1816  IV code  = 0;
1817  if (m->len)
1818   abort();
1819  if (flags & PERLIO_F_CANREAD)
1820   {
1821    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1822    int fd   = PerlIO_fileno(f);
1823    struct stat st;
1824    code = fstat(fd,&st);
1825    if (code == 0 && S_ISREG(st.st_mode))
1826     {
1827      SSize_t len = st.st_size - b->posn;
1828      if (len > 0)
1829       {
1830        Off_t posn;
1831        if (!page_size) {
1832 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1833            {
1834                SETERRNO(0,SS$_NORMAL);
1835 #   ifdef _SC_PAGESIZE
1836                page_size = sysconf(_SC_PAGESIZE);
1837 #   else
1838                page_size = sysconf(_SC_PAGE_SIZE);
1839 #   endif
1840                if ((long)page_size < 0) {
1841                    if (errno) {
1842                        SV *error = ERRSV;
1843                        char *msg;
1844                        STRLEN n_a;
1845                        (void)SvUPGRADE(error, SVt_PV);
1846                        msg = SvPVx(error, n_a);
1847                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1848                    }
1849                    else
1850                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1851                }
1852            }
1853 #else
1854 #   ifdef HAS_GETPAGESIZE
1855         page_size = getpagesize();
1856 #   else
1857 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
1858         page_size = PAGESIZE; /* compiletime, bad */
1859 #       endif
1860 #   endif
1861 #endif
1862         if ((IV)page_size <= 0)
1863             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1864        }
1865        if (b->posn < 0)
1866         {
1867          /* This is a hack - should never happen - open should have set it ! */
1868          b->posn = PerlIO_tell(PerlIONext(f));
1869         }
1870        posn = (b->posn / page_size) * page_size;
1871        len  = st.st_size - posn;
1872        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1873        if (m->mptr && m->mptr != (Mmap_t) -1)
1874         {
1875 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1876          madvise(m->mptr, len, MADV_SEQUENTIAL);
1877 #endif
1878          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1879          b->end  = ((STDCHAR *)m->mptr) + len;
1880          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
1881          b->ptr  = b->buf;
1882          m->len  = len;
1883         }
1884        else
1885         {
1886          b->buf = NULL;
1887         }
1888       }
1889      else
1890       {
1891        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1892        b->buf = NULL;
1893        b->ptr = b->end = b->ptr;
1894        code = -1;
1895       }
1896     }
1897   }
1898  return code;
1899 }
1900
1901 IV
1902 PerlIOMmap_unmap(PerlIO *f)
1903 {
1904  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1905  PerlIOBuf  *b = &m->base;
1906  IV code = 0;
1907  if (m->len)
1908   {
1909    if (b->buf)
1910     {
1911      code = munmap(m->mptr, m->len);
1912      b->buf  = NULL;
1913      m->len  = 0;
1914      m->mptr = NULL;
1915      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1916       code = -1;
1917     }
1918    b->ptr = b->end = b->buf;
1919    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1920   }
1921  return code;
1922 }
1923
1924 STDCHAR *
1925 PerlIOMmap_get_base(PerlIO *f)
1926 {
1927  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1928  PerlIOBuf  *b = &m->base;
1929  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1930   {
1931    /* Already have a readbuffer in progress */
1932    return b->buf;
1933   }
1934  if (b->buf)
1935   {
1936    /* We have a write buffer or flushed PerlIOBuf read buffer */
1937    m->bbuf = b->buf;  /* save it in case we need it again */
1938    b->buf  = NULL;    /* Clear to trigger below */
1939   }
1940  if (!b->buf)
1941   {
1942    PerlIOMmap_map(f);     /* Try and map it */
1943    if (!b->buf)
1944     {
1945      /* Map did not work - recover PerlIOBuf buffer if we have one */
1946      b->buf = m->bbuf;
1947     }
1948   }
1949  b->ptr  = b->end = b->buf;
1950  if (b->buf)
1951   return b->buf;
1952  return PerlIOBuf_get_base(f);
1953 }
1954
1955 SSize_t
1956 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1957 {
1958  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1959  PerlIOBuf  *b = &m->base;
1960  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1961   PerlIO_flush(f);
1962  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1963   {
1964    b->ptr -= count;
1965    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1966    return count;
1967   }
1968  if (m->len)
1969   {
1970    /* Loose the unwritable mapped buffer */
1971    PerlIO_flush(f);
1972    /* If flush took the "buffer" see if we have one from before */
1973    if (!b->buf && m->bbuf)
1974     b->buf = m->bbuf;
1975    if (!b->buf)
1976     {
1977      PerlIOBuf_get_base(f);
1978      m->bbuf = b->buf;
1979     }
1980   }
1981  return PerlIOBuf_unread(f,vbuf,count);
1982 }
1983
1984 SSize_t
1985 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
1986 {
1987  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1988  PerlIOBuf  *b = &m->base;
1989  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
1990   {
1991    /* No, or wrong sort of, buffer */
1992    if (m->len)
1993     {
1994      if (PerlIOMmap_unmap(f) != 0)
1995       return 0;
1996     }
1997    /* If unmap took the "buffer" see if we have one from before */
1998    if (!b->buf && m->bbuf)
1999     b->buf = m->bbuf;
2000    if (!b->buf)
2001     {
2002      PerlIOBuf_get_base(f);
2003      m->bbuf = b->buf;
2004     }
2005   }
2006  return PerlIOBuf_write(f,vbuf,count);
2007 }
2008
2009 IV
2010 PerlIOMmap_flush(PerlIO *f)
2011 {
2012  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2013  PerlIOBuf  *b = &m->base;
2014  IV code = PerlIOBuf_flush(f);
2015  /* Now we are "synced" at PerlIOBuf level */
2016  if (b->buf)
2017   {
2018    if (m->len)
2019     {
2020      /* Unmap the buffer */
2021      if (PerlIOMmap_unmap(f) != 0)
2022       code = -1;
2023     }
2024    else
2025     {
2026      /* We seem to have a PerlIOBuf buffer which was not mapped
2027       * remember it in case we need one later
2028       */
2029      m->bbuf = b->buf;
2030     }
2031   }
2032  return code;
2033 }
2034
2035 IV
2036 PerlIOMmap_fill(PerlIO *f)
2037 {
2038  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2039  IV code = PerlIO_flush(f);
2040  if (code == 0 && !b->buf)
2041   {
2042    code = PerlIOMmap_map(f);
2043   }
2044  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2045   {
2046    code = PerlIOBuf_fill(f);
2047   }
2048  return code;
2049 }
2050
2051 IV
2052 PerlIOMmap_close(PerlIO *f)
2053 {
2054  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2055  PerlIOBuf  *b = &m->base;
2056  IV code = PerlIO_flush(f);
2057  if (m->bbuf)
2058   {
2059    b->buf  = m->bbuf;
2060    m->bbuf = NULL;
2061    b->ptr  = b->end = b->buf;
2062   }
2063  if (PerlIOBuf_close(f) != 0)
2064   code = -1;
2065  return code;
2066 }
2067
2068
2069 PerlIO_funcs PerlIO_mmap = {
2070  "mmap",
2071  sizeof(PerlIOMmap),
2072  0,
2073  PerlIOBase_fileno,
2074  PerlIOBuf_fdopen,
2075  PerlIOBuf_open,
2076  PerlIOBuf_reopen,
2077  PerlIOBase_pushed,
2078  PerlIOBase_noop_ok,
2079  PerlIOBuf_read,
2080  PerlIOMmap_unread,
2081  PerlIOMmap_write,
2082  PerlIOBuf_seek,
2083  PerlIOBuf_tell,
2084  PerlIOBuf_close,
2085  PerlIOMmap_flush,
2086  PerlIOMmap_fill,
2087  PerlIOBase_eof,
2088  PerlIOBase_error,
2089  PerlIOBase_clearerr,
2090  PerlIOBuf_setlinebuf,
2091  PerlIOMmap_get_base,
2092  PerlIOBuf_bufsiz,
2093  PerlIOBuf_get_ptr,
2094  PerlIOBuf_get_cnt,
2095  PerlIOBuf_set_ptrcnt,
2096 };
2097
2098 #endif /* HAS_MMAP */
2099
2100 void
2101 PerlIO_init(void)
2102 {
2103  if (!_perlio)
2104   {
2105    atexit(&PerlIO_cleanup);
2106   }
2107 }
2108
2109 #undef PerlIO_stdin
2110 PerlIO *
2111 PerlIO_stdin(void)
2112 {
2113  if (!_perlio)
2114   PerlIO_stdstreams();
2115  return &_perlio[1];
2116 }
2117
2118 #undef PerlIO_stdout
2119 PerlIO *
2120 PerlIO_stdout(void)
2121 {
2122  if (!_perlio)
2123   PerlIO_stdstreams();
2124  return &_perlio[2];
2125 }
2126
2127 #undef PerlIO_stderr
2128 PerlIO *
2129 PerlIO_stderr(void)
2130 {
2131  if (!_perlio)
2132   PerlIO_stdstreams();
2133  return &_perlio[3];
2134 }
2135
2136 /*--------------------------------------------------------------------------------------*/
2137
2138 #undef PerlIO_getname
2139 char *
2140 PerlIO_getname(PerlIO *f, char *buf)
2141 {
2142  dTHX;
2143  Perl_croak(aTHX_ "Don't know how to get file name");
2144  return NULL;
2145 }
2146
2147
2148 /*--------------------------------------------------------------------------------------*/
2149 /* Functions which can be called on any kind of PerlIO implemented
2150    in terms of above
2151 */
2152
2153 #undef PerlIO_getc
2154 int
2155 PerlIO_getc(PerlIO *f)
2156 {
2157  STDCHAR buf[1];
2158  SSize_t count = PerlIO_read(f,buf,1);
2159  if (count == 1)
2160   {
2161    return (unsigned char) buf[0];
2162   }
2163  return EOF;
2164 }
2165
2166 #undef PerlIO_ungetc
2167 int
2168 PerlIO_ungetc(PerlIO *f, int ch)
2169 {
2170  if (ch != EOF)
2171   {
2172    STDCHAR buf = ch;
2173    if (PerlIO_unread(f,&buf,1) == 1)
2174     return ch;
2175   }
2176  return EOF;
2177 }
2178
2179 #undef PerlIO_putc
2180 int
2181 PerlIO_putc(PerlIO *f, int ch)
2182 {
2183  STDCHAR buf = ch;
2184  return PerlIO_write(f,&buf,1);
2185 }
2186
2187 #undef PerlIO_puts
2188 int
2189 PerlIO_puts(PerlIO *f, const char *s)
2190 {
2191  STRLEN len = strlen(s);
2192  return PerlIO_write(f,s,len);
2193 }
2194
2195 #undef PerlIO_rewind
2196 void
2197 PerlIO_rewind(PerlIO *f)
2198 {
2199  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2200  PerlIO_clearerr(f);
2201 }
2202
2203 #undef PerlIO_vprintf
2204 int
2205 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2206 {
2207  dTHX;
2208  SV *sv = newSVpvn("",0);
2209  char *s;
2210  STRLEN len;
2211  sv_vcatpvf(sv, fmt, &ap);
2212  s = SvPV(sv,len);
2213  return PerlIO_write(f,s,len);
2214 }
2215
2216 #undef PerlIO_printf
2217 int
2218 PerlIO_printf(PerlIO *f,const char *fmt,...)
2219 {
2220  va_list ap;
2221  int result;
2222  va_start(ap,fmt);
2223  result = PerlIO_vprintf(f,fmt,ap);
2224  va_end(ap);
2225  return result;
2226 }
2227
2228 #undef PerlIO_stdoutf
2229 int
2230 PerlIO_stdoutf(const char *fmt,...)
2231 {
2232  va_list ap;
2233  int result;
2234  va_start(ap,fmt);
2235  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2236  va_end(ap);
2237  return result;
2238 }
2239
2240 #undef PerlIO_tmpfile
2241 PerlIO *
2242 PerlIO_tmpfile(void)
2243 {
2244  dTHX;
2245  /* I have no idea how portable mkstemp() is ... */
2246  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2247  int fd = mkstemp(SvPVX(sv));
2248  PerlIO *f = NULL;
2249  if (fd >= 0)
2250   {
2251    f = PerlIO_fdopen(fd,"w+");
2252    if (f)
2253     {
2254      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2255     }
2256    PerlLIO_unlink(SvPVX(sv));
2257    SvREFCNT_dec(sv);
2258   }
2259  return f;
2260 }
2261
2262 #undef HAS_FSETPOS
2263 #undef HAS_FGETPOS
2264
2265 #endif /* USE_SFIO */
2266 #endif /* PERLIO_IS_STDIO */
2267
2268 /*======================================================================================*/
2269 /* Now some functions in terms of above which may be needed even if
2270    we are not in true PerlIO mode
2271  */
2272
2273 #ifndef HAS_FSETPOS
2274 #undef PerlIO_setpos
2275 int
2276 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2277 {
2278  return PerlIO_seek(f,*pos,0);
2279 }
2280 #else
2281 #ifndef PERLIO_IS_STDIO
2282 #undef PerlIO_setpos
2283 int
2284 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2285 {
2286 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2287  return fsetpos64(f, pos);
2288 #else
2289  return fsetpos(f, pos);
2290 #endif
2291 }
2292 #endif
2293 #endif
2294
2295 #ifndef HAS_FGETPOS
2296 #undef PerlIO_getpos
2297 int
2298 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2299 {
2300  *pos = PerlIO_tell(f);
2301  return *pos == -1 ? -1 : 0;
2302 }
2303 #else
2304 #ifndef PERLIO_IS_STDIO
2305 #undef PerlIO_getpos
2306 int
2307 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2308 {
2309 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2310  return fgetpos64(f, pos);
2311 #else
2312  return fgetpos(f, pos);
2313 #endif
2314 }
2315 #endif
2316 #endif
2317
2318 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2319
2320 int
2321 vprintf(char *pat, char *args)
2322 {
2323     _doprnt(pat, args, stdout);
2324     return 0;           /* wrong, but perl doesn't use the return value */
2325 }
2326
2327 int
2328 vfprintf(FILE *fd, char *pat, char *args)
2329 {
2330     _doprnt(pat, args, fd);
2331     return 0;           /* wrong, but perl doesn't use the return value */
2332 }
2333
2334 #endif
2335
2336 #ifndef PerlIO_vsprintf
2337 int
2338 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2339 {
2340  int val = vsprintf(s, fmt, ap);
2341  if (n >= 0)
2342   {
2343    if (strlen(s) >= (STRLEN)n)
2344     {
2345      dTHX;
2346      (void)PerlIO_puts(Perl_error_log,
2347                        "panic: sprintf overflow - memory corrupted!\n");
2348      my_exit(1);
2349     }
2350   }
2351  return val;
2352 }
2353 #endif
2354
2355 #ifndef PerlIO_sprintf
2356 int
2357 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2358 {
2359  va_list ap;
2360  int result;
2361  va_start(ap,fmt);
2362  result = PerlIO_vsprintf(s, n, fmt, ap);
2363  va_end(ap);
2364  return result;
2365 }
2366 #endif
2367
2368 #endif /* !PERL_IMPLICIT_SYS */
2369