perlio.c

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