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