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