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