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