Update Changes.
[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
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
0f4eea8f 24 * which are not #defined in iperlsys.h.
760ac839 25 * Which these are depends on various Configure #ifdef's
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
760ac839 34#ifdef PERLIO_IS_STDIO
35
36void
8ac85365 37PerlIO_init(void)
760ac839 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
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
60/* This section is just to make sure these functions
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{
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
17c3b450 87#else /* USE_SFIO */
760ac839 88
89/* Implement all the PerlIO interface using stdio.
90 - this should be only file to include <stdio.h>
91*/
92
93#undef PerlIO_stderr
94PerlIO *
c78749f2 95PerlIO_stderr(void)
760ac839 96{
97 return (PerlIO *) stderr;
98}
99
100#undef PerlIO_stdin
101PerlIO *
c78749f2 102PerlIO_stdin(void)
760ac839 103{
104 return (PerlIO *) stdin;
105}
106
107#undef PerlIO_stdout
108PerlIO *
c78749f2 109PerlIO_stdout(void)
760ac839 110{
111 return (PerlIO *) stdout;
112}
113
760ac839 114#undef PerlIO_fast_gets
115int
c78749f2 116PerlIO_fast_gets(PerlIO *f)
760ac839 117{
118#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
119 return 1;
120#else
121 return 0;
122#endif
123}
124
125#undef PerlIO_has_cntptr
126int
c78749f2 127PerlIO_has_cntptr(PerlIO *f)
760ac839 128{
129#if defined(USE_STDIO_PTR)
130 return 1;
131#else
132 return 0;
133#endif
134}
135
136#undef PerlIO_canset_cnt
137int
c78749f2 138PerlIO_canset_cnt(PerlIO *f)
760ac839 139{
140#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
141 return 1;
142#else
143 return 0;
144#endif
145}
146
147#undef PerlIO_set_cnt
148void
a20bf0c3 149PerlIO_set_cnt(PerlIO *f, int cnt)
760ac839 150{
961e40ee 151 dTHX;
152 if (cnt < -1 && ckWARN_d(WARN_INTERNAL))
0453d815 153 Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt);
760ac839 154#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
155 FILE_cnt(f) = cnt;
156#else
cea2e8a9 157 Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
760ac839 158#endif
159}
160
161#undef PerlIO_set_ptrcnt
162void
a20bf0c3 163PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
760ac839 164{
961e40ee 165 dTHX;
409faa39 166#ifdef FILE_bufsiz
888911fc 167 STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
168 int ec = e - ptr;
961e40ee 169 if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL))
0453d815 170 Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1);
961e40ee 171 if (cnt != ec && ckWARN_d(WARN_INTERNAL))
0453d815 172 Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec);
33dcbb9a 173#endif
760ac839 174#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
409faa39 175 FILE_ptr(f) = ptr;
760ac839 176#else
409faa39 177 Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system");
760ac839 178#endif
179#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
409faa39 180 FILE_cnt(f) = cnt;
760ac839 181#else
409faa39 182 Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
760ac839 183#endif
184}
185
186#undef PerlIO_get_cnt
187int
a20bf0c3 188PerlIO_get_cnt(PerlIO *f)
760ac839 189{
190#ifdef FILE_cnt
191 return FILE_cnt(f);
192#else
961e40ee 193 dTHX;
cea2e8a9 194 Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
760ac839 195 return -1;
196#endif
197}
198
199#undef PerlIO_get_bufsiz
200int
a20bf0c3 201PerlIO_get_bufsiz(PerlIO *f)
760ac839 202{
203#ifdef FILE_bufsiz
204 return FILE_bufsiz(f);
205#else
961e40ee 206 dTHX;
cea2e8a9 207 Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system");
760ac839 208 return -1;
209#endif
210}
211
212#undef PerlIO_get_ptr
888911fc 213STDCHAR *
a20bf0c3 214PerlIO_get_ptr(PerlIO *f)
760ac839 215{
216#ifdef FILE_ptr
888911fc 217 return FILE_ptr(f);
760ac839 218#else
961e40ee 219 dTHX;
cea2e8a9 220 Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system");
760ac839 221 return NULL;
222#endif
223}
224
225#undef PerlIO_get_base
888911fc 226STDCHAR *
a20bf0c3 227PerlIO_get_base(PerlIO *f)
760ac839 228{
229#ifdef FILE_base
888911fc 230 return FILE_base(f);
760ac839 231#else
961e40ee 232 dTHX;
cea2e8a9 233 Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system");
760ac839 234 return NULL;
235#endif
236}
237
238#undef PerlIO_has_base
239int
c78749f2 240PerlIO_has_base(PerlIO *f)
760ac839 241{
242#ifdef FILE_base
243 return 1;
244#else
245 return 0;
246#endif
247}
248
249#undef PerlIO_puts
250int
c78749f2 251PerlIO_puts(PerlIO *f, const char *s)
760ac839 252{
253 return fputs(s,f);
254}
255
256#undef PerlIO_open
257PerlIO *
c78749f2 258PerlIO_open(const char *path, const char *mode)
760ac839 259{
260 return fopen(path,mode);
261}
262
263#undef PerlIO_fdopen
264PerlIO *
c78749f2 265PerlIO_fdopen(int fd, const char *mode)
760ac839 266{
267 return fdopen(fd,mode);
268}
269
8c86a920 270#undef PerlIO_reopen
271PerlIO *
c78749f2 272PerlIO_reopen(const char *name, const char *mode, PerlIO *f)
8c86a920 273{
274 return freopen(name,mode,f);
275}
760ac839 276
277#undef PerlIO_close
278int
c78749f2 279PerlIO_close(PerlIO *f)
760ac839 280{
281 return fclose(f);
282}
283
284#undef PerlIO_eof
285int
c78749f2 286PerlIO_eof(PerlIO *f)
760ac839 287{
288 return feof(f);
289}
290
8c86a920 291#undef PerlIO_getname
292char *
a20bf0c3 293PerlIO_getname(PerlIO *f, char *buf)
8c86a920 294{
295#ifdef VMS
296 return fgetname(f,buf);
297#else
961e40ee 298 dTHX;
cea2e8a9 299 Perl_croak(aTHX_ "Don't know how to get file name");
c64afb19 300 return NULL;
8c86a920 301#endif
302}
303
760ac839 304#undef PerlIO_getc
305int
c78749f2 306PerlIO_getc(PerlIO *f)
760ac839 307{
308 return fgetc(f);
309}
310
311#undef PerlIO_error
312int
c78749f2 313PerlIO_error(PerlIO *f)
760ac839 314{
315 return ferror(f);
316}
317
318#undef PerlIO_clearerr
319void
c78749f2 320PerlIO_clearerr(PerlIO *f)
760ac839 321{
322 clearerr(f);
323}
324
325#undef PerlIO_flush
326int
c78749f2 327PerlIO_flush(PerlIO *f)
760ac839 328{
329 return Fflush(f);
330}
331
332#undef PerlIO_fileno
333int
c78749f2 334PerlIO_fileno(PerlIO *f)
760ac839 335{
336 return fileno(f);
337}
338
339#undef PerlIO_setlinebuf
340void
c78749f2 341PerlIO_setlinebuf(PerlIO *f)
760ac839 342{
343#ifdef HAS_SETLINEBUF
344 setlinebuf(f);
345#else
3e3baf6d 346# ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
347 setvbuf(f, Nullch, _IOLBF, BUFSIZ);
348# else
760ac839 349 setvbuf(f, Nullch, _IOLBF, 0);
3e3baf6d 350# endif
760ac839 351#endif
352}
353
354#undef PerlIO_putc
355int
c78749f2 356PerlIO_putc(PerlIO *f, int ch)
760ac839 357{
9010f3dd 358 return putc(ch,f);
760ac839 359}
360
361#undef PerlIO_ungetc
362int
c78749f2 363PerlIO_ungetc(PerlIO *f, int ch)
760ac839 364{
9010f3dd 365 return ungetc(ch,f);
760ac839 366}
367
368#undef PerlIO_read
5b54f415 369SSize_t
c78749f2 370PerlIO_read(PerlIO *f, void *buf, Size_t count)
760ac839 371{
372 return fread(buf,1,count,f);
373}
374
375#undef PerlIO_write
5b54f415 376SSize_t
c78749f2 377PerlIO_write(PerlIO *f, const void *buf, Size_t count)
760ac839 378{
379 return fwrite1(buf,1,count,f);
380}
381
382#undef PerlIO_vprintf
383int
c78749f2 384PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
760ac839 385{
386 return vfprintf(f,fmt,ap);
387}
388
760ac839 389#undef PerlIO_tell
5ff3f7a4 390Off_t
c78749f2 391PerlIO_tell(PerlIO *f)
760ac839 392{
dad16317 393#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
394 return ftello(f);
395#else
760ac839 396 return ftell(f);
dad16317 397#endif
760ac839 398}
399
400#undef PerlIO_seek
401int
c78749f2 402PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 403{
dad16317 404#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
405 return fseeko(f,offset,whence);
406#else
760ac839 407 return fseek(f,offset,whence);
dad16317 408#endif
760ac839 409}
410
411#undef PerlIO_rewind
412void
c78749f2 413PerlIO_rewind(PerlIO *f)
760ac839 414{
415 rewind(f);
416}
417
418#undef PerlIO_printf
419int
760ac839 420PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839 421{
422 va_list ap;
423 int result;
760ac839 424 va_start(ap,fmt);
760ac839 425 result = vfprintf(f,fmt,ap);
426 va_end(ap);
427 return result;
428}
429
430#undef PerlIO_stdoutf
431int
760ac839 432PerlIO_stdoutf(const char *fmt,...)
760ac839 433{
434 va_list ap;
435 int result;
760ac839 436 va_start(ap,fmt);
760ac839 437 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
438 va_end(ap);
439 return result;
440}
441
442#undef PerlIO_tmpfile
443PerlIO *
c78749f2 444PerlIO_tmpfile(void)
760ac839 445{
446 return tmpfile();
447}
448
449#undef PerlIO_importFILE
450PerlIO *
c78749f2 451PerlIO_importFILE(FILE *f, int fl)
760ac839 452{
453 return f;
454}
455
456#undef PerlIO_exportFILE
457FILE *
c78749f2 458PerlIO_exportFILE(PerlIO *f, int fl)
760ac839 459{
460 return f;
461}
462
463#undef PerlIO_findFILE
464FILE *
c78749f2 465PerlIO_findFILE(PerlIO *f)
760ac839 466{
467 return f;
468}
469
470#undef PerlIO_releaseFILE
471void
c78749f2 472PerlIO_releaseFILE(PerlIO *p, FILE *f)
760ac839 473{
474}
475
476void
c78749f2 477PerlIO_init(void)
760ac839 478{
479 /* Does nothing (yet) except force this file to be included
480 in perl binary. That allows this file to force inclusion
481 of other functions that may be required by loadable
482 extensions e.g. for FileHandle::tmpfile
483 */
484}
485
486#endif /* USE_SFIO */
487#endif /* PERLIO_IS_STDIO */
488
489#ifndef HAS_FSETPOS
490#undef PerlIO_setpos
491int
c78749f2 492PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 493{
494 return PerlIO_seek(f,*pos,0);
495}
c411622e 496#else
497#ifndef PERLIO_IS_STDIO
498#undef PerlIO_setpos
499int
c78749f2 500PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 501{
2d4389e4 502#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d 503 return fsetpos64(f, pos);
504#else
c411622e 505 return fsetpos(f, pos);
d9b3e12d 506#endif
c411622e 507}
508#endif
760ac839 509#endif
510
511#ifndef HAS_FGETPOS
512#undef PerlIO_getpos
513int
c78749f2 514PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839 515{
516 *pos = PerlIO_tell(f);
517 return 0;
518}
c411622e 519#else
520#ifndef PERLIO_IS_STDIO
521#undef PerlIO_getpos
522int
c78749f2 523PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 524{
2d4389e4 525#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d 526 return fgetpos64(f, pos);
527#else
c411622e 528 return fgetpos(f, pos);
d9b3e12d 529#endif
c411622e 530}
531#endif
760ac839 532#endif
533
534#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
535
536int
c78749f2 537vprintf(char *pat, char *args)
662a7e3f 538{
539 _doprnt(pat, args, stdout);
540 return 0; /* wrong, but perl doesn't use the return value */
541}
542
543int
c78749f2 544vfprintf(FILE *fd, char *pat, char *args)
760ac839 545{
546 _doprnt(pat, args, fd);
547 return 0; /* wrong, but perl doesn't use the return value */
548}
549
550#endif
551
552#ifndef PerlIO_vsprintf
553int
8ac85365 554PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839 555{
556 int val = vsprintf(s, fmt, ap);
557 if (n >= 0)
558 {
8c86a920 559 if (strlen(s) >= (STRLEN)n)
760ac839 560 {
bf49b057 561 dTHX;
562 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
563 my_exit(1);
760ac839 564 }
565 }
566 return val;
567}
568#endif
569
570#ifndef PerlIO_sprintf
571int
760ac839 572PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839 573{
574 va_list ap;
575 int result;
760ac839 576 va_start(ap,fmt);
760ac839 577 result = PerlIO_vsprintf(s, n, fmt, ap);
578 va_end(ap);
579 return result;
580}
581#endif
582
c5be433b 583#endif /* !PERL_IMPLICIT_SYS */
584