f269dcdb1ded38f14712c5cf98af40d36e56d73d
[p5sagit/p5-mst-13.2.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 < -1)
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 STDCHAR *ptr;
162 int cnt;
163 {
164 #ifdef FILE_bufsiz
165  STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
166  int ec = e - ptr;
167  if (ptr > e + 1)
168   warn("Setting ptr %p > end+1 %p\n", ptr, e + 1);
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) = 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 STDCHAR *
212 PerlIO_get_ptr(f)
213 PerlIO *f;
214 {
215 #ifdef FILE_ptr
216  return 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 STDCHAR *
225 PerlIO_get_base(f)
226 PerlIO *f;
227 {
228 #ifdef FILE_base
229  return 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(name, mode, f)
278 const char *name;
279 const char *mode;
280 PerlIO *f;
281 {
282  return freopen(name,mode,f);
283 }
284
285 #undef PerlIO_close
286 int      
287 PerlIO_close(f)
288 PerlIO *f;
289 {
290  return fclose(f);
291 }
292
293 #undef PerlIO_eof
294 int      
295 PerlIO_eof(f)
296 PerlIO *f;
297 {
298  return feof(f);
299 }
300
301 #undef PerlIO_getname
302 char *
303 PerlIO_getname(f,buf)
304 PerlIO *f;
305 char *buf;
306 {
307 #ifdef VMS
308  return fgetname(f,buf);
309 #else
310  croak("Don't know how to get file name");
311  return NULL;
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 #  ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
364     setvbuf(f, Nullch, _IOLBF, BUFSIZ);
365 #  else
366     setvbuf(f, Nullch, _IOLBF, 0);
367 #  endif
368 #endif
369 }
370
371 #undef PerlIO_putc
372 int      
373 PerlIO_putc(f,ch)
374 PerlIO *f;
375 int ch;
376 {
377  return putc(ch,f);
378 }
379
380 #undef PerlIO_ungetc
381 int      
382 PerlIO_ungetc(f,ch)
383 PerlIO *f;
384 int ch;
385 {
386  return ungetc(ch,f);
387 }
388
389 #undef PerlIO_read
390 SSize_t
391 PerlIO_read(f,buf,count)
392 PerlIO *f;
393 void *buf;
394 Size_t count;
395 {
396  return fread(buf,1,count,f);
397 }
398
399 #undef PerlIO_write
400 SSize_t
401 PerlIO_write(f,buf,count)
402 PerlIO *f;
403 const void *buf;
404 Size_t count;
405 {
406  return fwrite1(buf,1,count,f);
407 }
408
409 #undef PerlIO_vprintf
410 int      
411 PerlIO_vprintf(f,fmt,ap)
412 PerlIO *f;
413 const char *fmt;
414 va_list ap;
415 {
416  return vfprintf(f,fmt,ap);
417 }
418
419
420 #undef PerlIO_tell
421 long
422 PerlIO_tell(f)
423 PerlIO *f;
424 {
425  return ftell(f);
426 }
427
428 #undef PerlIO_seek
429 int
430 PerlIO_seek(f,offset,whence)
431 PerlIO *f;
432 off_t offset;
433 int whence;
434 {
435  return fseek(f,offset,whence);
436 }
437
438 #undef PerlIO_rewind
439 void
440 PerlIO_rewind(f)
441 PerlIO *f;
442 {
443  rewind(f);
444 }
445
446 #undef PerlIO_printf
447 int      
448 #ifdef I_STDARG
449 PerlIO_printf(PerlIO *f,const char *fmt,...)
450 #else
451 PerlIO_printf(f,fmt,va_alist)
452 PerlIO *f;
453 const char *fmt;
454 va_dcl
455 #endif
456 {
457  va_list ap;
458  int result;
459 #ifdef I_STDARG
460  va_start(ap,fmt);
461 #else
462  va_start(ap);
463 #endif
464  result = vfprintf(f,fmt,ap);
465  va_end(ap);
466  return result;
467 }
468
469 #undef PerlIO_stdoutf
470 int      
471 #ifdef I_STDARG
472 PerlIO_stdoutf(const char *fmt,...)
473 #else
474 PerlIO_stdoutf(fmt, va_alist)
475 const char *fmt;
476 va_dcl
477 #endif
478 {
479  va_list ap;
480  int result;
481 #ifdef I_STDARG
482  va_start(ap,fmt);
483 #else
484  va_start(ap);
485 #endif
486  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
487  va_end(ap);
488  return result;
489 }
490
491 #undef PerlIO_tmpfile
492 PerlIO *
493 PerlIO_tmpfile()
494 {
495  return tmpfile();
496 }
497
498 #undef PerlIO_importFILE
499 PerlIO *
500 PerlIO_importFILE(f,fl)
501 FILE *f;
502 int fl;
503 {
504  return f;
505 }
506
507 #undef PerlIO_exportFILE
508 FILE *
509 PerlIO_exportFILE(f,fl)
510 PerlIO *f;
511 int fl;
512 {
513  return f;
514 }
515
516 #undef PerlIO_findFILE
517 FILE *
518 PerlIO_findFILE(f)
519 PerlIO *f;
520 {
521  return f;
522 }
523
524 #undef PerlIO_releaseFILE
525 void
526 PerlIO_releaseFILE(p,f)
527 PerlIO *p;
528 FILE *f;
529 {
530 }
531
532 void
533 PerlIO_init()
534 {
535  /* Does nothing (yet) except force this file to be included 
536     in perl binary. That allows this file to force inclusion
537     of other functions that may be required by loadable 
538     extensions e.g. for FileHandle::tmpfile  
539  */
540 }
541
542 #endif /* USE_SFIO */
543 #endif /* PERLIO_IS_STDIO */
544
545 #ifndef HAS_FSETPOS
546 #undef PerlIO_setpos
547 int
548 PerlIO_setpos(f,pos)
549 PerlIO *f;
550 const Fpos_t *pos;
551 {
552  return PerlIO_seek(f,*pos,0); 
553 }
554 #else
555 #ifndef PERLIO_IS_STDIO
556 #undef PerlIO_setpos
557 int
558 PerlIO_setpos(f,pos)
559 PerlIO *f;
560 const Fpos_t *pos;
561 {
562  return fsetpos(f, pos);
563 }
564 #endif
565 #endif
566
567 #ifndef HAS_FGETPOS
568 #undef PerlIO_getpos
569 int
570 PerlIO_getpos(f,pos)
571 PerlIO *f;
572 Fpos_t *pos;
573 {
574  *pos = PerlIO_tell(f);
575  return 0;
576 }
577 #else
578 #ifndef PERLIO_IS_STDIO
579 #undef PerlIO_getpos
580 int
581 PerlIO_getpos(f,pos)
582 PerlIO *f;
583 Fpos_t *pos;
584 {
585  return fgetpos(f, pos);
586 }
587 #endif
588 #endif
589
590 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
591
592 int
593 vprintf(pat, args)
594 char *pat, *args;
595 {
596     _doprnt(pat, args, stdout);
597     return 0;           /* wrong, but perl doesn't use the return value */
598 }
599
600 int
601 vfprintf(fd, pat, args)
602 FILE *fd;
603 char *pat, *args;
604 {
605     _doprnt(pat, args, fd);
606     return 0;           /* wrong, but perl doesn't use the return value */
607 }
608
609 #endif
610
611 #ifndef PerlIO_vsprintf
612 int 
613 PerlIO_vsprintf(s,n,fmt,ap)
614 char *s;
615 const char *fmt;
616 int n;
617 va_list ap;
618 {
619  int val = vsprintf(s, fmt, ap);
620  if (n >= 0)
621   {
622    if (strlen(s) >= (STRLEN)n)
623     {
624      PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
625      my_exit(1);
626     }
627   }
628  return val;
629 }
630 #endif
631
632 #ifndef PerlIO_sprintf
633 int      
634 #ifdef I_STDARG
635 PerlIO_sprintf(char *s, int n, const char *fmt,...)
636 #else
637 PerlIO_sprintf(s, n, fmt, va_alist)
638 char *s;
639 int n;
640 const char *fmt;
641 va_dcl
642 #endif
643 {
644  va_list ap;
645  int result;
646 #ifdef I_STDARG
647  va_start(ap,fmt);
648 #else
649  va_start(ap);
650 #endif
651  result = PerlIO_vsprintf(s, n, fmt, ap);
652  va_end(ap);
653  return result;
654 }
655 #endif
656