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 /*======================================================================================*/
  89
  90 /* Implement all the PerlIO interface ourselves.
  91 */
  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
  98 #undef printf
  99 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
 100
 101 void
 102 PerlIO_debug(char *fmt,...)
 103 {
 104  static int dbg = 0;
 105  if (!dbg)
 106   {
 107    char *s = getenv("PERLIO_DEBUG");
 108    if (s && *s)
 109     dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 110    else
 111     dbg = -1;
 112   }
 113  if (dbg > 0)
 114   {
 115    dTHX;
 116    va_list ap;
 117    SV *sv = newSVpvn("",0);
 118    char *s;
 119    STRLEN len;
 120    va_start(ap,fmt);
 121    sv_vcatpvf(sv, fmt, &ap);
 122    s = SvPV(sv,len);
 123    write(dbg,s,len);
 124    va_end(ap);
 125    SvREFCNT_dec(sv);
 126   }
 127 }
 128
 129 #define PERLIO_F_EOF            0x010000
 130 #define PERLIO_F_ERROR          0x020000
 131 #define PERLIO_F_LINEBUF        0x040000
 132 #define PERLIO_F_TEMP           0x080000
 133 #define PERLIO_F_RDBUF          0x100000
 134 #define PERLIO_F_WRBUF          0x200000
 135 #define PERLIO_F_OPEN           0x400000
 136 #define PERLIO_F_USED           0x800000
 137
 138 struct _PerlIO
 139 {
 140  IV       flags;      /* Various flags for state */
 141  IV       fd;         /* Maybe pointer on some OSes */
 142  int      oflags;     /* open/fcntl flags */
 143  STDCHAR *buf;        /* Start of buffer */
 144  STDCHAR *end;        /* End of valid part of buffer */
 145  STDCHAR *ptr;        /* Current position in buffer */
 146  Size_t   bufsiz;     /* Size of buffer */
 147  Off_t    posn;       /* Offset of f->buf into the file */
 148  int      oneword;    /* An if-all-else-fails area as a buffer */
 149 };
 150
 151 /* Table of pointers to the PerlIO structs (malloc'ed) */
 152 PerlIO **_perlio     = NULL;
 153 int _perlio_size     = 0;
 154
 155 void
 156 PerlIO_alloc_buf(PerlIO *f)
 157 {
 158  if (!f->bufsiz)
 159   f->bufsiz = 4096;
 160  New('B',f->buf,f->bufsiz,char);
 161  if (!f->buf)
 162   {
 163    f->buf = (STDCHAR *)&f->oneword;
 164    f->bufsiz = sizeof(f->oneword);
 165   }
 166  f->ptr = f->buf;
 167  f->end = f->ptr;
 168 }
 169
 170
 171 /* This "flush" is akin to sfio's sync in that it handles files in either
 172    read or write state
 173 */
 174 #undef PerlIO_flush
 175 int
 176 PerlIO_flush(PerlIO *f)
 177 {
 178  int code = 0;
 179  if (f)
 180   {
 181    PerlIO_debug(__FUNCTION__ " f=%p flags=%08X c=%d buf=%p ptr=%p\n",
 182                 f,f->flags,(f->ptr-f->buf),f->buf,f->ptr);
 183    if (f->flags & PERLIO_F_WRBUF)
 184     {
 185      /* write() the buffer */
 186      STDCHAR *p = f->buf;
 187      int count;
 188      while (p < f->ptr)
 189       {
 190        count = write(f->fd,p,f->ptr - p);
 191        if (count > 0)
 192         {
 193          p += count;
 194         }
 195        else if (count < 0 && errno != EINTR)
 196         {
 197          f->flags |= PERLIO_F_ERROR;
 198          code = -1;
 199          break;
 200         }
 201       }
 202      f->posn += (p - f->buf);
 203     }
 204    else if (f->flags & PERLIO_F_RDBUF)
 205     {
 206      /* Note position change */
 207      f->posn += (f->ptr - f->buf);
 208      if (f->ptr < f->end)
 209       {
 210        /* We did not consume all of it */
 211        f->posn = lseek(f->fd,f->posn,SEEK_SET);
 212       }
 213     }
 214    f->ptr = f->end = f->buf;
 215    f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 216   }
 217  else
 218   {
 219    int i;
 220    for (i=_perlio_size; i >= 0; i--)
 221     {
 222      if ((f = _perlio[i]))
 223       {
 224        if (PerlIO_flush(f) != 0)
 225         code = -1;
 226       }
 227     }
 228   }
 229  return code;
 230 }
 231
 232 int
 233 PerlIO_oflags(const char *mode)
 234 {
 235  int oflags = -1;
 236  PerlIO_debug(__FUNCTION__ " %s = ",mode);
 237  switch(*mode)
 238   {
 239    case 'r':
 240     oflags = O_RDONLY;
 241     if (*++mode == '+')
 242      {
 243       oflags = O_RDWR;
 244       mode++;
 245      }
 246     break;
 247
 248    case 'w':
 249     oflags = O_CREAT|O_TRUNC;
 250     if (*++mode == '+')
 251      {
 252       oflags |= O_RDWR;
 253       mode++;
 254      }
 255     else
 256      oflags |= O_WRONLY;
 257     break;
 258
 259    case 'a':
 260     oflags = O_CREAT|O_APPEND;
 261     if (*++mode == '+')
 262      {
 263       oflags |= O_RDWR;
 264       mode++;
 265      }
 266     else
 267      oflags |= O_WRONLY;
 268     break;
 269   }
 270  if (*mode || oflags == -1)
 271   {
 272    errno = EINVAL;
 273    oflags = -1;
 274   }
 275  PerlIO_debug(" %X '%s'\n",oflags,mode);
 276  return oflags;
 277 }
 278
 279 PerlIO *
 280 PerlIO_allocate(void)
 281 {
 282  /* Find a free slot in the table, growing table as necessary */
 283  PerlIO *f;
 284  int i = 0;
 285  while (1)
 286   {
 287    PerlIO **table = _perlio;
 288    while (i < _perlio_size)
 289     {
 290      f = table[i];
 291      PerlIO_debug(__FUNCTION__ " try %d %p\n",i,f);
 292      if (!f)
 293       {
 294        Newz('F',f,1,PerlIO);
 295        if (!f)
 296         return NULL;
 297        table[i] = f;
 298       }
 299      if (!(f->flags & PERLIO_F_USED))
 300       {
 301        Zero(f,1,PerlIO);
 302        f->flags = PERLIO_F_USED;
 303        return f;
 304       }
 305      i++;
 306     }
 307    Newz('I',table,_perlio_size+16,PerlIO *);
 308    if (!table)
 309     return NULL;
 310    Copy(_perlio,table,_perlio_size,PerlIO *);
 311    if (_perlio)
 312     Safefree(_perlio);
 313    _perlio = table;
 314    _perlio_size += 16;
 315   }
 316 }
 317
 318 #undef PerlIO_fdopen
 319 PerlIO *
 320 PerlIO_fdopen(int fd, const char *mode)
 321 {
 322  PerlIO *f = NULL;
 323  if (fd >= 0)
 324   {
 325    if ((f = PerlIO_allocate()))
 326     {
 327      f->fd     = fd;
 328      f->oflags = PerlIO_oflags(mode);
 329      f->flags  |= (PERLIO_F_OPEN|PERLIO_F_USED);
 330     }
 331   }
 332  PerlIO_debug(__FUNCTION__ " fd=%d m=%s f=%p\n",fd,mode,f);
 333  return f;
 334 }
 335
 336 #undef PerlIO_fileno
 337 int
 338 PerlIO_fileno(PerlIO *f)
 339 {
 340  if (f && (f->flags & PERLIO_F_OPEN))
 341   {
 342    return f->fd;
 343   }
 344  return -1;
 345 }
 346
 347 #undef PerlIO_close
 348 int
 349 PerlIO_close(PerlIO *f)
 350 {
 351  int code = 0;
 352  if (f)
 353   {
 354    if (PerlIO_flush(f) != 0)
 355     code = -1;
 356    while (close(f->fd) != 0)
 357     {
 358      if (errno != EINTR)
 359       {
 360        code = -1;
 361        break;
 362       }
 363     }
 364    f->flags &= ~PERLIO_F_OPEN;
 365    f->fd     = -1;
 366    if (f->buf && f->buf != (STDCHAR *) &f->oneword)
 367     {
 368      Safefree(f->buf);
 369     }
 370    f->buf = NULL;
 371    f->ptr = f->end = f->buf;
 372    f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 373   }
 374  return code;
 375 }
 376
 377 void
 378 PerlIO_cleanup(void)
 379 {
 380  /* Close all the files */
 381  int i;
 382  PerlIO_debug(__FUNCTION__ "\n");
 383  for (i=_perlio_size-1; i >= 0; i--)
 384   {
 385    PerlIO *f = _perlio[i];
 386    if (f)
 387     {
 388      PerlIO_close(f);
 389      Safefree(f);
 390     }
 391   }
 392  if (_perlio)
 393   Safefree(_perlio);
 394  _perlio      = NULL;
 395  _perlio_size = 0;
 396 }
 397
 398 #undef PerlIO_open
 399 PerlIO *
 400 PerlIO_open(const char *path, const char *mode)
 401 {
 402  PerlIO *f = NULL;
 403  int oflags = PerlIO_oflags(mode);
 404  if (oflags != -1)
 405   {
 406    int fd = open(path,oflags,0666);
 407    if (fd >= 0)
 408     {
 409      PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
 410      f = PerlIO_fdopen(fd,mode);
 411      if (!f)
 412       close(fd);
 413     }
 414   }
 415  PerlIO_debug(__FUNCTION__ " path=%s m=%s f=%p\n",path,mode,f);
 416  return f;
 417 }
 418
 419 #undef PerlIO_reopen
 420 PerlIO *
 421 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 422 {
 423  PerlIO_debug(__FUNCTION__ " n=%s m=%s f=%p\n",path,mode,f);
 424  if (f)
 425   {
 426    int oflags = PerlIO_oflags(mode);
 427    PerlIO_close(f);
 428    if (oflags != -1)
 429     {
 430      int fd = open(path,oflags,0666);
 431      if (fd >= 0)
 432       {
 433        PerlIO_debug(__FUNCTION__ "fd=%d\n",fd);
 434        f->oflags = oflags;
 435        f->flags  |= (PERLIO_F_OPEN|PERLIO_F_USED);
 436       }
 437     }
 438    else
 439     {
 440      return NULL;
 441     }
 442   }
 443  return PerlIO_open(path,mode);
 444 }
 445
 446 void
 447 PerlIO_init(void)
 448 {
 449  if (!_perlio)
 450   {
 451    atexit(&PerlIO_cleanup);
 452    PerlIO_fdopen(0,"r");
 453    PerlIO_fdopen(1,"w");
 454    PerlIO_fdopen(2,"w");
 455   }
 456  PerlIO_debug(__FUNCTION__ "\n");
 457 }
 458
 459 #undef PerlIO_stdin
 460 PerlIO *
 461 PerlIO_stdin(void)
 462 {
 463  if (!_perlio)
 464   PerlIO_init();
 465  return _perlio[0];
 466 }
 467
 468 #undef PerlIO_stdout
 469 PerlIO *
 470 PerlIO_stdout(void)
 471 {
 472  if (!_perlio)
 473   PerlIO_init();
 474  return _perlio[1];
 475 }
 476
 477 #undef PerlIO_stderr
 478 PerlIO *
 479 PerlIO_stderr(void)
 480 {
 481  if (!_perlio)
 482   PerlIO_init();
 483  return _perlio[2];
 484 }
 485
 486 #undef PerlIO_fast_gets
 487 int
 488 PerlIO_fast_gets(PerlIO *f)
 489 {
 490  return 1;
 491 }
 492
 493 #undef PerlIO_has_cntptr
 494 int
 495 PerlIO_has_cntptr(PerlIO *f)
 496 {
 497  return 1;
 498 }
 499
 500 #undef PerlIO_canset_cnt
 501 int
 502 PerlIO_canset_cnt(PerlIO *f)
 503 {
 504  return 1;
 505 }
 506
 507 #undef PerlIO_set_cnt
 508 void
 509 PerlIO_set_cnt(PerlIO *f, int cnt)
 510 {
 511  if (f)
 512   {
 513    dTHX;
 514    if (!f->buf)
 515     PerlIO_alloc_buf(f);
 516    f->ptr = f->end - cnt;
 517    assert(f->ptr >= f->buf);
 518   }
 519 }
 520
 521 #undef PerlIO_get_cnt
 522 int
 523 PerlIO_get_cnt(PerlIO *f)
 524 {
 525  if (f)
 526   {
 527    if (!f->buf)
 528     PerlIO_alloc_buf(f);
 529    if (f->flags & PERLIO_F_RDBUF)
 530     return (f->end - f->ptr);
 531   }
 532  return 0;
 533 }
 534
 535 #undef PerlIO_set_ptrcnt
 536 void
 537 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 538 {
 539  if (f)
 540   {
 541    if (!f->buf)
 542     PerlIO_alloc_buf(f);
 543    f->ptr = ptr;
 544    if (PerlIO_get_cnt(f) != cnt || f->ptr < f->buf)
 545     {
 546      dTHX;
 547      assert(PerlIO_get_cnt(f) == cnt);
 548      assert(f->ptr >= f->buf);
 549     }
 550    f->flags |= PERLIO_F_RDBUF;
 551   }
 552 }
 553
 554 #undef PerlIO_get_bufsiz
 555 int
 556 PerlIO_get_bufsiz(PerlIO *f)
 557 {
 558  if (f)
 559   {
 560    if (!f->buf)
 561     PerlIO_alloc_buf(f);
 562    return f->bufsiz;
 563   }
 564  return -1;
 565 }
 566
 567 #undef PerlIO_get_ptr
 568 STDCHAR *
 569 PerlIO_get_ptr(PerlIO *f)
 570 {
 571  if (f)
 572   {
 573    if (!f->buf)
 574     PerlIO_alloc_buf(f);
 575    return f->ptr;
 576   }
 577  return NULL;
 578 }
 579
 580 #undef PerlIO_get_base
 581 STDCHAR *
 582 PerlIO_get_base(PerlIO *f)
 583 {
 584  if (f)
 585   {
 586    if (!f->buf)
 587     PerlIO_alloc_buf(f);
 588    return f->buf;
 589   }
 590  return NULL;
 591 }
 592
 593 #undef PerlIO_has_base
 594 int
 595 PerlIO_has_base(PerlIO *f)
 596 {
 597  if (f)
 598   {
 599    if (!f->buf)
 600     PerlIO_alloc_buf(f);
 601    return f->buf != NULL;
 602   }
 603 }
 604
 605 #undef PerlIO_puts
 606 int
 607 PerlIO_puts(PerlIO *f, const char *s)
 608 {
 609  STRLEN len = strlen(s);
 610  return PerlIO_write(f,s,len);
 611 }
 612
 613 #undef PerlIO_eof
 614 int
 615 PerlIO_eof(PerlIO *f)
 616 {
 617  if (f)
 618   {
 619    return (f->flags & PERLIO_F_EOF) != 0;
 620   }
 621  return 1;
 622 }
 623
 624 #undef PerlIO_getname
 625 char *
 626 PerlIO_getname(PerlIO *f, char *buf)
 627 {
 628  dTHX;
 629  Perl_croak(aTHX_ "Don't know how to get file name");
 630  return NULL;
 631 }
 632
 633 #undef PerlIO_ungetc
 634 int
 635 PerlIO_ungetc(PerlIO *f, int ch)
 636 {
 637  if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf)
 638   {
 639    *--(f->ptr) = ch;
 640    return ch;
 641   }
 642  PerlIO_debug(__FUNCTION__ " f=%p c=%c - cannot\n",f,ch);
 643  return -1;
 644 }
 645
 646 #undef PerlIO_read
 647 SSize_t
 648 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 649 {
 650  STDCHAR *buf = (STDCHAR *) vbuf;
 651  if (f)
 652   {
 653    Size_t got = 0;
 654    if (!f->ptr)
 655     PerlIO_alloc_buf(f);
 656
 657    while (count > 0)
 658     {
 659      SSize_t avail = (f->end - f->ptr);
 660      if ((SSize_t) count < avail)
 661       avail = count;
 662      if (avail > 0)
 663       {
 664        Copy(f->ptr,buf,avail,char);
 665        got     += avail;
 666        f->ptr  += avail;
 667        count   -= avail;
 668        buf     += avail;
 669       }
 670      if (count && (f->ptr >= f->end))
 671       {
 672        PerlIO_flush(f);
 673        f->ptr = f->end = f->buf;
 674        avail = read(f->fd,f->ptr,f->bufsiz);
 675        if (avail <= 0)
 676         {
 677          if (avail == 0)
 678           f->flags |= PERLIO_F_EOF;
 679          else if (errno == EINTR)
 680           continue;
 681          else
 682           f->flags |= PERLIO_F_ERROR;
 683          break;
 684         }
 685        f->end   = f->buf+avail;
 686        f->flags |= PERLIO_F_RDBUF;
 687       }
 688     }
 689    return got;
 690   }
 691  return 0;
 692 }
 693
 694 #undef PerlIO_getc
 695 int
 696 PerlIO_getc(PerlIO *f)
 697 {
 698  STDCHAR buf;
 699  int count = PerlIO_read(f,&buf,1);
 700  if (count == 1)
 701   return (unsigned char) buf;
 702  return -1;
 703 }
 704
 705 #undef PerlIO_error
 706 int
 707 PerlIO_error(PerlIO *f)
 708 {
 709  if (f)
 710   {
 711    return f->flags & PERLIO_F_ERROR;
 712   }
 713  return 1;
 714 }
 715
 716 #undef PerlIO_clearerr
 717 void
 718 PerlIO_clearerr(PerlIO *f)
 719 {
 720  if (f)
 721   {
 722    f->flags &= ~PERLIO_F_ERROR;
 723   }
 724 }
 725
 726 #undef PerlIO_setlinebuf
 727 void
 728 PerlIO_setlinebuf(PerlIO *f)
 729 {
 730  if (f)
 731   {
 732    f->flags &= ~PERLIO_F_LINEBUF;
 733   }
 734 }
 735
 736 #undef PerlIO_write
 737 SSize_t
 738 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 739 {
 740  const STDCHAR *buf = (const STDCHAR *) vbuf;
 741  Size_t written = 0;
 742  PerlIO_debug(__FUNCTION__ " f=%p c=%d\n",f,count);
 743  if (f)
 744   {
 745    if (!f->buf)
 746     PerlIO_alloc_buf(f);
 747    while (count > 0)
 748     {
 749      SSize_t avail = f->bufsiz - (f->ptr - f->buf);
 750      if ((SSize_t) count < avail)
 751       avail = count;
 752      f->flags |= PERLIO_F_WRBUF;
 753      if (f->flags & PERLIO_F_LINEBUF)
 754       {
 755        while (avail > 0)
 756         {
 757          int ch = *buf++;
 758          *(f->ptr)++ = ch;
 759          count--;
 760          avail--;
 761          written++;
 762          if (ch == '\n')
 763           {
 764            PerlIO_flush(f);
 765            break;
 766           }
 767         }
 768       }
 769      else
 770       {
 771        if (avail)
 772         {
 773          Copy(buf,f->ptr,avail,char);
 774          count   -= avail;
 775          buf     += avail;
 776          written += avail;
 777          f->ptr  += avail;
 778         }
 779       }
 780      if (f->ptr >= (f->buf + f->bufsiz))
 781       PerlIO_flush(f);
 782     }
 783   }
 784  return written;
 785 }
 786
 787 #undef PerlIO_putc
 788 int
 789 PerlIO_putc(PerlIO *f, int ch)
 790 {
 791  STDCHAR buf = ch;
 792  PerlIO_write(f,&ch,1);
 793 }
 794
 795 #undef PerlIO_tell
 796 Off_t
 797 PerlIO_tell(PerlIO *f)
 798 {
 799  Off_t posn = f->posn;
 800  if (f->buf)
 801   posn += (f->ptr - f->buf);
 802  PerlIO_debug(__FUNCTION__ " f=%p b=%ld a=%ld\n",f,(long)f->posn,(long)posn);
 803  return posn;
 804 }
 805
 806 #undef PerlIO_seek
 807 int
 808 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 809 {
 810  int code;
 811  PerlIO_debug(__FUNCTION__ " f=%p i=%ld+%d\n",f,(long)f->posn,(f->ptr-f->buf));
 812  code = PerlIO_flush(f);
 813  if (code == 0)
 814   {
 815    f->flags &= ~PERLIO_F_EOF;
 816    f->posn = PerlLIO_lseek(f->fd,offset,whence);
 817    PerlIO_debug(__FUNCTION__ " f=%p o=%ld w=%d p=%ld\n",
 818                 f,(long)offset,whence,(long)f->posn);
 819    if (f->posn == (Off_t) -1)
 820     {
 821      f->posn = 0;
 822      code = -1;
 823     }
 824   }
 825  return code;
 826 }
 827
 828 #undef PerlIO_rewind
 829 void
 830 PerlIO_rewind(PerlIO *f)
 831 {
 832  PerlIO_seek(f,(Off_t)0,SEEK_SET);
 833 }
 834
 835 #undef PerlIO_vprintf
 836 int
 837 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
 838 {
 839  dTHX;
 840  SV *sv = newSVpvn("",0);
 841  char *s;
 842  STRLEN len;
 843  sv_vcatpvf(sv, fmt, &ap);
 844  s = SvPV(sv,len);
 845  return PerlIO_write(f,s,len);
 846 }
 847
 848 #undef PerlIO_printf
 849 int
 850 PerlIO_printf(PerlIO *f,const char *fmt,...)
 851 {
 852  va_list ap;
 853  int result;
 854  va_start(ap,fmt);
 855  result = PerlIO_vprintf(f,fmt,ap);
 856  va_end(ap);
 857  return result;
 858 }
 859
 860 #undef PerlIO_stdoutf
 861 int
 862 PerlIO_stdoutf(const char *fmt,...)
 863 {
 864  va_list ap;
 865  int result;
 866  va_start(ap,fmt);
 867  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
 868  va_end(ap);
 869  return result;
 870 }
 871
 872 #undef PerlIO_tmpfile
 873 PerlIO *
 874 PerlIO_tmpfile(void)
 875 {
 876  dTHX;
 877  /* I have no idea how portable mkstemp() is ... */
 878  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
 879  int fd = mkstemp(SvPVX(sv));
 880  PerlIO *f = NULL;
 881  if (fd >= 0)
 882   {
 883    f = PerlIO_fdopen(fd,"w+");
 884    if (f)
 885     {
 886      f->flags |= PERLIO_F_TEMP;
 887     }
 888    unlink(SvPVX(sv));
 889    SvREFCNT_dec(sv);
 890   }
 891  return f;
 892 }
 893
 894 #undef PerlIO_importFILE
 895 PerlIO *
 896 PerlIO_importFILE(FILE *f, int fl)
 897 {
 898  int fd = fileno(f);
 899  /* Should really push stdio discipline when we have them */
 900  return PerlIO_fdopen(fd,"r+");
 901 }
 902
 903 #undef PerlIO_exportFILE
 904 FILE *
 905 PerlIO_exportFILE(PerlIO *f, int fl)
 906 {
 907  PerlIO_flush(f);
 908  /* Should really push stdio discipline when we have them */
 909  return fdopen(PerlIO_fileno(f),"r+");
 910 }
 911
 912 #undef PerlIO_findFILE
 913 FILE *
 914 PerlIO_findFILE(PerlIO *f)
 915 {
 916  return PerlIO_exportFILE(f,0);
 917 }
 918
 919 #undef PerlIO_releaseFILE
 920 void
 921 PerlIO_releaseFILE(PerlIO *p, FILE *f)
 922 {
 923 }
 924
 925 #undef HAS_FSETPOS
 926 #undef HAS_FGETPOS
 927
 928 /*======================================================================================*/
 929
 930 #endif /* USE_SFIO */
 931 #endif /* PERLIO_IS_STDIO */
 932
 933 #ifndef HAS_FSETPOS
 934 #undef PerlIO_setpos
 935 int
 936 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 937 {
 938  return PerlIO_seek(f,*pos,0);
 939 }
 940 #else
 941 #ifndef PERLIO_IS_STDIO
 942 #undef PerlIO_setpos
 943 int
 944 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 945 {
 946 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 947  return fsetpos64(f, pos);
 948 #else
 949  return fsetpos(f, pos);
 950 #endif
 951 }
 952 #endif
 953 #endif
 954
 955 #ifndef HAS_FGETPOS
 956 #undef PerlIO_getpos
 957 int
 958 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 959 {
 960  *pos = PerlIO_tell(f);
 961  return 0;
 962 }
 963 #else
 964 #ifndef PERLIO_IS_STDIO
 965 #undef PerlIO_getpos
 966 int
 967 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 968 {
 969 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 970  return fgetpos64(f, pos);
 971 #else
 972  return fgetpos(f, pos);
 973 #endif
 974 }
 975 #endif
 976 #endif
 977
 978 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 979
 980 int
 981 vprintf(char *pat, char *args)
 982 {
 983     _doprnt(pat, args, stdout);
 984     return 0;           /* wrong, but perl doesn't use the return value */
 985 }
 986
 987 int
 988 vfprintf(FILE *fd, char *pat, char *args)
 989 {
 990     _doprnt(pat, args, fd);
 991     return 0;           /* wrong, but perl doesn't use the return value */
 992 }
 993
 994 #endif
 995
 996 #ifndef PerlIO_vsprintf
 997 int
 998 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 999 {
1000  int val = vsprintf(s, fmt, ap);
1001  if (n >= 0)
1002   {
1003    if (strlen(s) >= (STRLEN)n)
1004     {
1005      dTHX;
1006      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1007      my_exit(1);
1008     }
1009   }
1010  return val;
1011 }
1012 #endif
1013
1014 #ifndef PerlIO_sprintf
1015 int
1016 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1017 {
1018  va_list ap;
1019  int result;
1020  va_start(ap,fmt);
1021  result = PerlIO_vsprintf(s, n, fmt, ap);
1022  va_end(ap);
1023  return result;
1024 }
1025 #endif
1026
1027 #endif /* !PERL_IMPLICIT_SYS */
1028