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