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