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