Fixed two bugs:
[p5sagit/p5-mst-13.2.git] / perlio.c
CommitLineData
760ac839 1/* perlio.c
2 *
1761cee5 3 * Copyright (c) 1996-2000, Nick Ing-Simmons
760ac839 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
c5be433b 10
760ac839 11#define VOIDUSED 1
12ae5dfc 12#ifdef PERL_MICRO
13# include "uconfig.h"
14#else
15# include "config.h"
16#endif
760ac839 17
6f9d8c32 18#define PERLIO_NOT_STDIO 0
760ac839 19#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
6f9d8c32 20/* #define PerlIO FILE */
760ac839 21#endif
22/*
6f9d8c32 23 * This file provides those parts of PerlIO abstraction
0f4eea8f 24 * which are not #defined in iperlsys.h.
6f9d8c32 25 * Which these are depends on various Configure #ifdef's
760ac839 26 */
27
28#include "EXTERN.h"
864dbfa3 29#define PERL_IN_PERLIO_C
760ac839 30#include "perl.h"
31
32e30700 32#if !defined(PERL_IMPLICIT_SYS)
33
6f9d8c32 34#ifdef PERLIO_IS_STDIO
760ac839 35
36void
8ac85365 37PerlIO_init(void)
760ac839 38{
6f9d8c32 39 /* Does nothing (yet) except force this file to be included
760ac839 40 in perl binary. That allows this file to force inclusion
6f9d8c32 41 of other functions that may be required by loadable
42 extensions e.g. for FileHandle::tmpfile
760ac839 43 */
44}
45
33dcbb9a 46#undef PerlIO_tmpfile
47PerlIO *
8ac85365 48PerlIO_tmpfile(void)
33dcbb9a 49{
50 return tmpfile();
51}
52
760ac839 53#else /* PERLIO_IS_STDIO */
54
55#ifdef USE_SFIO
56
57#undef HAS_FSETPOS
58#undef HAS_FGETPOS
59
6f9d8c32 60/* This section is just to make sure these functions
760ac839 61 get pulled in from libsfio.a
62*/
63
64#undef PerlIO_tmpfile
65PerlIO *
c78749f2 66PerlIO_tmpfile(void)
760ac839 67{
68 return sftmp(0);
69}
70
71void
c78749f2 72PerlIO_init(void)
760ac839 73{
6f9d8c32 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
760ac839 77 */
78
79 /* Hack
80 * sfio does its own 'autoflush' on stdout in common cases.
6f9d8c32 81 * Flush results in a lot of lseek()s to regular files and
760ac839 82 * lot of small writes to pipes.
83 */
84 sfset(sfstdout,SF_SHARE,0);
85}
86
17c3b450 87#else /* USE_SFIO */
760ac839 88
6f9d8c32 89/*======================================================================================*/
90
91/* Implement all the PerlIO interface ourselves.
760ac839 92*/
93
6f9d8c32 94#undef printf
95void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
96
97
98void
99PerlIO_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
135struct _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 */
bb9950b7 144 Off_t posn; /* Offset of f->buf into the file */
6f9d8c32 145 int oneword;
146};
147
148int _perlio_size = 0;
149PerlIO **_perlio = NULL;
150
151void
152PerlIO_alloc_buf(PerlIO *f)
153{
154 if (!f->bufsiz)
bb9950b7 155 f->bufsiz = 4096;
6f9d8c32 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
169int
170PerlIO_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 {
bb9950b7 190 f->flags |= PERLIO_F_ERROR;
6f9d8c32 191 code = -1;
192 break;
193 }
194 }
195 f->posn += (p - f->buf);
bb9950b7 196 PerlIO_debug(__FUNCTION__ "(w) f=%p p=%ld\n",f,(long)f->posn);
6f9d8c32 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 }
bb9950b7 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);
6f9d8c32 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
229int
230PerlIO_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':
bb9950b7 257 oflags = O_CREAT|O_APPEND;
6f9d8c32 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
760ac839 276PerlIO *
6f9d8c32 277PerlIO_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
315PerlIO *
316PerlIO_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
333int
334PerlIO_fileno(PerlIO *f)
760ac839 335{
6f9d8c32 336 if (f && (f->flags & PERLIO_F_OPEN))
337 {
338 return f->fd;
339 }
340 return -1;
341}
342
343#undef PerlIO_close
344int
345PerlIO_close(PerlIO *f)
346{
bb9950b7 347 int code = 0;
6f9d8c32 348 if (f)
349 {
bb9950b7 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 }
6f9d8c32 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
373void
374PerlIO_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
394PerlIO *
395PerlIO_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
415PerlIO *
416PerlIO_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
441void
442PerlIO_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");
760ac839 452}
453
454#undef PerlIO_stdin
455PerlIO *
c78749f2 456PerlIO_stdin(void)
760ac839 457{
6f9d8c32 458 if (!_perlio)
459 PerlIO_init();
460 return _perlio[0];
760ac839 461}
462
463#undef PerlIO_stdout
464PerlIO *
c78749f2 465PerlIO_stdout(void)
760ac839 466{
6f9d8c32 467 if (!_perlio)
468 PerlIO_init();
469 return _perlio[1];
470}
471
472#undef PerlIO_stderr
473PerlIO *
474PerlIO_stderr(void)
475{
476 if (!_perlio)
477 PerlIO_init();
478 return _perlio[2];
760ac839 479}
480
760ac839 481#undef PerlIO_fast_gets
6f9d8c32 482int
c78749f2 483PerlIO_fast_gets(PerlIO *f)
760ac839 484{
760ac839 485 return 1;
760ac839 486}
487
488#undef PerlIO_has_cntptr
6f9d8c32 489int
c78749f2 490PerlIO_has_cntptr(PerlIO *f)
760ac839 491{
760ac839 492 return 1;
760ac839 493}
494
495#undef PerlIO_canset_cnt
6f9d8c32 496int
c78749f2 497PerlIO_canset_cnt(PerlIO *f)
760ac839 498{
760ac839 499 return 1;
760ac839 500}
501
502#undef PerlIO_set_cnt
503void
a20bf0c3 504PerlIO_set_cnt(PerlIO *f, int cnt)
760ac839 505{
6f9d8c32 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 }
760ac839 514}
515
6f9d8c32 516#undef PerlIO_get_cnt
517int
518PerlIO_get_cnt(PerlIO *f)
760ac839 519{
6f9d8c32 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;
760ac839 528}
529
6f9d8c32 530#undef PerlIO_set_ptrcnt
531void
532PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
760ac839 533{
6f9d8c32 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 }
bb9950b7 546 f->flags |= PERLIO_F_RDBUF;
6f9d8c32 547 }
760ac839 548}
549
550#undef PerlIO_get_bufsiz
6f9d8c32 551int
a20bf0c3 552PerlIO_get_bufsiz(PerlIO *f)
760ac839 553{
6f9d8c32 554 if (f)
555 {
556 if (!f->buf)
557 PerlIO_alloc_buf(f);
558 return f->bufsiz;
559 }
760ac839 560 return -1;
760ac839 561}
562
563#undef PerlIO_get_ptr
888911fc 564STDCHAR *
a20bf0c3 565PerlIO_get_ptr(PerlIO *f)
760ac839 566{
6f9d8c32 567 if (f)
568 {
569 if (!f->buf)
570 PerlIO_alloc_buf(f);
571 return f->ptr;
572 }
760ac839 573 return NULL;
760ac839 574}
575
576#undef PerlIO_get_base
888911fc 577STDCHAR *
a20bf0c3 578PerlIO_get_base(PerlIO *f)
760ac839 579{
6f9d8c32 580 if (f)
581 {
582 if (!f->buf)
583 PerlIO_alloc_buf(f);
584 return f->buf;
585 }
760ac839 586 return NULL;
760ac839 587}
588
6f9d8c32 589#undef PerlIO_has_base
590int
c78749f2 591PerlIO_has_base(PerlIO *f)
760ac839 592{
6f9d8c32 593 if (f)
594 {
595 if (!f->buf)
596 PerlIO_alloc_buf(f);
597 return f->buf != NULL;
598 }
760ac839 599}
600
601#undef PerlIO_puts
602int
c78749f2 603PerlIO_puts(PerlIO *f, const char *s)
760ac839 604{
6f9d8c32 605 STRLEN len = strlen(s);
606 return PerlIO_write(f,s,len);
760ac839 607}
608
609#undef PerlIO_eof
6f9d8c32 610int
c78749f2 611PerlIO_eof(PerlIO *f)
760ac839 612{
6f9d8c32 613 if (f)
614 {
615 return (f->flags & PERLIO_F_EOF) != 0;
616 }
617 return 1;
760ac839 618}
619
8c86a920 620#undef PerlIO_getname
621char *
a20bf0c3 622PerlIO_getname(PerlIO *f, char *buf)
8c86a920 623{
624#ifdef VMS
625 return fgetname(f,buf);
626#else
961e40ee 627 dTHX;
cea2e8a9 628 Perl_croak(aTHX_ "Don't know how to get file name");
c64afb19 629 return NULL;
8c86a920 630#endif
631}
632
6f9d8c32 633#undef PerlIO_ungetc
634int
635PerlIO_ungetc(PerlIO *f, int ch)
636{
6f9d8c32 637 if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf)
638 {
639 *--(f->ptr) = ch;
bb9950b7 640 PerlIO_debug(__FUNCTION__ " f=%p c=%c\n",f,ch);
6f9d8c32 641 return ch;
642 }
bb9950b7 643 PerlIO_debug(__FUNCTION__ " f=%p c=%c - cannot\n",f,ch);
6f9d8c32 644 return -1;
645}
646
647#undef PerlIO_read
648SSize_t
649PerlIO_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 {
bb9950b7 673 PerlIO_flush(f);
6f9d8c32 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
760ac839 695#undef PerlIO_getc
6f9d8c32 696int
c78749f2 697PerlIO_getc(PerlIO *f)
760ac839 698{
6f9d8c32 699 STDCHAR buf;
700 int count = PerlIO_read(f,&buf,1);
701 if (count == 1)
702 return buf;
703 return -1;
760ac839 704}
705
706#undef PerlIO_error
6f9d8c32 707int
c78749f2 708PerlIO_error(PerlIO *f)
760ac839 709{
6f9d8c32 710 if (f)
711 {
712 return f->flags & PERLIO_F_ERROR;
713 }
714 return 1;
760ac839 715}
716
717#undef PerlIO_clearerr
718void
c78749f2 719PerlIO_clearerr(PerlIO *f)
760ac839 720{
6f9d8c32 721 if (f)
722 {
723 f->flags &= ~PERLIO_F_ERROR;
724 }
760ac839 725}
726
727#undef PerlIO_setlinebuf
728void
c78749f2 729PerlIO_setlinebuf(PerlIO *f)
760ac839 730{
6f9d8c32 731 if (f)
732 {
733 f->flags &= ~PERLIO_F_LINEBUF;
734 }
760ac839 735}
736
737#undef PerlIO_write
5b54f415 738SSize_t
6f9d8c32 739PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 740{
6f9d8c32 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 {
bb9950b7 750 SSize_t avail = f->bufsiz - (f->ptr - f->buf);
751 if ((SSize_t) count < avail)
6f9d8c32 752 avail = count;
753 f->flags |= PERLIO_F_WRBUF;
bb9950b7 754 if (1 || (f->flags & PERLIO_F_LINEBUF))
6f9d8c32 755 {
756 while (avail > 0)
757 {
758 int ch = *buf++;
759 *(f->ptr)++ = ch;
760 count--;
761 avail--;
762 written++;
763 if (ch == '\n')
bb9950b7 764 {
765 PerlIO_flush(f);
766 break;
767 }
6f9d8c32 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;
760ac839 786}
787
6f9d8c32 788#undef PerlIO_putc
789int
790PerlIO_putc(PerlIO *f, int ch)
760ac839 791{
6f9d8c32 792 STDCHAR buf = ch;
793 PerlIO_write(f,&ch,1);
760ac839 794}
795
760ac839 796#undef PerlIO_tell
5ff3f7a4 797Off_t
c78749f2 798PerlIO_tell(PerlIO *f)
760ac839 799{
bb9950b7 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);
6f9d8c32 805 return posn;
760ac839 806}
807
808#undef PerlIO_seek
809int
c78749f2 810PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 811{
bb9950b7 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);
6f9d8c32 815 if (code == 0)
816 {
817 f->flags &= ~PERLIO_F_EOF;
bb9950b7 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);
6f9d8c32 821 if (f->posn == (Off_t) -1)
822 {
823 f->posn = 0;
824 code = -1;
825 }
826 }
827 return code;
760ac839 828}
829
830#undef PerlIO_rewind
831void
c78749f2 832PerlIO_rewind(PerlIO *f)
760ac839 833{
6f9d8c32 834 PerlIO_seek(f,(Off_t)0,SEEK_SET);
835}
836
837#undef PerlIO_vprintf
838int
839PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
840{
841 dTHX;
bb9950b7 842 SV *sv = newSVpvn("",0);
6f9d8c32 843 char *s;
844 STRLEN len;
845 sv_vcatpvf(sv, fmt, &ap);
846 s = SvPV(sv,len);
bb9950b7 847 return PerlIO_write(f,s,len);
760ac839 848}
849
850#undef PerlIO_printf
6f9d8c32 851int
760ac839 852PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839 853{
854 va_list ap;
855 int result;
760ac839 856 va_start(ap,fmt);
6f9d8c32 857 result = PerlIO_vprintf(f,fmt,ap);
760ac839 858 va_end(ap);
859 return result;
860}
861
862#undef PerlIO_stdoutf
6f9d8c32 863int
760ac839 864PerlIO_stdoutf(const char *fmt,...)
760ac839 865{
866 va_list ap;
867 int result;
760ac839 868 va_start(ap,fmt);
760ac839 869 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
870 va_end(ap);
871 return result;
872}
873
874#undef PerlIO_tmpfile
875PerlIO *
c78749f2 876PerlIO_tmpfile(void)
760ac839 877{
6f9d8c32 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;
760ac839 893}
894
895#undef PerlIO_importFILE
896PerlIO *
c78749f2 897PerlIO_importFILE(FILE *f, int fl)
760ac839 898{
6f9d8c32 899 int fd = fileno(f);
900 return PerlIO_fdopen(fd,"r+");
760ac839 901}
902
903#undef PerlIO_exportFILE
904FILE *
c78749f2 905PerlIO_exportFILE(PerlIO *f, int fl)
760ac839 906{
6f9d8c32 907 PerlIO_flush(f);
908 return fdopen(PerlIO_fileno(f),"r+");
760ac839 909}
910
911#undef PerlIO_findFILE
912FILE *
c78749f2 913PerlIO_findFILE(PerlIO *f)
760ac839 914{
6f9d8c32 915 return PerlIO_exportFILE(f,0);
760ac839 916}
917
918#undef PerlIO_releaseFILE
919void
c78749f2 920PerlIO_releaseFILE(PerlIO *p, FILE *f)
760ac839 921{
922}
923
6f9d8c32 924#undef HAS_FSETPOS
925#undef HAS_FGETPOS
926
927/*======================================================================================*/
760ac839 928
929#endif /* USE_SFIO */
930#endif /* PERLIO_IS_STDIO */
931
932#ifndef HAS_FSETPOS
933#undef PerlIO_setpos
934int
c78749f2 935PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 936{
6f9d8c32 937 return PerlIO_seek(f,*pos,0);
760ac839 938}
c411622e 939#else
940#ifndef PERLIO_IS_STDIO
941#undef PerlIO_setpos
942int
c78749f2 943PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 944{
2d4389e4 945#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d 946 return fsetpos64(f, pos);
947#else
c411622e 948 return fsetpos(f, pos);
d9b3e12d 949#endif
c411622e 950}
951#endif
760ac839 952#endif
953
954#ifndef HAS_FGETPOS
955#undef PerlIO_getpos
956int
c78749f2 957PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839 958{
959 *pos = PerlIO_tell(f);
960 return 0;
961}
c411622e 962#else
963#ifndef PERLIO_IS_STDIO
964#undef PerlIO_getpos
965int
c78749f2 966PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 967{
2d4389e4 968#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d 969 return fgetpos64(f, pos);
970#else
c411622e 971 return fgetpos(f, pos);
d9b3e12d 972#endif
c411622e 973}
974#endif
760ac839 975#endif
976
977#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
978
979int
c78749f2 980vprintf(char *pat, char *args)
662a7e3f 981{
982 _doprnt(pat, args, stdout);
983 return 0; /* wrong, but perl doesn't use the return value */
984}
985
986int
c78749f2 987vfprintf(FILE *fd, char *pat, char *args)
760ac839 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
6f9d8c32 996int
8ac85365 997PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839 998{
999 int val = vsprintf(s, fmt, ap);
1000 if (n >= 0)
1001 {
8c86a920 1002 if (strlen(s) >= (STRLEN)n)
760ac839 1003 {
bf49b057 1004 dTHX;
1005 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1006 my_exit(1);
760ac839 1007 }
1008 }
1009 return val;
1010}
1011#endif
1012
1013#ifndef PerlIO_sprintf
6f9d8c32 1014int
760ac839 1015PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839 1016{
1017 va_list ap;
1018 int result;
760ac839 1019 va_start(ap,fmt);
760ac839 1020 result = PerlIO_vsprintf(s, n, fmt, ap);
1021 va_end(ap);
1022 return result;
1023}
1024#endif
1025
c5be433b 1026#endif /* !PERL_IMPLICIT_SYS */
1027