perl 5.003_06: perl.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 #undef PerlIO_reopen
276 PerlIO * 
277 PerlIO_reopen(fd,mode)
278 char *name;
279 char *mode;
280 PerlIO *f;
281 const char *mode;
282 {
283  return freopen(name,mode,f);
284 }
285
286 #undef PerlIO_close
287 int      
288 PerlIO_close(f)
289 PerlIO *f;
290 {
291  return fclose(f);
292 }
293
294 #undef PerlIO_eof
295 int      
296 PerlIO_eof(f)
297 PerlIO *f;
298 {
299  return feof(f);
300 }
301
302 #undef PerlIO_getname
303 char *
304 PerlIO_getname(f,buf)
305 PerlIO *f;
306 char *buf;
307 {
308 #ifdef VMS
309  return fgetname(f,buf);
310 #else
311  croak("Don't know how to get file name");
312 #endif
313 }
314
315 #undef PerlIO_getc
316 int      
317 PerlIO_getc(f)
318 PerlIO *f;
319 {
320  return fgetc(f);
321 }
322
323 #undef PerlIO_error
324 int      
325 PerlIO_error(f)
326 PerlIO *f;
327 {
328  return ferror(f);
329 }
330
331 #undef PerlIO_clearerr
332 void
333 PerlIO_clearerr(f)
334 PerlIO *f;
335 {
336  clearerr(f);
337 }
338
339 #undef PerlIO_flush
340 int      
341 PerlIO_flush(f)
342 PerlIO *f;
343 {
344  return Fflush(f);
345 }
346
347 #undef PerlIO_fileno
348 int      
349 PerlIO_fileno(f)
350 PerlIO *f;
351 {
352  return fileno(f);
353 }
354
355 #undef PerlIO_setlinebuf
356 void
357 PerlIO_setlinebuf(f)
358 PerlIO *f;
359 {
360 #ifdef HAS_SETLINEBUF
361     setlinebuf(f);
362 #else
363     setvbuf(f, Nullch, _IOLBF, 0);
364 #endif
365 }
366
367 #undef PerlIO_putc
368 int      
369 PerlIO_putc(f,ch)
370 PerlIO *f;
371 int ch;
372 {
373  putc(ch,f);
374 }
375
376 #undef PerlIO_ungetc
377 int      
378 PerlIO_ungetc(f,ch)
379 PerlIO *f;
380 int ch;
381 {
382  ungetc(ch,f);
383 }
384
385 #undef PerlIO_read
386 int      
387 PerlIO_read(f,buf,count)
388 PerlIO *f;
389 void *buf;
390 size_t count;
391 {
392  return fread(buf,1,count,f);
393 }
394
395 #undef PerlIO_write
396 int      
397 PerlIO_write(f,buf,count)
398 PerlIO *f;
399 const void *buf;
400 size_t count;
401 {
402  return fwrite1(buf,1,count,f);
403 }
404
405 #undef PerlIO_vprintf
406 int      
407 PerlIO_vprintf(f,fmt,ap)
408 PerlIO *f;
409 const char *fmt;
410 va_list ap;
411 {
412  return vfprintf(f,fmt,ap);
413 }
414
415
416 #undef PerlIO_tell
417 long
418 PerlIO_tell(f)
419 PerlIO *f;
420 {
421  return ftell(f);
422 }
423
424 #undef PerlIO_seek
425 int
426 PerlIO_seek(f,offset,whence)
427 PerlIO *f;
428 off_t offset;
429 int whence;
430 {
431  return fseek(f,offset,whence);
432 }
433
434 #undef PerlIO_rewind
435 void
436 PerlIO_rewind(f)
437 PerlIO *f;
438 {
439  rewind(f);
440 }
441
442 #undef PerlIO_printf
443 int      
444 #ifdef I_STDARG
445 PerlIO_printf(PerlIO *f,const char *fmt,...)
446 #else
447 PerlIO_printf(f,fmt,va_alist)
448 PerlIO *f;
449 const char *fmt;
450 va_dcl
451 #endif
452 {
453  va_list ap;
454  int result;
455 #ifdef I_STDARG
456  va_start(ap,fmt);
457 #else
458  va_start(ap);
459 #endif
460  result = vfprintf(f,fmt,ap);
461  va_end(ap);
462  return result;
463 }
464
465 #undef PerlIO_stdoutf
466 int      
467 #ifdef I_STDARG
468 PerlIO_stdoutf(const char *fmt,...)
469 #else
470 PerlIO_stdoutf(fmt, va_alist)
471 const char *fmt;
472 va_dcl
473 #endif
474 {
475  va_list ap;
476  int result;
477 #ifdef I_STDARG
478  va_start(ap,fmt);
479 #else
480  va_start(ap);
481 #endif
482  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
483  va_end(ap);
484  return result;
485 }
486
487 #undef PerlIO_tmpfile
488 PerlIO *
489 PerlIO_tmpfile()
490 {
491  return tmpfile();
492 }
493
494 #undef PerlIO_importFILE
495 PerlIO *
496 PerlIO_importFILE(f,fl)
497 FILE *f;
498 int fl;
499 {
500  return f;
501 }
502
503 #undef PerlIO_exportFILE
504 FILE *
505 PerlIO_exportFILE(f,fl)
506 PerlIO *f;
507 int fl;
508 {
509  return f;
510 }
511
512 #undef PerlIO_findFILE
513 FILE *
514 PerlIO_findFILE(f)
515 PerlIO *f;
516 {
517  return f;
518 }
519
520 #undef PerlIO_releaseFILE
521 void
522 PerlIO_releaseFILE(p,f)
523 PerlIO *p;
524 FILE *f;
525 {
526 }
527
528 void
529 PerlIO_init()
530 {
531  /* Does nothing (yet) except force this file to be included 
532     in perl binary. That allows this file to force inclusion
533     of other functions that may be required by loadable 
534     extensions e.g. for FileHandle::tmpfile  
535  */
536 }
537
538 #endif /* USE_SFIO */
539 #endif /* PERLIO_IS_STDIO */
540
541 #ifndef HAS_FSETPOS
542 #undef PerlIO_setpos
543 int
544 PerlIO_setpos(f,pos)
545 PerlIO *f;
546 const Fpos_t *pos;
547 {
548  return PerlIO_seek(f,*pos,0); 
549 }
550 #else
551 #ifndef PERLIO_IS_STDIO
552 #undef PerlIO_setpos
553 int
554 PerlIO_setpos(f,pos)
555 PerlIO *f;
556 const Fpos_t *pos;
557 {
558  return fsetpos(f, pos);
559 }
560 #endif
561 #endif
562
563 #ifndef HAS_FGETPOS
564 #undef PerlIO_getpos
565 int
566 PerlIO_getpos(f,pos)
567 PerlIO *f;
568 Fpos_t *pos;
569 {
570  *pos = PerlIO_tell(f);
571  return 0;
572 }
573 #else
574 #ifndef PERLIO_IS_STDIO
575 #undef PerlIO_getpos
576 int
577 PerlIO_getpos(f,pos)
578 PerlIO *f;
579 Fpos_t *pos;
580 {
581  return fgetpos(f, pos);
582 }
583 #endif
584 #endif
585
586 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
587
588 int
589 vprintf(fd, pat, args)
590 FILE *fd;
591 char *pat, *args;
592 {
593     _doprnt(pat, args, fd);
594     return 0;           /* wrong, but perl doesn't use the return value */
595 }
596
597 #endif
598
599 #ifndef PerlIO_vsprintf
600 int 
601 PerlIO_vsprintf(s,n,fmt,ap)
602 char *s;
603 const char *fmt;
604 int n;
605 va_list ap;
606 {
607  int val = vsprintf(s, fmt, ap);
608  if (n >= 0)
609   {
610    if (strlen(s) >= (STRLEN)n)
611     {
612      PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
613      my_exit(1);
614     }
615   }
616  return val;
617 }
618 #endif
619
620 #ifndef PerlIO_sprintf
621 int      
622 #ifdef I_STDARG
623 PerlIO_sprintf(char *s, int n, const char *fmt,...)
624 #else
625 PerlIO_sprintf(s, n, fmt, va_alist)
626 char *s;
627 int n;
628 const char *fmt;
629 va_dcl
630 #endif
631 {
632  va_list ap;
633  int result;
634 #ifdef I_STDARG
635  va_start(ap,fmt);
636 #else
637  va_start(ap);
638 #endif
639  result = PerlIO_vsprintf(s, n, fmt, ap);
640  va_end(ap);
641  return result;
642 }
643 #endif
644