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