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