This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make die/warn and other diagnostics go to wherever STDERR happens
[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 #if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
389  return ftello(f);
390 #else
391  return ftell(f);
392 #endif
393 }
394
395 #undef PerlIO_seek
396 int
397 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
398 {
399 #if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
400  return fseeko(f,offset,whence);
401 #else
402  return fseek(f,offset,whence);
403 #endif
404 }
405
406 #undef PerlIO_rewind
407 void
408 PerlIO_rewind(PerlIO *f)
409 {
410  rewind(f);
411 }
412
413 #undef PerlIO_printf
414 int      
415 PerlIO_printf(PerlIO *f,const char *fmt,...)
416 {
417  va_list ap;
418  int result;
419  va_start(ap,fmt);
420  result = vfprintf(f,fmt,ap);
421  va_end(ap);
422  return result;
423 }
424
425 #undef PerlIO_stdoutf
426 int      
427 PerlIO_stdoutf(const char *fmt,...)
428 {
429  va_list ap;
430  int result;
431  va_start(ap,fmt);
432  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
433  va_end(ap);
434  return result;
435 }
436
437 #undef PerlIO_tmpfile
438 PerlIO *
439 PerlIO_tmpfile(void)
440 {
441  return tmpfile();
442 }
443
444 #undef PerlIO_importFILE
445 PerlIO *
446 PerlIO_importFILE(FILE *f, int fl)
447 {
448  return f;
449 }
450
451 #undef PerlIO_exportFILE
452 FILE *
453 PerlIO_exportFILE(PerlIO *f, int fl)
454 {
455  return f;
456 }
457
458 #undef PerlIO_findFILE
459 FILE *
460 PerlIO_findFILE(PerlIO *f)
461 {
462  return f;
463 }
464
465 #undef PerlIO_releaseFILE
466 void
467 PerlIO_releaseFILE(PerlIO *p, FILE *f)
468 {
469 }
470
471 void
472 PerlIO_init(void)
473 {
474  /* Does nothing (yet) except force this file to be included 
475     in perl binary. That allows this file to force inclusion
476     of other functions that may be required by loadable 
477     extensions e.g. for FileHandle::tmpfile  
478  */
479 }
480
481 #endif /* USE_SFIO */
482 #endif /* PERLIO_IS_STDIO */
483
484 #ifndef HAS_FSETPOS
485 #undef PerlIO_setpos
486 int
487 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
488 {
489  return PerlIO_seek(f,*pos,0); 
490 }
491 #else
492 #ifndef PERLIO_IS_STDIO
493 #undef PerlIO_setpos
494 int
495 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
496 {
497 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
498  return fsetpos64(f, pos);
499 #else
500  return fsetpos(f, pos);
501 #endif
502 }
503 #endif
504 #endif
505
506 #ifndef HAS_FGETPOS
507 #undef PerlIO_getpos
508 int
509 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
510 {
511  *pos = PerlIO_tell(f);
512  return 0;
513 }
514 #else
515 #ifndef PERLIO_IS_STDIO
516 #undef PerlIO_getpos
517 int
518 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
519 {
520 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
521  return fgetpos64(f, pos);
522 #else
523  return fgetpos(f, pos);
524 #endif
525 }
526 #endif
527 #endif
528
529 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
530
531 int
532 vprintf(char *pat, char *args)
533 {
534     _doprnt(pat, args, stdout);
535     return 0;           /* wrong, but perl doesn't use the return value */
536 }
537
538 int
539 vfprintf(FILE *fd, char *pat, char *args)
540 {
541     _doprnt(pat, args, fd);
542     return 0;           /* wrong, but perl doesn't use the return value */
543 }
544
545 #endif
546
547 #ifndef PerlIO_vsprintf
548 int 
549 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
550 {
551  int val = vsprintf(s, fmt, ap);
552  if (n >= 0)
553   {
554    if (strlen(s) >= (STRLEN)n)
555     {
556      dTHX;
557      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
558      my_exit(1);
559     }
560   }
561  return val;
562 }
563 #endif
564
565 #ifndef PerlIO_sprintf
566 int      
567 PerlIO_sprintf(char *s, int n, const char *fmt,...)
568 {
569  va_list ap;
570  int result;
571  va_start(ap,fmt);
572  result = PerlIO_vsprintf(s, n, fmt, ap);
573  va_end(ap);
574  return result;
575 }
576 #endif
577
578 #endif /* !PERL_IMPLICIT_SYS */
579