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