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 HV *PerlIO_layer_hv;
 253 AV *PerlIO_layer_av;
 254
 255 void
 256 PerlIO_cleanup(void)
 257 {
 258  PerlIO_cleantable(&_perlio);
 259 }
 260
 261 void
 262 PerlIO_pop(PerlIO *f)
 263 {
 264  PerlIOl *l = *f;
 265  if (l)
 266   {
 267    (*l->tab->Popped)(f);
 268    *f = l->next;
 269    Safefree(l);
 270   }
 271 }
 272
 273 #undef PerlIO_close
 274 int
 275 PerlIO_close(PerlIO *f)
 276 {
 277  int code = (*PerlIOBase(f)->tab->Close)(f);
 278  while (*f)
 279   {
 280    PerlIO_pop(f);
 281   }
 282  return code;
 283 }
 284
 285
 286 /*--------------------------------------------------------------------------------------*/
 287 /* Given the abstraction above the public API functions */
 288
 289 #undef PerlIO_fileno
 290 int
 291 PerlIO_fileno(PerlIO *f)
 292 {
 293  return (*PerlIOBase(f)->tab->Fileno)(f);
 294 }
 295
 296
 297 extern PerlIO_funcs PerlIO_unix;
 298 extern PerlIO_funcs PerlIO_perlio;
 299 extern PerlIO_funcs PerlIO_stdio;
 300 #ifdef HAS_MMAP
 301 extern PerlIO_funcs PerlIO_mmap;
 302 #endif
 303
 304 XS(XS_perlio_import)
 305 {
 306  dXSARGS;
 307  GV *gv = CvGV(cv);
 308  char *s = GvNAME(gv);
 309  STRLEN l = GvNAMELEN(gv);
 310  PerlIO_debug("%.*s\n",(int) l,s);
 311  XSRETURN_EMPTY;
 312 }
 313
 314 XS(XS_perlio_unimport)
 315 {
 316  dXSARGS;
 317  GV *gv = CvGV(cv);
 318  char *s = GvNAME(gv);
 319  STRLEN l = GvNAMELEN(gv);
 320  PerlIO_debug("%.*s\n",(int) l,s);
 321  XSRETURN_EMPTY;
 322 }
 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(PTR2IV(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_ "perlio: 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 = INT2PTR(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 #if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
1041 #define fseek fseeko
1042 #endif
1043
1044 #if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
1045 #define ftell ftello
1046 #endif
1047
1048
1049 typedef struct
1050 {
1051  struct _PerlIO base;
1052  FILE *         stdio;      /* The stream */
1053 } PerlIOStdio;
1054
1055 IV
1056 PerlIOStdio_fileno(PerlIO *f)
1057 {
1058  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1059 }
1060
1061
1062 PerlIO *
1063 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1064 {
1065  PerlIO *f = NULL;
1066  int init = 0;
1067  if (*mode == 'I')
1068   {
1069    init = 1;
1070    mode++;
1071   }
1072  if (fd >= 0)
1073   {
1074    FILE *stdio = NULL;
1075    if (init)
1076     {
1077      switch(fd)
1078       {
1079        case 0:
1080         stdio = stdin;
1081         break;
1082        case 1:
1083         stdio = stdout;
1084         break;
1085        case 2:
1086         stdio = stderr;
1087         break;
1088       }
1089     }
1090    else
1091     stdio = fdopen(fd,mode);
1092    if (stdio)
1093     {
1094      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1095      s->stdio  = stdio;
1096     }
1097   }
1098  return f;
1099 }
1100
1101 #undef PerlIO_importFILE
1102 PerlIO *
1103 PerlIO_importFILE(FILE *stdio, int fl)
1104 {
1105  PerlIO *f = NULL;
1106  if (stdio)
1107   {
1108    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1109    s->stdio  = stdio;
1110   }
1111  return f;
1112 }
1113
1114 PerlIO *
1115 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1116 {
1117  PerlIO *f = NULL;
1118  FILE *stdio = fopen(path,mode);
1119  if (stdio)
1120   {
1121    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1122    s->stdio  = stdio;
1123   }
1124  return f;
1125 }
1126
1127 int
1128 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1129 {
1130  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1131  FILE *stdio = freopen(path,mode,s->stdio);
1132  if (!s->stdio)
1133   return -1;
1134  s->stdio = stdio;
1135  return 0;
1136 }
1137
1138 SSize_t
1139 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1140 {
1141  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1142  SSize_t got = 0;
1143  if (count == 1)
1144   {
1145    STDCHAR *buf = (STDCHAR *) vbuf;
1146    /* Perl is expecting PerlIO_getc() to fill the buffer
1147     * Linux's stdio does not do that for fread()
1148     */
1149    int ch = fgetc(s);
1150    if (ch != EOF)
1151     {
1152      *buf = ch;
1153      got = 1;
1154     }
1155   }
1156  else
1157   got = fread(vbuf,1,count,s);
1158  return got;
1159 }
1160
1161 SSize_t
1162 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1163 {
1164  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1165  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1166  SSize_t unread = 0;
1167  while (count > 0)
1168   {
1169    int ch = *buf-- & 0xff;
1170    if (ungetc(ch,s) != ch)
1171     break;
1172    unread++;
1173    count--;
1174   }
1175  return unread;
1176 }
1177
1178 SSize_t
1179 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1180 {
1181  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1182 }
1183
1184 IV
1185 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1186 {
1187  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1188  return fseek(stdio,offset,whence);
1189 }
1190
1191 Off_t
1192 PerlIOStdio_tell(PerlIO *f)
1193 {
1194  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1195  return ftell(stdio);
1196 }
1197
1198 IV
1199 PerlIOStdio_close(PerlIO *f)
1200 {
1201  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1202 }
1203
1204 IV
1205 PerlIOStdio_flush(PerlIO *f)
1206 {
1207  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1208  return fflush(stdio);
1209 }
1210
1211 IV
1212 PerlIOStdio_fill(PerlIO *f)
1213 {
1214  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1215  int c;
1216  if (fflush(stdio) != 0)
1217   return EOF;
1218  c = fgetc(stdio);
1219  if (c == EOF || ungetc(c,stdio) != c)
1220   return EOF;
1221  return 0;
1222 }
1223
1224 IV
1225 PerlIOStdio_eof(PerlIO *f)
1226 {
1227  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1228 }
1229
1230 IV
1231 PerlIOStdio_error(PerlIO *f)
1232 {
1233  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1234 }
1235
1236 void
1237 PerlIOStdio_clearerr(PerlIO *f)
1238 {
1239  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1240 }
1241
1242 void
1243 PerlIOStdio_setlinebuf(PerlIO *f)
1244 {
1245 #ifdef HAS_SETLINEBUF
1246  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1247 #else
1248  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1249 #endif
1250 }
1251
1252 #ifdef FILE_base
1253 STDCHAR *
1254 PerlIOStdio_get_base(PerlIO *f)
1255 {
1256  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1257  return FILE_base(stdio);
1258 }
1259
1260 Size_t
1261 PerlIOStdio_get_bufsiz(PerlIO *f)
1262 {
1263  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1264  return FILE_bufsiz(stdio);
1265 }
1266 #endif
1267
1268 #ifdef USE_STDIO_PTR
1269 STDCHAR *
1270 PerlIOStdio_get_ptr(PerlIO *f)
1271 {
1272  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1273  return FILE_ptr(stdio);
1274 }
1275
1276 SSize_t
1277 PerlIOStdio_get_cnt(PerlIO *f)
1278 {
1279  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1280  return FILE_cnt(stdio);
1281 }
1282
1283 void
1284 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1285 {
1286  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1287  if (ptr != NULL)
1288   {
1289 #ifdef STDIO_PTR_LVALUE
1290    FILE_ptr(stdio) = ptr;
1291 #ifdef STDIO_PTR_LVAL_SETS_CNT
1292    if (FILE_cnt(stdio) != (cnt))
1293     {
1294      dTHX;
1295      assert(FILE_cnt(stdio) == (cnt));
1296     }
1297 #endif
1298 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1299    /* Setting ptr _does_ change cnt - we are done */
1300    return;
1301 #endif
1302 #else  /* STDIO_PTR_LVALUE */
1303    abort();
1304 #endif /* STDIO_PTR_LVALUE */
1305   }
1306 /* Now (or only) set cnt */
1307 #ifdef STDIO_CNT_LVALUE
1308  FILE_cnt(stdio) = cnt;
1309 #else  /* STDIO_CNT_LVALUE */
1310 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1311  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1312 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1313  abort();
1314 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1315 #endif /* STDIO_CNT_LVALUE */
1316 }
1317
1318 #endif
1319
1320 PerlIO_funcs PerlIO_stdio = {
1321  "stdio",
1322  sizeof(PerlIOStdio),
1323  0,
1324  PerlIOStdio_fileno,
1325  PerlIOStdio_fdopen,
1326  PerlIOStdio_open,
1327  PerlIOStdio_reopen,
1328  PerlIOBase_pushed,
1329  PerlIOBase_noop_ok,
1330  PerlIOStdio_read,
1331  PerlIOStdio_unread,
1332  PerlIOStdio_write,
1333  PerlIOStdio_seek,
1334  PerlIOStdio_tell,
1335  PerlIOStdio_close,
1336  PerlIOStdio_flush,
1337  PerlIOStdio_fill,
1338  PerlIOStdio_eof,
1339  PerlIOStdio_error,
1340  PerlIOStdio_clearerr,
1341  PerlIOStdio_setlinebuf,
1342 #ifdef FILE_base
1343  PerlIOStdio_get_base,
1344  PerlIOStdio_get_bufsiz,
1345 #else
1346  NULL,
1347  NULL,
1348 #endif
1349 #ifdef USE_STDIO_PTR
1350  PerlIOStdio_get_ptr,
1351  PerlIOStdio_get_cnt,
1352 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1353  PerlIOStdio_set_ptrcnt
1354 #else  /* STDIO_PTR_LVALUE */
1355  NULL
1356 #endif /* STDIO_PTR_LVALUE */
1357 #else  /* USE_STDIO_PTR */
1358  NULL,
1359  NULL,
1360  NULL
1361 #endif /* USE_STDIO_PTR */
1362 };
1363
1364 #undef PerlIO_exportFILE
1365 FILE *
1366 PerlIO_exportFILE(PerlIO *f, int fl)
1367 {
1368  PerlIO_flush(f);
1369  /* Should really push stdio discipline when we have them */
1370  return fdopen(PerlIO_fileno(f),"r+");
1371 }
1372
1373 #undef PerlIO_findFILE
1374 FILE *
1375 PerlIO_findFILE(PerlIO *f)
1376 {
1377  return PerlIO_exportFILE(f,0);
1378 }
1379
1380 #undef PerlIO_releaseFILE
1381 void
1382 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1383 {
1384 }
1385
1386 /*--------------------------------------------------------------------------------------*/
1387 /* perlio buffer layer */
1388
1389 typedef struct
1390 {
1391  struct _PerlIO base;
1392  Off_t          posn;       /* Offset of buf into the file */
1393  STDCHAR *      buf;        /* Start of buffer */
1394  STDCHAR *      end;        /* End of valid part of buffer */
1395  STDCHAR *      ptr;        /* Current position in buffer */
1396  Size_t         bufsiz;     /* Size of buffer */
1397  IV             oneword;    /* Emergency buffer */
1398 } PerlIOBuf;
1399
1400
1401 PerlIO *
1402 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1403 {
1404  PerlIO_funcs *tab = PerlIO_default_btm();
1405  int init = 0;
1406  PerlIO *f;
1407  if (*mode == 'I')
1408   {
1409    init = 1;
1410    mode++;
1411   }
1412  f = (*tab->Fdopen)(tab,fd,mode);
1413  if (f)
1414   {
1415    /* Initial stderr is unbuffered */
1416    if (!init || fd != 2)
1417     {
1418      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1419      b->posn = PerlIO_tell(PerlIONext(f));
1420     }
1421   }
1422  return f;
1423 }
1424
1425
1426 PerlIO *
1427 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1428 {
1429  PerlIO_funcs *tab = PerlIO_default_btm();
1430  PerlIO *f = (*tab->Open)(tab,path,mode);
1431  if (f)
1432   {
1433    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1434    b->posn = PerlIO_tell(PerlIONext(f));
1435   }
1436  return f;
1437 }
1438
1439 int
1440 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1441 {
1442  PerlIO *next = PerlIONext(f);
1443  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1444  if (code = 0)
1445   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1446  if (code == 0)
1447   {
1448    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1449    b->posn = PerlIO_tell(PerlIONext(f));
1450   }
1451  return code;
1452 }
1453
1454 /* This "flush" is akin to sfio's sync in that it handles files in either
1455    read or write state
1456 */
1457 IV
1458 PerlIOBuf_flush(PerlIO *f)
1459 {
1460  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1461  int code = 0;
1462  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1463   {
1464    /* write() the buffer */
1465    STDCHAR *p = b->buf;
1466    int count;
1467    while (p < b->ptr)
1468     {
1469      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1470      if (count > 0)
1471       {
1472        p += count;
1473       }
1474      else if (count < 0)
1475       {
1476        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1477        code = -1;
1478        break;
1479       }
1480     }
1481    b->posn += (p - b->buf);
1482   }
1483  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1484   {
1485    /* Note position change */
1486    b->posn += (b->ptr - b->buf);
1487    if (b->ptr < b->end)
1488     {
1489      /* We did not consume all of it */
1490      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1491       {
1492        b->posn = PerlIO_tell(PerlIONext(f));
1493       }
1494     }
1495   }
1496  b->ptr = b->end = b->buf;
1497  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1498  if (PerlIO_flush(PerlIONext(f)) != 0)
1499   code = -1;
1500  return code;
1501 }
1502
1503 IV
1504 PerlIOBuf_fill(PerlIO *f)
1505 {
1506  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1507  SSize_t avail;
1508  if (PerlIO_flush(f) != 0)
1509   return -1;
1510  b->ptr = b->end = b->buf;
1511  avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1512  if (avail <= 0)
1513   {
1514    if (avail == 0)
1515     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1516    else
1517     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1518    return -1;
1519   }
1520  b->end      = b->buf+avail;
1521  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1522  return 0;
1523 }
1524
1525 SSize_t
1526 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1527 {
1528  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1529  STDCHAR *buf = (STDCHAR *) vbuf;
1530  if (f)
1531   {
1532    Size_t got = 0;
1533    if (!b->ptr)
1534     PerlIO_get_base(f);
1535    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1536     return 0;
1537    while (count > 0)
1538     {
1539      SSize_t avail = (b->end - b->ptr);
1540      if ((SSize_t) count < avail)
1541       avail = count;
1542      if (avail > 0)
1543       {
1544        Copy(b->ptr,buf,avail,char);
1545        got     += avail;
1546        b->ptr  += avail;
1547        count   -= avail;
1548        buf     += avail;
1549       }
1550      if (count && (b->ptr >= b->end))
1551       {
1552        if (PerlIO_fill(f) != 0)
1553         break;
1554       }
1555     }
1556    return got;
1557   }
1558  return 0;
1559 }
1560
1561 SSize_t
1562 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1563 {
1564  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1565  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1566  SSize_t unread = 0;
1567  SSize_t avail;
1568  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1569   PerlIO_flush(f);
1570  if (!b->buf)
1571   PerlIO_get_base(f);
1572  if (b->buf)
1573   {
1574    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1575     {
1576      avail = (b->ptr - b->buf);
1577      if (avail > (SSize_t) count)
1578       avail = count;
1579      b->ptr -= avail;
1580     }
1581    else
1582     {
1583      avail = b->bufsiz;
1584      if (avail > (SSize_t) count)
1585       avail = count;
1586      b->end = b->ptr + avail;
1587     }
1588    if (avail > 0)
1589     {
1590      buf    -= avail;
1591      if (buf != b->ptr)
1592       {
1593        Copy(buf,b->ptr,avail,char);
1594       }
1595      count  -= avail;
1596      unread += avail;
1597      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1598     }
1599   }
1600  return unread;
1601 }
1602
1603 SSize_t
1604 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1605 {
1606  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1607  const STDCHAR *buf = (const STDCHAR *) vbuf;
1608  Size_t written = 0;
1609  if (!b->buf)
1610   PerlIO_get_base(f);
1611  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1612   return 0;
1613  while (count > 0)
1614   {
1615    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1616    if ((SSize_t) count < avail)
1617     avail = count;
1618    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1619    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1620     {
1621      while (avail > 0)
1622       {
1623        int ch = *buf++;
1624        *(b->ptr)++ = ch;
1625        count--;
1626        avail--;
1627        written++;
1628        if (ch == '\n')
1629         {
1630          PerlIO_flush(f);
1631          break;
1632         }
1633       }
1634     }
1635    else
1636     {
1637      if (avail)
1638       {
1639        Copy(buf,b->ptr,avail,char);
1640        count   -= avail;
1641        buf     += avail;
1642        written += avail;
1643        b->ptr  += avail;
1644       }
1645     }
1646    if (b->ptr >= (b->buf + b->bufsiz))
1647     PerlIO_flush(f);
1648   }
1649  return written;
1650 }
1651
1652 IV
1653 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1654 {
1655  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1656  int code = PerlIO_flush(f);
1657  if (code == 0)
1658   {
1659    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1660    code = PerlIO_seek(PerlIONext(f),offset,whence);
1661    if (code == 0)
1662     {
1663      b->posn = PerlIO_tell(PerlIONext(f));
1664     }
1665   }
1666  return code;
1667 }
1668
1669 Off_t
1670 PerlIOBuf_tell(PerlIO *f)
1671 {
1672  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1673  Off_t posn = b->posn;
1674  if (b->buf)
1675   posn += (b->ptr - b->buf);
1676  return posn;
1677 }
1678
1679 IV
1680 PerlIOBuf_close(PerlIO *f)
1681 {
1682  IV code = PerlIOBase_close(f);
1683  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1684  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1685   {
1686    Safefree(b->buf);
1687   }
1688  b->buf = NULL;
1689  b->ptr = b->end = b->buf;
1690  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1691  return code;
1692 }
1693
1694 void
1695 PerlIOBuf_setlinebuf(PerlIO *f)
1696 {
1697  if (f)
1698   {
1699    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1700   }
1701 }
1702
1703 void
1704 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1705 {
1706  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1707  dTHX;
1708  if (!b->buf)
1709   PerlIO_get_base(f);
1710  b->ptr = b->end - cnt;
1711  assert(b->ptr >= b->buf);
1712 }
1713
1714 STDCHAR *
1715 PerlIOBuf_get_ptr(PerlIO *f)
1716 {
1717  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1718  if (!b->buf)
1719   PerlIO_get_base(f);
1720  return b->ptr;
1721 }
1722
1723 SSize_t
1724 PerlIOBuf_get_cnt(PerlIO *f)
1725 {
1726  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1727  if (!b->buf)
1728   PerlIO_get_base(f);
1729  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1730   return (b->end - b->ptr);
1731  return 0;
1732 }
1733
1734 STDCHAR *
1735 PerlIOBuf_get_base(PerlIO *f)
1736 {
1737  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1738  if (!b->buf)
1739   {
1740    if (!b->bufsiz)
1741     b->bufsiz = 4096;
1742    New('B',b->buf,b->bufsiz,STDCHAR);
1743    if (!b->buf)
1744     {
1745      b->buf = (STDCHAR *)&b->oneword;
1746      b->bufsiz = sizeof(b->oneword);
1747     }
1748    b->ptr = b->buf;
1749    b->end = b->ptr;
1750   }
1751  return b->buf;
1752 }
1753
1754 Size_t
1755 PerlIOBuf_bufsiz(PerlIO *f)
1756 {
1757  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1758  if (!b->buf)
1759   PerlIO_get_base(f);
1760  return (b->end - b->buf);
1761 }
1762
1763 void
1764 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1765 {
1766  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1767  if (!b->buf)
1768   PerlIO_get_base(f);
1769  b->ptr = ptr;
1770  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1771   {
1772    dTHX;
1773    assert(PerlIO_get_cnt(f) == cnt);
1774    assert(b->ptr >= b->buf);
1775   }
1776  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1777 }
1778
1779 PerlIO_funcs PerlIO_perlio = {
1780  "perlio",
1781  sizeof(PerlIOBuf),
1782  0,
1783  PerlIOBase_fileno,
1784  PerlIOBuf_fdopen,
1785  PerlIOBuf_open,
1786  PerlIOBuf_reopen,
1787  PerlIOBase_pushed,
1788  PerlIOBase_noop_ok,
1789  PerlIOBuf_read,
1790  PerlIOBuf_unread,
1791  PerlIOBuf_write,
1792  PerlIOBuf_seek,
1793  PerlIOBuf_tell,
1794  PerlIOBuf_close,
1795  PerlIOBuf_flush,
1796  PerlIOBuf_fill,
1797  PerlIOBase_eof,
1798  PerlIOBase_error,
1799  PerlIOBase_clearerr,
1800  PerlIOBuf_setlinebuf,
1801  PerlIOBuf_get_base,
1802  PerlIOBuf_bufsiz,
1803  PerlIOBuf_get_ptr,
1804  PerlIOBuf_get_cnt,
1805  PerlIOBuf_set_ptrcnt,
1806 };
1807
1808 #ifdef HAS_MMAP
1809 /*--------------------------------------------------------------------------------------*/
1810 /* mmap as "buffer" layer */
1811
1812 typedef struct
1813 {
1814  PerlIOBuf      base;         /* PerlIOBuf stuff */
1815  Mmap_t         mptr;        /* Mapped address */
1816  Size_t         len;          /* mapped length */
1817  STDCHAR        *bbuf;        /* malloced buffer if map fails */
1818
1819 } PerlIOMmap;
1820
1821 static size_t page_size = 0;
1822
1823 IV
1824 PerlIOMmap_map(PerlIO *f)
1825 {
1826  dTHX;
1827  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1828  PerlIOBuf  *b = &m->base;
1829  IV flags = PerlIOBase(f)->flags;
1830  IV code  = 0;
1831  if (m->len)
1832   abort();
1833  if (flags & PERLIO_F_CANREAD)
1834   {
1835    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1836    int fd   = PerlIO_fileno(f);
1837    struct stat st;
1838    code = fstat(fd,&st);
1839    if (code == 0 && S_ISREG(st.st_mode))
1840     {
1841      SSize_t len = st.st_size - b->posn;
1842      if (len > 0)
1843       {
1844        Off_t posn;
1845        if (!page_size) {
1846 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1847            {
1848                SETERRNO(0,SS$_NORMAL);
1849 #   ifdef _SC_PAGESIZE
1850                page_size = sysconf(_SC_PAGESIZE);
1851 #   else
1852                page_size = sysconf(_SC_PAGE_SIZE);
1853 #   endif
1854                if ((long)page_size < 0) {
1855                    if (errno) {
1856                        SV *error = ERRSV;
1857                        char *msg;
1858                        STRLEN n_a;
1859                        (void)SvUPGRADE(error, SVt_PV);
1860                        msg = SvPVx(error, n_a);
1861                        Perl_croak("panic: sysconf: %s", msg);
1862                    }
1863                    else
1864                        Perl_croak("panic: sysconf: pagesize unknown");
1865                }
1866            }
1867 #else
1868 #   ifdef HAS_GETPAGESIZE
1869         page_size = getpagesize();
1870 #   else
1871 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
1872         page_size = PAGESIZE; /* compiletime, bad */
1873 #       endif
1874 #   endif
1875 #endif
1876         if ((IV)page_size <= 0)
1877             Perl_croak("panic: bad pagesize %"IVdf, (IV)page_size);
1878        }
1879        if (b->posn < 0)
1880         {
1881          /* This is a hack - should never happen - open should have set it ! */
1882          b->posn = PerlIO_tell(PerlIONext(f));
1883         }
1884        posn = (b->posn / page_size) * page_size;
1885        len  = st.st_size - posn;
1886        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1887        if (m->mptr && m->mptr != (Mmap_t) -1)
1888         {
1889 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1890          madvise(m->mptr, len, MADV_SEQUENTIAL);
1891 #endif
1892          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1893          b->end  = ((STDCHAR *)m->mptr) + len;
1894          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
1895          b->ptr  = b->buf;
1896          m->len  = len;
1897         }
1898        else
1899         {
1900          b->buf = NULL;
1901         }
1902       }
1903      else
1904       {
1905        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1906        b->buf = NULL;
1907        b->ptr = b->end = b->ptr;
1908        code = -1;
1909       }
1910     }
1911   }
1912  return code;
1913 }
1914
1915 IV
1916 PerlIOMmap_unmap(PerlIO *f)
1917 {
1918  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1919  PerlIOBuf  *b = &m->base;
1920  IV code = 0;
1921  if (m->len)
1922   {
1923    if (b->buf)
1924     {
1925      code = munmap(m->mptr, m->len);
1926      b->buf  = NULL;
1927      m->len  = 0;
1928      m->mptr = NULL;
1929      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1930       code = -1;
1931     }
1932    b->ptr = b->end = b->buf;
1933    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1934   }
1935  return code;
1936 }
1937
1938 STDCHAR *
1939 PerlIOMmap_get_base(PerlIO *f)
1940 {
1941  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1942  PerlIOBuf  *b = &m->base;
1943  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1944   {
1945    /* Already have a readbuffer in progress */
1946    return b->buf;
1947   }
1948  if (b->buf)
1949   {
1950    /* We have a write buffer or flushed PerlIOBuf read buffer */
1951    m->bbuf = b->buf;  /* save it in case we need it again */
1952    b->buf  = NULL;    /* Clear to trigger below */
1953   }
1954  if (!b->buf)
1955   {
1956    PerlIOMmap_map(f);     /* Try and map it */
1957    if (!b->buf)
1958     {
1959      /* Map did not work - recover PerlIOBuf buffer if we have one */
1960      b->buf = m->bbuf;
1961     }
1962   }
1963  b->ptr  = b->end = b->buf;
1964  if (b->buf)
1965   return b->buf;
1966  return PerlIOBuf_get_base(f);
1967 }
1968
1969 SSize_t
1970 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1971 {
1972  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1973  PerlIOBuf  *b = &m->base;
1974  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1975   PerlIO_flush(f);
1976  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1977   {
1978    b->ptr -= count;
1979    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1980    return count;
1981   }
1982  if (m->len)
1983   {
1984    /* Loose the unwritable mapped buffer */
1985    PerlIO_flush(f);
1986    /* If flush took the "buffer" see if we have one from before */
1987    if (!b->buf && m->bbuf)
1988     b->buf = m->bbuf;
1989    if (!b->buf)
1990     {
1991      PerlIOBuf_get_base(f);
1992      m->bbuf = b->buf;
1993     }
1994   }
1995  return PerlIOBuf_unread(f,vbuf,count);
1996 }
1997
1998 SSize_t
1999 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2000 {
2001  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2002  PerlIOBuf  *b = &m->base;
2003  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2004   {
2005    /* No, or wrong sort of, buffer */
2006    if (m->len)
2007     {
2008      if (PerlIOMmap_unmap(f) != 0)
2009       return 0;
2010     }
2011    /* If unmap took the "buffer" see if we have one from before */
2012    if (!b->buf && m->bbuf)
2013     b->buf = m->bbuf;
2014    if (!b->buf)
2015     {
2016      PerlIOBuf_get_base(f);
2017      m->bbuf = b->buf;
2018     }
2019   }
2020  return PerlIOBuf_write(f,vbuf,count);
2021 }
2022
2023 IV
2024 PerlIOMmap_flush(PerlIO *f)
2025 {
2026  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2027  PerlIOBuf  *b = &m->base;
2028  IV code = PerlIOBuf_flush(f);
2029  /* Now we are "synced" at PerlIOBuf level */
2030  if (b->buf)
2031   {
2032    if (m->len)
2033     {
2034      /* Unmap the buffer */
2035      if (PerlIOMmap_unmap(f) != 0)
2036       code = -1;
2037     }
2038    else
2039     {
2040      /* We seem to have a PerlIOBuf buffer which was not mapped
2041       * remember it in case we need one later
2042       */
2043      m->bbuf = b->buf;
2044     }
2045   }
2046  return code;
2047 }
2048
2049 IV
2050 PerlIOMmap_fill(PerlIO *f)
2051 {
2052  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2053  IV code = PerlIO_flush(f);
2054  if (code == 0 && !b->buf)
2055   {
2056    code = PerlIOMmap_map(f);
2057   }
2058  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2059   {
2060    code = PerlIOBuf_fill(f);
2061   }
2062  return code;
2063 }
2064
2065 IV
2066 PerlIOMmap_close(PerlIO *f)
2067 {
2068  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2069  PerlIOBuf  *b = &m->base;
2070  IV code = PerlIO_flush(f);
2071  if (m->bbuf)
2072   {
2073    b->buf  = m->bbuf;
2074    m->bbuf = NULL;
2075    b->ptr  = b->end = b->buf;
2076   }
2077  if (PerlIOBuf_close(f) != 0)
2078   code = -1;
2079  return code;
2080 }
2081
2082
2083 PerlIO_funcs PerlIO_mmap = {
2084  "mmap",
2085  sizeof(PerlIOMmap),
2086  0,
2087  PerlIOBase_fileno,
2088  PerlIOBuf_fdopen,
2089  PerlIOBuf_open,
2090  PerlIOBuf_reopen,
2091  PerlIOBase_pushed,
2092  PerlIOBase_noop_ok,
2093  PerlIOBuf_read,
2094  PerlIOMmap_unread,
2095  PerlIOMmap_write,
2096  PerlIOBuf_seek,
2097  PerlIOBuf_tell,
2098  PerlIOBuf_close,
2099  PerlIOMmap_flush,
2100  PerlIOMmap_fill,
2101  PerlIOBase_eof,
2102  PerlIOBase_error,
2103  PerlIOBase_clearerr,
2104  PerlIOBuf_setlinebuf,
2105  PerlIOMmap_get_base,
2106  PerlIOBuf_bufsiz,
2107  PerlIOBuf_get_ptr,
2108  PerlIOBuf_get_cnt,
2109  PerlIOBuf_set_ptrcnt,
2110 };
2111
2112 #endif /* HAS_MMAP */
2113
2114
2115
2116 void
2117 PerlIO_init(void)
2118 {
2119  if (!_perlio)
2120   {
2121    atexit(&PerlIO_cleanup);
2122   }
2123 }
2124
2125 #undef PerlIO_stdin
2126 PerlIO *
2127 PerlIO_stdin(void)
2128 {
2129  if (!_perlio)
2130   PerlIO_stdstreams();
2131  return &_perlio[1];
2132 }
2133
2134 #undef PerlIO_stdout
2135 PerlIO *
2136 PerlIO_stdout(void)
2137 {
2138  if (!_perlio)
2139   PerlIO_stdstreams();
2140  return &_perlio[2];
2141 }
2142
2143 #undef PerlIO_stderr
2144 PerlIO *
2145 PerlIO_stderr(void)
2146 {
2147  if (!_perlio)
2148   PerlIO_stdstreams();
2149  return &_perlio[3];
2150 }
2151
2152 /*--------------------------------------------------------------------------------------*/
2153
2154 #undef PerlIO_getname
2155 char *
2156 PerlIO_getname(PerlIO *f, char *buf)
2157 {
2158  dTHX;
2159  Perl_croak(aTHX_ "Don't know how to get file name");
2160  return NULL;
2161 }
2162
2163
2164 /*--------------------------------------------------------------------------------------*/
2165 /* Functions which can be called on any kind of PerlIO implemented
2166    in terms of above
2167 */
2168
2169 #undef PerlIO_getc
2170 int
2171 PerlIO_getc(PerlIO *f)
2172 {
2173  STDCHAR buf[1];
2174  SSize_t count = PerlIO_read(f,buf,1);
2175  if (count == 1)
2176   {
2177    return (unsigned char) buf[0];
2178   }
2179  return EOF;
2180 }
2181
2182 #undef PerlIO_ungetc
2183 int
2184 PerlIO_ungetc(PerlIO *f, int ch)
2185 {
2186  if (ch != EOF)
2187   {
2188    STDCHAR buf = ch;
2189    if (PerlIO_unread(f,&buf,1) == 1)
2190     return ch;
2191   }
2192  return EOF;
2193 }
2194
2195 #undef PerlIO_putc
2196 int
2197 PerlIO_putc(PerlIO *f, int ch)
2198 {
2199  STDCHAR buf = ch;
2200  return PerlIO_write(f,&buf,1);
2201 }
2202
2203 #undef PerlIO_puts
2204 int
2205 PerlIO_puts(PerlIO *f, const char *s)
2206 {
2207  STRLEN len = strlen(s);
2208  return PerlIO_write(f,s,len);
2209 }
2210
2211 #undef PerlIO_rewind
2212 void
2213 PerlIO_rewind(PerlIO *f)
2214 {
2215  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2216  PerlIO_clearerr(f);
2217 }
2218
2219 #undef PerlIO_vprintf
2220 int
2221 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2222 {
2223  dTHX;
2224  SV *sv = newSVpvn("",0);
2225  char *s;
2226  STRLEN len;
2227  sv_vcatpvf(sv, fmt, &ap);
2228  s = SvPV(sv,len);
2229  return PerlIO_write(f,s,len);
2230 }
2231
2232 #undef PerlIO_printf
2233 int
2234 PerlIO_printf(PerlIO *f,const char *fmt,...)
2235 {
2236  va_list ap;
2237  int result;
2238  va_start(ap,fmt);
2239  result = PerlIO_vprintf(f,fmt,ap);
2240  va_end(ap);
2241  return result;
2242 }
2243
2244 #undef PerlIO_stdoutf
2245 int
2246 PerlIO_stdoutf(const char *fmt,...)
2247 {
2248  va_list ap;
2249  int result;
2250  va_start(ap,fmt);
2251  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2252  va_end(ap);
2253  return result;
2254 }
2255
2256 #undef PerlIO_tmpfile
2257 PerlIO *
2258 PerlIO_tmpfile(void)
2259 {
2260  dTHX;
2261  /* I have no idea how portable mkstemp() is ... */
2262  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2263  int fd = mkstemp(SvPVX(sv));
2264  PerlIO *f = NULL;
2265  if (fd >= 0)
2266   {
2267    f = PerlIO_fdopen(fd,"w+");
2268    if (f)
2269     {
2270      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2271     }
2272    unlink(SvPVX(sv));
2273    SvREFCNT_dec(sv);
2274   }
2275  return f;
2276 }
2277
2278 #undef HAS_FSETPOS
2279 #undef HAS_FGETPOS
2280
2281 #endif /* USE_SFIO */
2282 #endif /* PERLIO_IS_STDIO */
2283
2284 /*======================================================================================*/
2285 /* Now some functions in terms of above which may be needed even if
2286    we are not in true PerlIO mode
2287  */
2288
2289 #ifndef HAS_FSETPOS
2290 #undef PerlIO_setpos
2291 int
2292 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2293 {
2294  return PerlIO_seek(f,*pos,0);
2295 }
2296 #else
2297 #ifndef PERLIO_IS_STDIO
2298 #undef PerlIO_setpos
2299 int
2300 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2301 {
2302 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2303  return fsetpos64(f, pos);
2304 #else
2305  return fsetpos(f, pos);
2306 #endif
2307 }
2308 #endif
2309 #endif
2310
2311 #ifndef HAS_FGETPOS
2312 #undef PerlIO_getpos
2313 int
2314 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2315 {
2316  *pos = PerlIO_tell(f);
2317  return 0;
2318 }
2319 #else
2320 #ifndef PERLIO_IS_STDIO
2321 #undef PerlIO_getpos
2322 int
2323 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2324 {
2325 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2326  return fgetpos64(f, pos);
2327 #else
2328  return fgetpos(f, pos);
2329 #endif
2330 }
2331 #endif
2332 #endif
2333
2334 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2335
2336 int
2337 vprintf(char *pat, char *args)
2338 {
2339     _doprnt(pat, args, stdout);
2340     return 0;           /* wrong, but perl doesn't use the return value */
2341 }
2342
2343 int
2344 vfprintf(FILE *fd, char *pat, char *args)
2345 {
2346     _doprnt(pat, args, fd);
2347     return 0;           /* wrong, but perl doesn't use the return value */
2348 }
2349
2350 #endif
2351
2352 #ifndef PerlIO_vsprintf
2353 int
2354 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2355 {
2356  int val = vsprintf(s, fmt, ap);
2357  if (n >= 0)
2358   {
2359    if (strlen(s) >= (STRLEN)n)
2360     {
2361      dTHX;
2362      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
2363      my_exit(1);
2364     }
2365   }
2366  return val;
2367 }
2368 #endif
2369
2370 #ifndef PerlIO_sprintf
2371 int
2372 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2373 {
2374  va_list ap;
2375  int result;
2376  va_start(ap,fmt);
2377  result = PerlIO_vsprintf(s, n, fmt, ap);
2378  va_end(ap);
2379  return result;
2380 }
2381 #endif
2382
2383 #endif /* !PERL_IMPLICIT_SYS */
2384