Commit | Line | Data |
---|---|---|
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 | ||
c5be433b | 10 | |
760ac839 | 11 | #define VOIDUSED 1 |
12ae5dfc JH |
12 | #ifdef PERL_MICRO |
13 | # include "uconfig.h" | |
14 | #else | |
15 | # include "config.h" | |
16 | #endif | |
760ac839 LW |
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 LW |
25 | * Which these are depends on various Configure #ifdef's |
26 | */ | |
27 | ||
28 | #include "EXTERN.h" | |
864dbfa3 | 29 | #define PERL_IN_PERLIO_C |
760ac839 LW |
30 | #include "perl.h" |
31 | ||
32e30700 GS |
32 | #if !defined(PERL_IMPLICIT_SYS) |
33 | ||
760ac839 LW |
34 | #ifdef PERLIO_IS_STDIO |
35 | ||
36 | void | |
8ac85365 | 37 | PerlIO_init(void) |
760ac839 LW |
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 |
47 | PerlIO * | |
8ac85365 | 48 | PerlIO_tmpfile(void) |
33dcbb9a | 49 | { |
50 | return tmpfile(); | |
51 | } | |
52 | ||
760ac839 LW |
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 * | |
c78749f2 | 66 | PerlIO_tmpfile(void) |
760ac839 LW |
67 | { |
68 | return sftmp(0); | |
69 | } | |
70 | ||
71 | void | |
c78749f2 | 72 | PerlIO_init(void) |
760ac839 LW |
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 LW |
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 | |
94 | PerlIO * | |
c78749f2 | 95 | PerlIO_stderr(void) |
760ac839 LW |
96 | { |
97 | return (PerlIO *) stderr; | |
98 | } | |
99 | ||
100 | #undef PerlIO_stdin | |
101 | PerlIO * | |
c78749f2 | 102 | PerlIO_stdin(void) |
760ac839 LW |
103 | { |
104 | return (PerlIO *) stdin; | |
105 | } | |
106 | ||
107 | #undef PerlIO_stdout | |
108 | PerlIO * | |
c78749f2 | 109 | PerlIO_stdout(void) |
760ac839 LW |
110 | { |
111 | return (PerlIO *) stdout; | |
112 | } | |
113 | ||
760ac839 LW |
114 | #undef PerlIO_fast_gets |
115 | int | |
c78749f2 | 116 | PerlIO_fast_gets(PerlIO *f) |
760ac839 LW |
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 | |
126 | int | |
c78749f2 | 127 | PerlIO_has_cntptr(PerlIO *f) |
760ac839 LW |
128 | { |
129 | #if defined(USE_STDIO_PTR) | |
130 | return 1; | |
131 | #else | |
132 | return 0; | |
133 | #endif | |
134 | } | |
135 | ||
136 | #undef PerlIO_canset_cnt | |
137 | int | |
c78749f2 | 138 | PerlIO_canset_cnt(PerlIO *f) |
760ac839 LW |
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 | |
148 | void | |
a20bf0c3 | 149 | PerlIO_set_cnt(PerlIO *f, int cnt) |
760ac839 | 150 | { |
961e40ee SB |
151 | dTHX; |
152 | if (cnt < -1 && ckWARN_d(WARN_INTERNAL)) | |
0453d815 | 153 | Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt); |
760ac839 LW |
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 LW |
158 | #endif |
159 | } | |
160 | ||
161 | #undef PerlIO_set_ptrcnt | |
162 | void | |
a20bf0c3 | 163 | PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) |
760ac839 | 164 | { |
961e40ee | 165 | dTHX; |
409faa39 | 166 | #ifdef FILE_bufsiz |
888911fc CS |
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 LW |
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 LW |
183 | #endif |
184 | } | |
185 | ||
186 | #undef PerlIO_get_cnt | |
187 | int | |
a20bf0c3 | 188 | PerlIO_get_cnt(PerlIO *f) |
760ac839 LW |
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 LW |
195 | return -1; |
196 | #endif | |
197 | } | |
198 | ||
199 | #undef PerlIO_get_bufsiz | |
200 | int | |
a20bf0c3 | 201 | PerlIO_get_bufsiz(PerlIO *f) |
760ac839 LW |
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 LW |
208 | return -1; |
209 | #endif | |
210 | } | |
211 | ||
212 | #undef PerlIO_get_ptr | |
888911fc | 213 | STDCHAR * |
a20bf0c3 | 214 | PerlIO_get_ptr(PerlIO *f) |
760ac839 LW |
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 LW |
221 | return NULL; |
222 | #endif | |
223 | } | |
224 | ||
225 | #undef PerlIO_get_base | |
888911fc | 226 | STDCHAR * |
a20bf0c3 | 227 | PerlIO_get_base(PerlIO *f) |
760ac839 LW |
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 LW |
234 | return NULL; |
235 | #endif | |
236 | } | |
237 | ||
238 | #undef PerlIO_has_base | |
239 | int | |
c78749f2 | 240 | PerlIO_has_base(PerlIO *f) |
760ac839 LW |
241 | { |
242 | #ifdef FILE_base | |
243 | return 1; | |
244 | #else | |
245 | return 0; | |
246 | #endif | |
247 | } | |
248 | ||
249 | #undef PerlIO_puts | |
250 | int | |
c78749f2 | 251 | PerlIO_puts(PerlIO *f, const char *s) |
760ac839 LW |
252 | { |
253 | return fputs(s,f); | |
254 | } | |
255 | ||
256 | #undef PerlIO_open | |
257 | PerlIO * | |
c78749f2 | 258 | PerlIO_open(const char *path, const char *mode) |
760ac839 LW |
259 | { |
260 | return fopen(path,mode); | |
261 | } | |
262 | ||
263 | #undef PerlIO_fdopen | |
264 | PerlIO * | |
c78749f2 | 265 | PerlIO_fdopen(int fd, const char *mode) |
760ac839 LW |
266 | { |
267 | return fdopen(fd,mode); | |
268 | } | |
269 | ||
8c86a920 | 270 | #undef PerlIO_reopen |
271 | PerlIO * | |
c78749f2 | 272 | PerlIO_reopen(const char *name, const char *mode, PerlIO *f) |
8c86a920 | 273 | { |
274 | return freopen(name,mode,f); | |
275 | } | |
760ac839 LW |
276 | |
277 | #undef PerlIO_close | |
278 | int | |
c78749f2 | 279 | PerlIO_close(PerlIO *f) |
760ac839 LW |
280 | { |
281 | return fclose(f); | |
282 | } | |
283 | ||
284 | #undef PerlIO_eof | |
285 | int | |
c78749f2 | 286 | PerlIO_eof(PerlIO *f) |
760ac839 LW |
287 | { |
288 | return feof(f); | |
289 | } | |
290 | ||
8c86a920 | 291 | #undef PerlIO_getname |
292 | char * | |
a20bf0c3 | 293 | PerlIO_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 LW |
304 | #undef PerlIO_getc |
305 | int | |
c78749f2 | 306 | PerlIO_getc(PerlIO *f) |
760ac839 LW |
307 | { |
308 | return fgetc(f); | |
309 | } | |
310 | ||
311 | #undef PerlIO_error | |
312 | int | |
c78749f2 | 313 | PerlIO_error(PerlIO *f) |
760ac839 LW |
314 | { |
315 | return ferror(f); | |
316 | } | |
317 | ||
318 | #undef PerlIO_clearerr | |
319 | void | |
c78749f2 | 320 | PerlIO_clearerr(PerlIO *f) |
760ac839 LW |
321 | { |
322 | clearerr(f); | |
323 | } | |
324 | ||
325 | #undef PerlIO_flush | |
326 | int | |
c78749f2 | 327 | PerlIO_flush(PerlIO *f) |
760ac839 LW |
328 | { |
329 | return Fflush(f); | |
330 | } | |
331 | ||
332 | #undef PerlIO_fileno | |
333 | int | |
c78749f2 | 334 | PerlIO_fileno(PerlIO *f) |
760ac839 LW |
335 | { |
336 | return fileno(f); | |
337 | } | |
338 | ||
339 | #undef PerlIO_setlinebuf | |
340 | void | |
c78749f2 | 341 | PerlIO_setlinebuf(PerlIO *f) |
760ac839 LW |
342 | { |
343 | #ifdef HAS_SETLINEBUF | |
344 | setlinebuf(f); | |
345 | #else | |
3e3baf6d TB |
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 LW |
351 | #endif |
352 | } | |
353 | ||
354 | #undef PerlIO_putc | |
355 | int | |
c78749f2 | 356 | PerlIO_putc(PerlIO *f, int ch) |
760ac839 | 357 | { |
9010f3dd | 358 | return putc(ch,f); |
760ac839 LW |
359 | } |
360 | ||
361 | #undef PerlIO_ungetc | |
362 | int | |
c78749f2 | 363 | PerlIO_ungetc(PerlIO *f, int ch) |
760ac839 | 364 | { |
9010f3dd | 365 | return ungetc(ch,f); |
760ac839 LW |
366 | } |
367 | ||
368 | #undef PerlIO_read | |
5b54f415 | 369 | SSize_t |
c78749f2 | 370 | PerlIO_read(PerlIO *f, void *buf, Size_t count) |
760ac839 LW |
371 | { |
372 | return fread(buf,1,count,f); | |
373 | } | |
374 | ||
375 | #undef PerlIO_write | |
5b54f415 | 376 | SSize_t |
c78749f2 | 377 | PerlIO_write(PerlIO *f, const void *buf, Size_t count) |
760ac839 LW |
378 | { |
379 | return fwrite1(buf,1,count,f); | |
380 | } | |
381 | ||
382 | #undef PerlIO_vprintf | |
383 | int | |
c78749f2 | 384 | PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) |
760ac839 LW |
385 | { |
386 | return vfprintf(f,fmt,ap); | |
387 | } | |
388 | ||
760ac839 | 389 | #undef PerlIO_tell |
5ff3f7a4 | 390 | Off_t |
c78749f2 | 391 | PerlIO_tell(PerlIO *f) |
760ac839 | 392 | { |
dad16317 RB |
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 LW |
398 | } |
399 | ||
400 | #undef PerlIO_seek | |
401 | int | |
c78749f2 | 402 | PerlIO_seek(PerlIO *f, Off_t offset, int whence) |
760ac839 | 403 | { |
dad16317 RB |
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 LW |
409 | } |
410 | ||
411 | #undef PerlIO_rewind | |
412 | void | |
c78749f2 | 413 | PerlIO_rewind(PerlIO *f) |
760ac839 LW |
414 | { |
415 | rewind(f); | |
416 | } | |
417 | ||
418 | #undef PerlIO_printf | |
419 | int | |
760ac839 | 420 | PerlIO_printf(PerlIO *f,const char *fmt,...) |
760ac839 LW |
421 | { |
422 | va_list ap; | |
423 | int result; | |
760ac839 | 424 | va_start(ap,fmt); |
760ac839 LW |
425 | result = vfprintf(f,fmt,ap); |
426 | va_end(ap); | |
427 | return result; | |
428 | } | |
429 | ||
430 | #undef PerlIO_stdoutf | |
431 | int | |
760ac839 | 432 | PerlIO_stdoutf(const char *fmt,...) |
760ac839 LW |
433 | { |
434 | va_list ap; | |
435 | int result; | |
760ac839 | 436 | va_start(ap,fmt); |
760ac839 LW |
437 | result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap); |
438 | va_end(ap); | |
439 | return result; | |
440 | } | |
441 | ||
442 | #undef PerlIO_tmpfile | |
443 | PerlIO * | |
c78749f2 | 444 | PerlIO_tmpfile(void) |
760ac839 LW |
445 | { |
446 | return tmpfile(); | |
447 | } | |
448 | ||
449 | #undef PerlIO_importFILE | |
450 | PerlIO * | |
c78749f2 | 451 | PerlIO_importFILE(FILE *f, int fl) |
760ac839 LW |
452 | { |
453 | return f; | |
454 | } | |
455 | ||
456 | #undef PerlIO_exportFILE | |
457 | FILE * | |
c78749f2 | 458 | PerlIO_exportFILE(PerlIO *f, int fl) |
760ac839 LW |
459 | { |
460 | return f; | |
461 | } | |
462 | ||
463 | #undef PerlIO_findFILE | |
464 | FILE * | |
c78749f2 | 465 | PerlIO_findFILE(PerlIO *f) |
760ac839 LW |
466 | { |
467 | return f; | |
468 | } | |
469 | ||
470 | #undef PerlIO_releaseFILE | |
471 | void | |
c78749f2 | 472 | PerlIO_releaseFILE(PerlIO *p, FILE *f) |
760ac839 LW |
473 | { |
474 | } | |
475 | ||
476 | void | |
c78749f2 | 477 | PerlIO_init(void) |
760ac839 LW |
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 | |
491 | int | |
c78749f2 | 492 | PerlIO_setpos(PerlIO *f, const Fpos_t *pos) |
760ac839 LW |
493 | { |
494 | return PerlIO_seek(f,*pos,0); | |
495 | } | |
c411622e | 496 | #else |
497 | #ifndef PERLIO_IS_STDIO | |
498 | #undef PerlIO_setpos | |
499 | int | |
c78749f2 | 500 | PerlIO_setpos(PerlIO *f, const Fpos_t *pos) |
c411622e | 501 | { |
2d4389e4 | 502 | #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) |
d9b3e12d JH |
503 | return fsetpos64(f, pos); |
504 | #else | |
c411622e | 505 | return fsetpos(f, pos); |
d9b3e12d | 506 | #endif |
c411622e | 507 | } |
508 | #endif | |
760ac839 LW |
509 | #endif |
510 | ||
511 | #ifndef HAS_FGETPOS | |
512 | #undef PerlIO_getpos | |
513 | int | |
c78749f2 | 514 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
760ac839 LW |
515 | { |
516 | *pos = PerlIO_tell(f); | |
517 | return 0; | |
518 | } | |
c411622e | 519 | #else |
520 | #ifndef PERLIO_IS_STDIO | |
521 | #undef PerlIO_getpos | |
522 | int | |
c78749f2 | 523 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
c411622e | 524 | { |
2d4389e4 | 525 | #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) |
d9b3e12d JH |
526 | return fgetpos64(f, pos); |
527 | #else | |
c411622e | 528 | return fgetpos(f, pos); |
d9b3e12d | 529 | #endif |
c411622e | 530 | } |
531 | #endif | |
760ac839 LW |
532 | #endif |
533 | ||
534 | #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) | |
535 | ||
536 | int | |
c78749f2 | 537 | vprintf(char *pat, char *args) |
662a7e3f CS |
538 | { |
539 | _doprnt(pat, args, stdout); | |
540 | return 0; /* wrong, but perl doesn't use the return value */ | |
541 | } | |
542 | ||
543 | int | |
c78749f2 | 544 | vfprintf(FILE *fd, char *pat, char *args) |
760ac839 LW |
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 | |
553 | int | |
8ac85365 | 554 | PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) |
760ac839 LW |
555 | { |
556 | int val = vsprintf(s, fmt, ap); | |
557 | if (n >= 0) | |
558 | { | |
8c86a920 | 559 | if (strlen(s) >= (STRLEN)n) |
760ac839 | 560 | { |
bf49b057 GS |
561 | dTHX; |
562 | PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); | |
563 | my_exit(1); | |
760ac839 LW |
564 | } |
565 | } | |
566 | return val; | |
567 | } | |
568 | #endif | |
569 | ||
570 | #ifndef PerlIO_sprintf | |
571 | int | |
760ac839 | 572 | PerlIO_sprintf(char *s, int n, const char *fmt,...) |
760ac839 LW |
573 | { |
574 | va_list ap; | |
575 | int result; | |
760ac839 | 576 | va_start(ap,fmt); |
760ac839 LW |
577 | result = PerlIO_vsprintf(s, n, fmt, ap); |
578 | va_end(ap); | |
579 | return result; | |
580 | } | |
581 | #endif | |
582 | ||
c5be433b GS |
583 | #endif /* !PERL_IMPLICIT_SYS */ |
584 |