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