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