This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change files which are mysteriously different to mainline to be
[perl5.git] / perlio.c
CommitLineData
760ac839
LW
1/* perlio.c
2 *
1761cee5 3 * Copyright (c) 1996-2000, Nick Ing-Simmons
760ac839
LW
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
12ae5dfc
JH
11#ifdef PERL_MICRO
12# include "uconfig.h"
13#else
14# include "config.h"
15#endif
760ac839 16
6f9d8c32 17#define PERLIO_NOT_STDIO 0
760ac839 18#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
6f9d8c32 19/* #define PerlIO FILE */
760ac839
LW
20#endif
21/*
6f9d8c32 22 * This file provides those parts of PerlIO abstraction
0f4eea8f 23 * which are not #defined in iperlsys.h.
6f9d8c32 24 * Which these are depends on various Configure #ifdef's
760ac839
LW
25 */
26
27#include "EXTERN.h"
864dbfa3 28#define PERL_IN_PERLIO_C
760ac839
LW
29#include "perl.h"
30
32e30700
GS
31#if !defined(PERL_IMPLICIT_SYS)
32
6f9d8c32 33#ifdef PERLIO_IS_STDIO
760ac839
LW
34
35void
8ac85365 36PerlIO_init(void)
760ac839 37{
6f9d8c32 38 /* Does nothing (yet) except force this file to be included
760ac839 39 in perl binary. That allows this file to force inclusion
6f9d8c32
NIS
40 of other functions that may be required by loadable
41 extensions e.g. for FileHandle::tmpfile
760ac839
LW
42 */
43}
44
33dcbb9a
PP
45#undef PerlIO_tmpfile
46PerlIO *
8ac85365 47PerlIO_tmpfile(void)
33dcbb9a
PP
48{
49 return tmpfile();
50}
51
760ac839
LW
52#else /* PERLIO_IS_STDIO */
53
54#ifdef USE_SFIO
55
56#undef HAS_FSETPOS
57#undef HAS_FGETPOS
58
6f9d8c32 59/* This section is just to make sure these functions
760ac839
LW
60 get pulled in from libsfio.a
61*/
62
63#undef PerlIO_tmpfile
64PerlIO *
c78749f2 65PerlIO_tmpfile(void)
760ac839
LW
66{
67 return sftmp(0);
68}
69
70void
c78749f2 71PerlIO_init(void)
760ac839 72{
6f9d8c32
NIS
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
760ac839
LW
76 */
77
78 /* Hack
79 * sfio does its own 'autoflush' on stdout in common cases.
6f9d8c32 80 * Flush results in a lot of lseek()s to regular files and
760ac839
LW
81 * lot of small writes to pipes.
82 */
83 sfset(sfstdout,SF_SHARE,0);
84}
85
17c3b450 86#else /* USE_SFIO */
760ac839 87
6f9d8c32
NIS
88/*======================================================================================*/
89
90/* Implement all the PerlIO interface ourselves.
760ac839
LW
91*/
92
b1ef6e3b 93/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
02f66e2f
NIS
94#ifdef I_UNISTD
95#include <unistd.h>
96#endif
97
6f9d8c32
NIS
98#undef printf
99void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
100
6f9d8c32
NIS
101void
102PerlIO_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
138struct _PerlIO
139{
b1ef6e3b 140 IV flags; /* Various flags for state */
6f9d8c32
NIS
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 */
bb9950b7 147 Off_t posn; /* Offset of f->buf into the file */
b1ef6e3b 148 int oneword; /* An if-all-else-fails area as a buffer */
6f9d8c32
NIS
149};
150
b1ef6e3b 151/* Table of pointers to the PerlIO structs (malloc'ed) */
6f9d8c32 152PerlIO **_perlio = NULL;
b1ef6e3b 153int _perlio_size = 0;
6f9d8c32
NIS
154
155void
156PerlIO_alloc_buf(PerlIO *f)
157{
158 if (!f->bufsiz)
bb9950b7 159 f->bufsiz = 4096;
6f9d8c32
NIS
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;
6f9d8c32
NIS
168}
169
b1ef6e3b
NIS
170
171/* This "flush" is akin to sfio's sync in that it handles files in either
172 read or write state
173*/
6f9d8c32
NIS
174#undef PerlIO_flush
175int
176PerlIO_flush(PerlIO *f)
177{
178 int code = 0;
179 if (f)
180 {
6f9d8c32
NIS
181 if (f->flags & PERLIO_F_WRBUF)
182 {
b1ef6e3b 183 /* write() the buffer */
6f9d8c32
NIS
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 {
bb9950b7 195 f->flags |= PERLIO_F_ERROR;
6f9d8c32
NIS
196 code = -1;
197 break;
198 }
199 }
200 f->posn += (p - f->buf);
201 }
202 else if (f->flags & PERLIO_F_RDBUF)
203 {
b1ef6e3b 204 /* Note position change */
6f9d8c32
NIS
205 f->posn += (f->ptr - f->buf);
206 if (f->ptr < f->end)
207 {
b1ef6e3b 208 /* We did not consume all of it */
6f9d8c32
NIS
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;
f89522bf 218 for (i=_perlio_size-1; i >= 0; i--)
6f9d8c32
NIS
219 {
220 if ((f = _perlio[i]))
221 {
222 if (PerlIO_flush(f) != 0)
223 code = -1;
224 }
225 }
226 }
227 return code;
228}
229
230int
231PerlIO_oflags(const char *mode)
232{
233 int oflags = -1;
6f9d8c32
NIS
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
NIS
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 }
6f9d8c32
NIS
272 return oflags;
273}
274
760ac839 275PerlIO *
6f9d8c32
NIS
276PerlIO_allocate(void)
277{
b1ef6e3b 278 /* Find a free slot in the table, growing table as necessary */
6f9d8c32
NIS
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];
6f9d8c32
NIS
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
314PerlIO *
315PerlIO_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 }
6f9d8c32
NIS
327 return f;
328}
329
330#undef PerlIO_fileno
331int
332PerlIO_fileno(PerlIO *f)
760ac839 333{
6f9d8c32
NIS
334 if (f && (f->flags & PERLIO_F_OPEN))
335 {
336 return f->fd;
337 }
338 return -1;
339}
340
341#undef PerlIO_close
342int
343PerlIO_close(PerlIO *f)
344{
bb9950b7 345 int code = 0;
6f9d8c32
NIS
346 if (f)
347 {
bb9950b7
NIS
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 }
6f9d8c32
NIS
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
371void
372PerlIO_cleanup(void)
373{
b1ef6e3b 374 /* Close all the files */
6f9d8c32 375 int i;
6f9d8c32
NIS
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
392PerlIO *
393PerlIO_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 {
6f9d8c32
NIS
402 f = PerlIO_fdopen(fd,mode);
403 if (!f)
404 close(fd);
405 }
406 }
6f9d8c32
NIS
407 return f;
408}
409
410#undef PerlIO_reopen
411PerlIO *
412PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
413{
6f9d8c32
NIS
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 {
6f9d8c32
NIS
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
435void
436PerlIO_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 }
760ac839
LW
445}
446
447#undef PerlIO_stdin
448PerlIO *
c78749f2 449PerlIO_stdin(void)
760ac839 450{
6f9d8c32
NIS
451 if (!_perlio)
452 PerlIO_init();
453 return _perlio[0];
760ac839
LW
454}
455
456#undef PerlIO_stdout
457PerlIO *
c78749f2 458PerlIO_stdout(void)
760ac839 459{
6f9d8c32
NIS
460 if (!_perlio)
461 PerlIO_init();
462 return _perlio[1];
463}
464
465#undef PerlIO_stderr
466PerlIO *
467PerlIO_stderr(void)
468{
469 if (!_perlio)
470 PerlIO_init();
471 return _perlio[2];
760ac839
LW
472}
473
760ac839 474#undef PerlIO_fast_gets
6f9d8c32 475int
c78749f2 476PerlIO_fast_gets(PerlIO *f)
760ac839 477{
760ac839 478 return 1;
760ac839
LW
479}
480
481#undef PerlIO_has_cntptr
6f9d8c32 482int
c78749f2 483PerlIO_has_cntptr(PerlIO *f)
760ac839 484{
760ac839 485 return 1;
760ac839
LW
486}
487
488#undef PerlIO_canset_cnt
6f9d8c32 489int
c78749f2 490PerlIO_canset_cnt(PerlIO *f)
760ac839 491{
760ac839 492 return 1;
760ac839
LW
493}
494
495#undef PerlIO_set_cnt
496void
a20bf0c3 497PerlIO_set_cnt(PerlIO *f, int cnt)
760ac839 498{
6f9d8c32
NIS
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 }
760ac839
LW
507}
508
6f9d8c32
NIS
509#undef PerlIO_get_cnt
510int
511PerlIO_get_cnt(PerlIO *f)
760ac839 512{
6f9d8c32
NIS
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;
760ac839
LW
521}
522
6f9d8c32
NIS
523#undef PerlIO_set_ptrcnt
524void
525PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
760ac839 526{
6f9d8c32
NIS
527 if (f)
528 {
6f9d8c32
NIS
529 if (!f->buf)
530 PerlIO_alloc_buf(f);
531 f->ptr = ptr;
b1ef6e3b 532 if (PerlIO_get_cnt(f) != cnt || f->ptr < f->buf)
6f9d8c32
NIS
533 {
534 dTHX;
b1ef6e3b
NIS
535 assert(PerlIO_get_cnt(f) == cnt);
536 assert(f->ptr >= f->buf);
6f9d8c32 537 }
bb9950b7 538 f->flags |= PERLIO_F_RDBUF;
6f9d8c32 539 }
760ac839
LW
540}
541
542#undef PerlIO_get_bufsiz
6f9d8c32 543int
a20bf0c3 544PerlIO_get_bufsiz(PerlIO *f)
760ac839 545{
6f9d8c32
NIS
546 if (f)
547 {
548 if (!f->buf)
549 PerlIO_alloc_buf(f);
550 return f->bufsiz;
551 }
760ac839 552 return -1;
760ac839
LW
553}
554
555#undef PerlIO_get_ptr
888911fc 556STDCHAR *
a20bf0c3 557PerlIO_get_ptr(PerlIO *f)
760ac839 558{
6f9d8c32
NIS
559 if (f)
560 {
561 if (!f->buf)
562 PerlIO_alloc_buf(f);
563 return f->ptr;
564 }
760ac839 565 return NULL;
760ac839
LW
566}
567
568#undef PerlIO_get_base
888911fc 569STDCHAR *
a20bf0c3 570PerlIO_get_base(PerlIO *f)
760ac839 571{
6f9d8c32
NIS
572 if (f)
573 {
574 if (!f->buf)
575 PerlIO_alloc_buf(f);
576 return f->buf;
577 }
760ac839 578 return NULL;
760ac839
LW
579}
580
6f9d8c32
NIS
581#undef PerlIO_has_base
582int
c78749f2 583PerlIO_has_base(PerlIO *f)
760ac839 584{
6f9d8c32
NIS
585 if (f)
586 {
587 if (!f->buf)
588 PerlIO_alloc_buf(f);
589 return f->buf != NULL;
590 }
760ac839
LW
591}
592
593#undef PerlIO_puts
594int
c78749f2 595PerlIO_puts(PerlIO *f, const char *s)
760ac839 596{
6f9d8c32
NIS
597 STRLEN len = strlen(s);
598 return PerlIO_write(f,s,len);
760ac839
LW
599}
600
601#undef PerlIO_eof
6f9d8c32 602int
c78749f2 603PerlIO_eof(PerlIO *f)
760ac839 604{
6f9d8c32
NIS
605 if (f)
606 {
607 return (f->flags & PERLIO_F_EOF) != 0;
608 }
609 return 1;
760ac839
LW
610}
611
8c86a920
PP
612#undef PerlIO_getname
613char *
a20bf0c3 614PerlIO_getname(PerlIO *f, char *buf)
8c86a920 615{
961e40ee 616 dTHX;
cea2e8a9 617 Perl_croak(aTHX_ "Don't know how to get file name");
c64afb19 618 return NULL;
8c86a920
PP
619}
620
6f9d8c32
NIS
621#undef PerlIO_ungetc
622int
623PerlIO_ungetc(PerlIO *f, int ch)
624{
6f9d8c32
NIS
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
634SSize_t
635PerlIO_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);
f89522bf
NIS
643 if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_WRONLY)
644 return 0;
6f9d8c32
NIS
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 {
bb9950b7 660 PerlIO_flush(f);
6f9d8c32
NIS
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
760ac839 682#undef PerlIO_getc
6f9d8c32 683int
c78749f2 684PerlIO_getc(PerlIO *f)
760ac839 685{
6f9d8c32
NIS
686 STDCHAR buf;
687 int count = PerlIO_read(f,&buf,1);
688 if (count == 1)
b1ef6e3b 689 return (unsigned char) buf;
6f9d8c32 690 return -1;
760ac839
LW
691}
692
693#undef PerlIO_error
6f9d8c32 694int
c78749f2 695PerlIO_error(PerlIO *f)
760ac839 696{
6f9d8c32
NIS
697 if (f)
698 {
699 return f->flags & PERLIO_F_ERROR;
700 }
701 return 1;
760ac839
LW
702}
703
704#undef PerlIO_clearerr
705void
c78749f2 706PerlIO_clearerr(PerlIO *f)
760ac839 707{
6f9d8c32
NIS
708 if (f)
709 {
710 f->flags &= ~PERLIO_F_ERROR;
711 }
760ac839
LW
712}
713
714#undef PerlIO_setlinebuf
715void
c78749f2 716PerlIO_setlinebuf(PerlIO *f)
760ac839 717{
6f9d8c32
NIS
718 if (f)
719 {
720 f->flags &= ~PERLIO_F_LINEBUF;
721 }
760ac839
LW
722}
723
724#undef PerlIO_write
5b54f415 725SSize_t
6f9d8c32 726PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 727{
6f9d8c32
NIS
728 const STDCHAR *buf = (const STDCHAR *) vbuf;
729 Size_t written = 0;
6f9d8c32
NIS
730 if (f)
731 {
732 if (!f->buf)
733 PerlIO_alloc_buf(f);
f89522bf
NIS
734 if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_RDONLY)
735 return 0;
6f9d8c32
NIS
736 while (count > 0)
737 {
bb9950b7
NIS
738 SSize_t avail = f->bufsiz - (f->ptr - f->buf);
739 if ((SSize_t) count < avail)
6f9d8c32
NIS
740 avail = count;
741 f->flags |= PERLIO_F_WRBUF;
b1ef6e3b 742 if (f->flags & PERLIO_F_LINEBUF)
6f9d8c32
NIS
743 {
744 while (avail > 0)
745 {
746 int ch = *buf++;
747 *(f->ptr)++ = ch;
748 count--;
749 avail--;
750 written++;
751 if (ch == '\n')
bb9950b7
NIS
752 {
753 PerlIO_flush(f);
754 break;
755 }
6f9d8c32
NIS
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;
760ac839
LW
774}
775
6f9d8c32
NIS
776#undef PerlIO_putc
777int
778PerlIO_putc(PerlIO *f, int ch)
760ac839 779{
6f9d8c32 780 STDCHAR buf = ch;
f89522bf 781 PerlIO_write(f,&buf,1);
760ac839
LW
782}
783
760ac839 784#undef PerlIO_tell
5ff3f7a4 785Off_t
c78749f2 786PerlIO_tell(PerlIO *f)
760ac839 787{
bb9950b7
NIS
788 Off_t posn = f->posn;
789 if (f->buf)
790 posn += (f->ptr - f->buf);
6f9d8c32 791 return posn;
760ac839
LW
792}
793
794#undef PerlIO_seek
795int
c78749f2 796PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 797{
bb9950b7 798 int code;
bb9950b7 799 code = PerlIO_flush(f);
6f9d8c32
NIS
800 if (code == 0)
801 {
802 f->flags &= ~PERLIO_F_EOF;
bb9950b7 803 f->posn = PerlLIO_lseek(f->fd,offset,whence);
6f9d8c32
NIS
804 if (f->posn == (Off_t) -1)
805 {
806 f->posn = 0;
807 code = -1;
808 }
809 }
810 return code;
760ac839
LW
811}
812
813#undef PerlIO_rewind
814void
c78749f2 815PerlIO_rewind(PerlIO *f)
760ac839 816{
6f9d8c32
NIS
817 PerlIO_seek(f,(Off_t)0,SEEK_SET);
818}
819
820#undef PerlIO_vprintf
821int
822PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
823{
824 dTHX;
bb9950b7 825 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
826 char *s;
827 STRLEN len;
828 sv_vcatpvf(sv, fmt, &ap);
829 s = SvPV(sv,len);
bb9950b7 830 return PerlIO_write(f,s,len);
760ac839
LW
831}
832
833#undef PerlIO_printf
6f9d8c32 834int
760ac839 835PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
836{
837 va_list ap;
838 int result;
760ac839 839 va_start(ap,fmt);
6f9d8c32 840 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
841 va_end(ap);
842 return result;
843}
844
845#undef PerlIO_stdoutf
6f9d8c32 846int
760ac839 847PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
848{
849 va_list ap;
850 int result;
760ac839 851 va_start(ap,fmt);
760ac839
LW
852 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
853 va_end(ap);
854 return result;
855}
856
857#undef PerlIO_tmpfile
858PerlIO *
c78749f2 859PerlIO_tmpfile(void)
760ac839 860{
6f9d8c32 861 dTHX;
b1ef6e3b 862 /* I have no idea how portable mkstemp() is ... */
6f9d8c32
NIS
863 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
864 int fd = mkstemp(SvPVX(sv));
865 PerlIO *f = NULL;
866 if (fd >= 0)
867 {
b1ef6e3b 868 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
869 if (f)
870 {
871 f->flags |= PERLIO_F_TEMP;
872 }
873 unlink(SvPVX(sv));
874 SvREFCNT_dec(sv);
875 }
876 return f;
760ac839
LW
877}
878
879#undef PerlIO_importFILE
880PerlIO *
c78749f2 881PerlIO_importFILE(FILE *f, int fl)
760ac839 882{
6f9d8c32 883 int fd = fileno(f);
b1ef6e3b 884 /* Should really push stdio discipline when we have them */
6f9d8c32 885 return PerlIO_fdopen(fd,"r+");
760ac839
LW
886}
887
888#undef PerlIO_exportFILE
889FILE *
c78749f2 890PerlIO_exportFILE(PerlIO *f, int fl)
760ac839 891{
6f9d8c32 892 PerlIO_flush(f);
b1ef6e3b 893 /* Should really push stdio discipline when we have them */
6f9d8c32 894 return fdopen(PerlIO_fileno(f),"r+");
760ac839
LW
895}
896
897#undef PerlIO_findFILE
898FILE *
c78749f2 899PerlIO_findFILE(PerlIO *f)
760ac839 900{
6f9d8c32 901 return PerlIO_exportFILE(f,0);
760ac839
LW
902}
903
904#undef PerlIO_releaseFILE
905void
c78749f2 906PerlIO_releaseFILE(PerlIO *p, FILE *f)
760ac839
LW
907{
908}
909
6f9d8c32
NIS
910#undef HAS_FSETPOS
911#undef HAS_FGETPOS
912
913/*======================================================================================*/
760ac839
LW
914
915#endif /* USE_SFIO */
916#endif /* PERLIO_IS_STDIO */
917
918#ifndef HAS_FSETPOS
919#undef PerlIO_setpos
920int
c78749f2 921PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 922{
6f9d8c32 923 return PerlIO_seek(f,*pos,0);
760ac839 924}
c411622e
PP
925#else
926#ifndef PERLIO_IS_STDIO
927#undef PerlIO_setpos
928int
c78749f2 929PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 930{
2d4389e4 931#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
932 return fsetpos64(f, pos);
933#else
c411622e 934 return fsetpos(f, pos);
d9b3e12d 935#endif
c411622e
PP
936}
937#endif
760ac839
LW
938#endif
939
940#ifndef HAS_FGETPOS
941#undef PerlIO_getpos
942int
c78749f2 943PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
944{
945 *pos = PerlIO_tell(f);
946 return 0;
947}
c411622e
PP
948#else
949#ifndef PERLIO_IS_STDIO
950#undef PerlIO_getpos
951int
c78749f2 952PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 953{
2d4389e4 954#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
955 return fgetpos64(f, pos);
956#else
c411622e 957 return fgetpos(f, pos);
d9b3e12d 958#endif
c411622e
PP
959}
960#endif
760ac839
LW
961#endif
962
963#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
964
965int
c78749f2 966vprintf(char *pat, char *args)
662a7e3f
CS
967{
968 _doprnt(pat, args, stdout);
969 return 0; /* wrong, but perl doesn't use the return value */
970}
971
972int
c78749f2 973vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
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
6f9d8c32 982int
8ac85365 983PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
984{
985 int val = vsprintf(s, fmt, ap);
986 if (n >= 0)
987 {
8c86a920 988 if (strlen(s) >= (STRLEN)n)
760ac839 989 {
bf49b057
GS
990 dTHX;
991 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
992 my_exit(1);
760ac839
LW
993 }
994 }
995 return val;
996}
997#endif
998
999#ifndef PerlIO_sprintf
6f9d8c32 1000int
760ac839 1001PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
1002{
1003 va_list ap;
1004 int result;
760ac839 1005 va_start(ap,fmt);
760ac839
LW
1006 result = PerlIO_vsprintf(s, n, fmt, ap);
1007 va_end(ap);
1008 return result;
1009}
1010#endif
1011
c5be433b
GS
1012#endif /* !PERL_IMPLICIT_SYS */
1013