Commit | Line | Data |
---|---|---|
760ac839 LW |
1 | /* perlio.c |
2 | * | |
1761cee5 | 3 | * Copyright (c) 1996-2000, Nick Ing-Simmons |
760ac839 LW |
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 | |
12ae5dfc JH |
11 | #ifdef PERL_MICRO |
12 | # include "uconfig.h" | |
13 | #else | |
14 | # include "config.h" | |
15 | #endif | |
760ac839 | 16 | |
6f9d8c32 | 17 | #define PERLIO_NOT_STDIO 0 |
760ac839 | 18 | #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) |
6f9d8c32 | 19 | /* #define PerlIO FILE */ |
760ac839 LW |
20 | #endif |
21 | /* | |
6f9d8c32 | 22 | * This file provides those parts of PerlIO abstraction |
0f4eea8f | 23 | * which are not #defined in iperlsys.h. |
6f9d8c32 | 24 | * Which these are depends on various Configure #ifdef's |
760ac839 LW |
25 | */ |
26 | ||
27 | #include "EXTERN.h" | |
864dbfa3 | 28 | #define PERL_IN_PERLIO_C |
760ac839 LW |
29 | #include "perl.h" |
30 | ||
32e30700 GS |
31 | #if !defined(PERL_IMPLICIT_SYS) |
32 | ||
6f9d8c32 | 33 | #ifdef PERLIO_IS_STDIO |
760ac839 LW |
34 | |
35 | void | |
8ac85365 | 36 | PerlIO_init(void) |
760ac839 | 37 | { |
6f9d8c32 | 38 | /* Does nothing (yet) except force this file to be included |
760ac839 | 39 | in perl binary. That allows this file to force inclusion |
6f9d8c32 NIS |
40 | of other functions that may be required by loadable |
41 | extensions e.g. for FileHandle::tmpfile | |
760ac839 LW |
42 | */ |
43 | } | |
44 | ||
33dcbb9a | 45 | #undef PerlIO_tmpfile |
46 | PerlIO * | |
8ac85365 | 47 | PerlIO_tmpfile(void) |
33dcbb9a | 48 | { |
49 | return tmpfile(); | |
50 | } | |
51 | ||
760ac839 LW |
52 | #else /* PERLIO_IS_STDIO */ |
53 | ||
54 | #ifdef USE_SFIO | |
55 | ||
56 | #undef HAS_FSETPOS | |
57 | #undef HAS_FGETPOS | |
58 | ||
6f9d8c32 | 59 | /* This section is just to make sure these functions |
760ac839 LW |
60 | get pulled in from libsfio.a |
61 | */ | |
62 | ||
63 | #undef PerlIO_tmpfile | |
64 | PerlIO * | |
c78749f2 | 65 | PerlIO_tmpfile(void) |
760ac839 LW |
66 | { |
67 | return sftmp(0); | |
68 | } | |
69 | ||
70 | void | |
c78749f2 | 71 | PerlIO_init(void) |
760ac839 | 72 | { |
6f9d8c32 NIS |
73 | /* Force this file to be included in perl binary. Which allows |
74 | * this file to force inclusion of other functions that may be | |
75 | * required by loadable extensions e.g. for FileHandle::tmpfile | |
760ac839 LW |
76 | */ |
77 | ||
78 | /* Hack | |
79 | * sfio does its own 'autoflush' on stdout in common cases. | |
6f9d8c32 | 80 | * Flush results in a lot of lseek()s to regular files and |
760ac839 LW |
81 | * lot of small writes to pipes. |
82 | */ | |
83 | sfset(sfstdout,SF_SHARE,0); | |
84 | } | |
85 | ||
17c3b450 | 86 | #else /* USE_SFIO */ |
760ac839 | 87 | |
6f9d8c32 NIS |
88 | /*======================================================================================*/ |
89 | ||
90 | /* Implement all the PerlIO interface ourselves. | |
760ac839 LW |
91 | */ |
92 | ||
b1ef6e3b | 93 | /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */ |
02f66e2f NIS |
94 | #ifdef I_UNISTD |
95 | #include <unistd.h> | |
96 | #endif | |
97 | ||
6f9d8c32 NIS |
98 | #undef printf |
99 | void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2))); | |
100 | ||
6f9d8c32 NIS |
101 | void |
102 | PerlIO_debug(char *fmt,...) | |
103 | { | |
104 | static int dbg = 0; | |
105 | if (!dbg) | |
106 | { | |
107 | char *s = getenv("PERLIO_DEBUG"); | |
108 | if (s && *s) | |
109 | dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666); | |
110 | else | |
111 | dbg = -1; | |
112 | } | |
113 | if (dbg > 0) | |
114 | { | |
115 | dTHX; | |
116 | va_list ap; | |
117 | SV *sv = newSVpvn("",0); | |
118 | char *s; | |
119 | STRLEN len; | |
120 | va_start(ap,fmt); | |
121 | sv_vcatpvf(sv, fmt, &ap); | |
122 | s = SvPV(sv,len); | |
123 | write(dbg,s,len); | |
124 | va_end(ap); | |
125 | SvREFCNT_dec(sv); | |
126 | } | |
127 | } | |
128 | ||
129 | #define PERLIO_F_EOF 0x010000 | |
130 | #define PERLIO_F_ERROR 0x020000 | |
131 | #define PERLIO_F_LINEBUF 0x040000 | |
132 | #define PERLIO_F_TEMP 0x080000 | |
133 | #define PERLIO_F_RDBUF 0x100000 | |
134 | #define PERLIO_F_WRBUF 0x200000 | |
135 | #define PERLIO_F_OPEN 0x400000 | |
136 | #define PERLIO_F_USED 0x800000 | |
137 | ||
138 | struct _PerlIO | |
139 | { | |
b1ef6e3b | 140 | IV flags; /* Various flags for state */ |
6f9d8c32 NIS |
141 | IV fd; /* Maybe pointer on some OSes */ |
142 | int oflags; /* open/fcntl flags */ | |
143 | STDCHAR *buf; /* Start of buffer */ | |
144 | STDCHAR *end; /* End of valid part of buffer */ | |
145 | STDCHAR *ptr; /* Current position in buffer */ | |
146 | Size_t bufsiz; /* Size of buffer */ | |
bb9950b7 | 147 | Off_t posn; /* Offset of f->buf into the file */ |
b1ef6e3b | 148 | int oneword; /* An if-all-else-fails area as a buffer */ |
6f9d8c32 NIS |
149 | }; |
150 | ||
b1ef6e3b | 151 | /* Table of pointers to the PerlIO structs (malloc'ed) */ |
6f9d8c32 | 152 | PerlIO **_perlio = NULL; |
b1ef6e3b | 153 | int _perlio_size = 0; |
6f9d8c32 NIS |
154 | |
155 | void | |
156 | PerlIO_alloc_buf(PerlIO *f) | |
157 | { | |
158 | if (!f->bufsiz) | |
bb9950b7 | 159 | f->bufsiz = 4096; |
6f9d8c32 NIS |
160 | New('B',f->buf,f->bufsiz,char); |
161 | if (!f->buf) | |
162 | { | |
163 | f->buf = (STDCHAR *)&f->oneword; | |
164 | f->bufsiz = sizeof(f->oneword); | |
165 | } | |
166 | f->ptr = f->buf; | |
167 | f->end = f->ptr; | |
6f9d8c32 NIS |
168 | } |
169 | ||
b1ef6e3b NIS |
170 | |
171 | /* This "flush" is akin to sfio's sync in that it handles files in either | |
172 | read or write state | |
173 | */ | |
6f9d8c32 NIS |
174 | #undef PerlIO_flush |
175 | int | |
176 | PerlIO_flush(PerlIO *f) | |
177 | { | |
178 | int code = 0; | |
179 | if (f) | |
180 | { | |
6f9d8c32 NIS |
181 | if (f->flags & PERLIO_F_WRBUF) |
182 | { | |
b1ef6e3b | 183 | /* write() the buffer */ |
6f9d8c32 NIS |
184 | STDCHAR *p = f->buf; |
185 | int count; | |
186 | while (p < f->ptr) | |
187 | { | |
188 | count = write(f->fd,p,f->ptr - p); | |
189 | if (count > 0) | |
190 | { | |
191 | p += count; | |
192 | } | |
193 | else if (count < 0 && errno != EINTR) | |
194 | { | |
bb9950b7 | 195 | f->flags |= PERLIO_F_ERROR; |
6f9d8c32 NIS |
196 | code = -1; |
197 | break; | |
198 | } | |
199 | } | |
200 | f->posn += (p - f->buf); | |
201 | } | |
202 | else if (f->flags & PERLIO_F_RDBUF) | |
203 | { | |
b1ef6e3b | 204 | /* Note position change */ |
6f9d8c32 NIS |
205 | f->posn += (f->ptr - f->buf); |
206 | if (f->ptr < f->end) | |
207 | { | |
b1ef6e3b | 208 | /* We did not consume all of it */ |
6f9d8c32 NIS |
209 | f->posn = lseek(f->fd,f->posn,SEEK_SET); |
210 | } | |
211 | } | |
212 | f->ptr = f->end = f->buf; | |
213 | f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); | |
214 | } | |
215 | else | |
216 | { | |
217 | int i; | |
f89522bf | 218 | for (i=_perlio_size-1; i >= 0; i--) |
6f9d8c32 NIS |
219 | { |
220 | if ((f = _perlio[i])) | |
221 | { | |
222 | if (PerlIO_flush(f) != 0) | |
223 | code = -1; | |
224 | } | |
225 | } | |
226 | } | |
227 | return code; | |
228 | } | |
229 | ||
230 | int | |
231 | PerlIO_oflags(const char *mode) | |
232 | { | |
233 | int oflags = -1; | |
6f9d8c32 NIS |
234 | switch(*mode) |
235 | { | |
236 | case 'r': | |
237 | oflags = O_RDONLY; | |
238 | if (*++mode == '+') | |
239 | { | |
240 | oflags = O_RDWR; | |
241 | mode++; | |
242 | } | |
243 | break; | |
244 | ||
245 | case 'w': | |
246 | oflags = O_CREAT|O_TRUNC; | |
247 | if (*++mode == '+') | |
248 | { | |
249 | oflags |= O_RDWR; | |
250 | mode++; | |
251 | } | |
252 | else | |
253 | oflags |= O_WRONLY; | |
254 | break; | |
255 | ||
256 | case 'a': | |
bb9950b7 | 257 | oflags = O_CREAT|O_APPEND; |
6f9d8c32 NIS |
258 | if (*++mode == '+') |
259 | { | |
260 | oflags |= O_RDWR; | |
261 | mode++; | |
262 | } | |
263 | else | |
264 | oflags |= O_WRONLY; | |
265 | break; | |
266 | } | |
267 | if (*mode || oflags == -1) | |
268 | { | |
269 | errno = EINVAL; | |
270 | oflags = -1; | |
271 | } | |
6f9d8c32 NIS |
272 | return oflags; |
273 | } | |
274 | ||
760ac839 | 275 | PerlIO * |
6f9d8c32 NIS |
276 | PerlIO_allocate(void) |
277 | { | |
b1ef6e3b | 278 | /* Find a free slot in the table, growing table as necessary */ |
6f9d8c32 NIS |
279 | PerlIO *f; |
280 | int i = 0; | |
281 | while (1) | |
282 | { | |
283 | PerlIO **table = _perlio; | |
284 | while (i < _perlio_size) | |
285 | { | |
286 | f = table[i]; | |
6f9d8c32 NIS |
287 | if (!f) |
288 | { | |
289 | Newz('F',f,1,PerlIO); | |
290 | if (!f) | |
291 | return NULL; | |
292 | table[i] = f; | |
293 | } | |
294 | if (!(f->flags & PERLIO_F_USED)) | |
295 | { | |
296 | Zero(f,1,PerlIO); | |
297 | f->flags = PERLIO_F_USED; | |
298 | return f; | |
299 | } | |
300 | i++; | |
301 | } | |
302 | Newz('I',table,_perlio_size+16,PerlIO *); | |
303 | if (!table) | |
304 | return NULL; | |
305 | Copy(_perlio,table,_perlio_size,PerlIO *); | |
306 | if (_perlio) | |
307 | Safefree(_perlio); | |
308 | _perlio = table; | |
309 | _perlio_size += 16; | |
310 | } | |
311 | } | |
312 | ||
313 | #undef PerlIO_fdopen | |
314 | PerlIO * | |
315 | PerlIO_fdopen(int fd, const char *mode) | |
316 | { | |
317 | PerlIO *f = NULL; | |
318 | if (fd >= 0) | |
319 | { | |
320 | if ((f = PerlIO_allocate())) | |
321 | { | |
322 | f->fd = fd; | |
323 | f->oflags = PerlIO_oflags(mode); | |
324 | f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED); | |
325 | } | |
326 | } | |
6f9d8c32 NIS |
327 | return f; |
328 | } | |
329 | ||
330 | #undef PerlIO_fileno | |
331 | int | |
332 | PerlIO_fileno(PerlIO *f) | |
760ac839 | 333 | { |
6f9d8c32 NIS |
334 | if (f && (f->flags & PERLIO_F_OPEN)) |
335 | { | |
336 | return f->fd; | |
337 | } | |
338 | return -1; | |
339 | } | |
340 | ||
341 | #undef PerlIO_close | |
342 | int | |
343 | PerlIO_close(PerlIO *f) | |
344 | { | |
bb9950b7 | 345 | int code = 0; |
6f9d8c32 NIS |
346 | if (f) |
347 | { | |
bb9950b7 NIS |
348 | if (PerlIO_flush(f) != 0) |
349 | code = -1; | |
350 | while (close(f->fd) != 0) | |
351 | { | |
352 | if (errno != EINTR) | |
353 | { | |
354 | code = -1; | |
355 | break; | |
356 | } | |
357 | } | |
6f9d8c32 NIS |
358 | f->flags &= ~PERLIO_F_OPEN; |
359 | f->fd = -1; | |
360 | if (f->buf && f->buf != (STDCHAR *) &f->oneword) | |
361 | { | |
362 | Safefree(f->buf); | |
363 | } | |
364 | f->buf = NULL; | |
365 | f->ptr = f->end = f->buf; | |
366 | f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF); | |
367 | } | |
368 | return code; | |
369 | } | |
370 | ||
371 | void | |
372 | PerlIO_cleanup(void) | |
373 | { | |
b1ef6e3b | 374 | /* Close all the files */ |
6f9d8c32 | 375 | int i; |
6f9d8c32 NIS |
376 | for (i=_perlio_size-1; i >= 0; i--) |
377 | { | |
378 | PerlIO *f = _perlio[i]; | |
379 | if (f) | |
380 | { | |
381 | PerlIO_close(f); | |
382 | Safefree(f); | |
383 | } | |
384 | } | |
385 | if (_perlio) | |
386 | Safefree(_perlio); | |
387 | _perlio = NULL; | |
388 | _perlio_size = 0; | |
389 | } | |
390 | ||
391 | #undef PerlIO_open | |
392 | PerlIO * | |
393 | PerlIO_open(const char *path, const char *mode) | |
394 | { | |
395 | PerlIO *f = NULL; | |
396 | int oflags = PerlIO_oflags(mode); | |
397 | if (oflags != -1) | |
398 | { | |
399 | int fd = open(path,oflags,0666); | |
400 | if (fd >= 0) | |
401 | { | |
6f9d8c32 NIS |
402 | f = PerlIO_fdopen(fd,mode); |
403 | if (!f) | |
404 | close(fd); | |
405 | } | |
406 | } | |
6f9d8c32 NIS |
407 | return f; |
408 | } | |
409 | ||
410 | #undef PerlIO_reopen | |
411 | PerlIO * | |
412 | PerlIO_reopen(const char *path, const char *mode, PerlIO *f) | |
413 | { | |
6f9d8c32 NIS |
414 | if (f) |
415 | { | |
416 | int oflags = PerlIO_oflags(mode); | |
417 | PerlIO_close(f); | |
418 | if (oflags != -1) | |
419 | { | |
420 | int fd = open(path,oflags,0666); | |
421 | if (fd >= 0) | |
422 | { | |
6f9d8c32 NIS |
423 | f->oflags = oflags; |
424 | f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED); | |
425 | } | |
426 | } | |
427 | else | |
428 | { | |
429 | return NULL; | |
430 | } | |
431 | } | |
432 | return PerlIO_open(path,mode); | |
433 | } | |
434 | ||
435 | void | |
436 | PerlIO_init(void) | |
437 | { | |
438 | if (!_perlio) | |
439 | { | |
440 | atexit(&PerlIO_cleanup); | |
441 | PerlIO_fdopen(0,"r"); | |
442 | PerlIO_fdopen(1,"w"); | |
443 | PerlIO_fdopen(2,"w"); | |
444 | } | |
760ac839 LW |
445 | } |
446 | ||
447 | #undef PerlIO_stdin | |
448 | PerlIO * | |
c78749f2 | 449 | PerlIO_stdin(void) |
760ac839 | 450 | { |
6f9d8c32 NIS |
451 | if (!_perlio) |
452 | PerlIO_init(); | |
453 | return _perlio[0]; | |
760ac839 LW |
454 | } |
455 | ||
456 | #undef PerlIO_stdout | |
457 | PerlIO * | |
c78749f2 | 458 | PerlIO_stdout(void) |
760ac839 | 459 | { |
6f9d8c32 NIS |
460 | if (!_perlio) |
461 | PerlIO_init(); | |
462 | return _perlio[1]; | |
463 | } | |
464 | ||
465 | #undef PerlIO_stderr | |
466 | PerlIO * | |
467 | PerlIO_stderr(void) | |
468 | { | |
469 | if (!_perlio) | |
470 | PerlIO_init(); | |
471 | return _perlio[2]; | |
760ac839 LW |
472 | } |
473 | ||
760ac839 | 474 | #undef PerlIO_fast_gets |
6f9d8c32 | 475 | int |
c78749f2 | 476 | PerlIO_fast_gets(PerlIO *f) |
760ac839 | 477 | { |
760ac839 | 478 | return 1; |
760ac839 LW |
479 | } |
480 | ||
481 | #undef PerlIO_has_cntptr | |
6f9d8c32 | 482 | int |
c78749f2 | 483 | PerlIO_has_cntptr(PerlIO *f) |
760ac839 | 484 | { |
760ac839 | 485 | return 1; |
760ac839 LW |
486 | } |
487 | ||
488 | #undef PerlIO_canset_cnt | |
6f9d8c32 | 489 | int |
c78749f2 | 490 | PerlIO_canset_cnt(PerlIO *f) |
760ac839 | 491 | { |
760ac839 | 492 | return 1; |
760ac839 LW |
493 | } |
494 | ||
495 | #undef PerlIO_set_cnt | |
496 | void | |
a20bf0c3 | 497 | PerlIO_set_cnt(PerlIO *f, int cnt) |
760ac839 | 498 | { |
6f9d8c32 NIS |
499 | if (f) |
500 | { | |
501 | dTHX; | |
502 | if (!f->buf) | |
503 | PerlIO_alloc_buf(f); | |
504 | f->ptr = f->end - cnt; | |
505 | assert(f->ptr >= f->buf); | |
506 | } | |
760ac839 LW |
507 | } |
508 | ||
6f9d8c32 NIS |
509 | #undef PerlIO_get_cnt |
510 | int | |
511 | PerlIO_get_cnt(PerlIO *f) | |
760ac839 | 512 | { |
6f9d8c32 NIS |
513 | if (f) |
514 | { | |
515 | if (!f->buf) | |
516 | PerlIO_alloc_buf(f); | |
517 | if (f->flags & PERLIO_F_RDBUF) | |
518 | return (f->end - f->ptr); | |
519 | } | |
520 | return 0; | |
760ac839 LW |
521 | } |
522 | ||
6f9d8c32 NIS |
523 | #undef PerlIO_set_ptrcnt |
524 | void | |
525 | PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) | |
760ac839 | 526 | { |
6f9d8c32 NIS |
527 | if (f) |
528 | { | |
6f9d8c32 NIS |
529 | if (!f->buf) |
530 | PerlIO_alloc_buf(f); | |
531 | f->ptr = ptr; | |
b1ef6e3b | 532 | if (PerlIO_get_cnt(f) != cnt || f->ptr < f->buf) |
6f9d8c32 NIS |
533 | { |
534 | dTHX; | |
b1ef6e3b NIS |
535 | assert(PerlIO_get_cnt(f) == cnt); |
536 | assert(f->ptr >= f->buf); | |
6f9d8c32 | 537 | } |
bb9950b7 | 538 | f->flags |= PERLIO_F_RDBUF; |
6f9d8c32 | 539 | } |
760ac839 LW |
540 | } |
541 | ||
542 | #undef PerlIO_get_bufsiz | |
6f9d8c32 | 543 | int |
a20bf0c3 | 544 | PerlIO_get_bufsiz(PerlIO *f) |
760ac839 | 545 | { |
6f9d8c32 NIS |
546 | if (f) |
547 | { | |
548 | if (!f->buf) | |
549 | PerlIO_alloc_buf(f); | |
550 | return f->bufsiz; | |
551 | } | |
760ac839 | 552 | return -1; |
760ac839 LW |
553 | } |
554 | ||
555 | #undef PerlIO_get_ptr | |
888911fc | 556 | STDCHAR * |
a20bf0c3 | 557 | PerlIO_get_ptr(PerlIO *f) |
760ac839 | 558 | { |
6f9d8c32 NIS |
559 | if (f) |
560 | { | |
561 | if (!f->buf) | |
562 | PerlIO_alloc_buf(f); | |
563 | return f->ptr; | |
564 | } | |
760ac839 | 565 | return NULL; |
760ac839 LW |
566 | } |
567 | ||
568 | #undef PerlIO_get_base | |
888911fc | 569 | STDCHAR * |
a20bf0c3 | 570 | PerlIO_get_base(PerlIO *f) |
760ac839 | 571 | { |
6f9d8c32 NIS |
572 | if (f) |
573 | { | |
574 | if (!f->buf) | |
575 | PerlIO_alloc_buf(f); | |
576 | return f->buf; | |
577 | } | |
760ac839 | 578 | return NULL; |
760ac839 LW |
579 | } |
580 | ||
6f9d8c32 NIS |
581 | #undef PerlIO_has_base |
582 | int | |
c78749f2 | 583 | PerlIO_has_base(PerlIO *f) |
760ac839 | 584 | { |
6f9d8c32 NIS |
585 | if (f) |
586 | { | |
587 | if (!f->buf) | |
588 | PerlIO_alloc_buf(f); | |
589 | return f->buf != NULL; | |
590 | } | |
760ac839 LW |
591 | } |
592 | ||
593 | #undef PerlIO_puts | |
594 | int | |
c78749f2 | 595 | PerlIO_puts(PerlIO *f, const char *s) |
760ac839 | 596 | { |
6f9d8c32 NIS |
597 | STRLEN len = strlen(s); |
598 | return PerlIO_write(f,s,len); | |
760ac839 LW |
599 | } |
600 | ||
601 | #undef PerlIO_eof | |
6f9d8c32 | 602 | int |
c78749f2 | 603 | PerlIO_eof(PerlIO *f) |
760ac839 | 604 | { |
6f9d8c32 NIS |
605 | if (f) |
606 | { | |
607 | return (f->flags & PERLIO_F_EOF) != 0; | |
608 | } | |
609 | return 1; | |
760ac839 LW |
610 | } |
611 | ||
8c86a920 | 612 | #undef PerlIO_getname |
613 | char * | |
a20bf0c3 | 614 | PerlIO_getname(PerlIO *f, char *buf) |
8c86a920 | 615 | { |
961e40ee | 616 | dTHX; |
cea2e8a9 | 617 | Perl_croak(aTHX_ "Don't know how to get file name"); |
c64afb19 | 618 | return NULL; |
8c86a920 | 619 | } |
620 | ||
6f9d8c32 NIS |
621 | #undef PerlIO_ungetc |
622 | int | |
623 | PerlIO_ungetc(PerlIO *f, int ch) | |
624 | { | |
6f9d8c32 NIS |
625 | if (f->buf && (f->flags & PERLIO_F_RDBUF) && f->ptr > f->buf) |
626 | { | |
627 | *--(f->ptr) = ch; | |
628 | return ch; | |
629 | } | |
630 | return -1; | |
631 | } | |
632 | ||
633 | #undef PerlIO_read | |
634 | SSize_t | |
635 | PerlIO_read(PerlIO *f, void *vbuf, Size_t count) | |
636 | { | |
637 | STDCHAR *buf = (STDCHAR *) vbuf; | |
638 | if (f) | |
639 | { | |
640 | Size_t got = 0; | |
641 | if (!f->ptr) | |
642 | PerlIO_alloc_buf(f); | |
f89522bf NIS |
643 | if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_WRONLY) |
644 | return 0; | |
6f9d8c32 NIS |
645 | while (count > 0) |
646 | { | |
647 | SSize_t avail = (f->end - f->ptr); | |
648 | if ((SSize_t) count < avail) | |
649 | avail = count; | |
650 | if (avail > 0) | |
651 | { | |
652 | Copy(f->ptr,buf,avail,char); | |
653 | got += avail; | |
654 | f->ptr += avail; | |
655 | count -= avail; | |
656 | buf += avail; | |
657 | } | |
658 | if (count && (f->ptr >= f->end)) | |
659 | { | |
bb9950b7 | 660 | PerlIO_flush(f); |
6f9d8c32 NIS |
661 | f->ptr = f->end = f->buf; |
662 | avail = read(f->fd,f->ptr,f->bufsiz); | |
663 | if (avail <= 0) | |
664 | { | |
665 | if (avail == 0) | |
666 | f->flags |= PERLIO_F_EOF; | |
667 | else if (errno == EINTR) | |
668 | continue; | |
669 | else | |
670 | f->flags |= PERLIO_F_ERROR; | |
671 | break; | |
672 | } | |
673 | f->end = f->buf+avail; | |
674 | f->flags |= PERLIO_F_RDBUF; | |
675 | } | |
676 | } | |
677 | return got; | |
678 | } | |
679 | return 0; | |
680 | } | |
681 | ||
760ac839 | 682 | #undef PerlIO_getc |
6f9d8c32 | 683 | int |
c78749f2 | 684 | PerlIO_getc(PerlIO *f) |
760ac839 | 685 | { |
6f9d8c32 NIS |
686 | STDCHAR buf; |
687 | int count = PerlIO_read(f,&buf,1); | |
688 | if (count == 1) | |
b1ef6e3b | 689 | return (unsigned char) buf; |
6f9d8c32 | 690 | return -1; |
760ac839 LW |
691 | } |
692 | ||
693 | #undef PerlIO_error | |
6f9d8c32 | 694 | int |
c78749f2 | 695 | PerlIO_error(PerlIO *f) |
760ac839 | 696 | { |
6f9d8c32 NIS |
697 | if (f) |
698 | { | |
699 | return f->flags & PERLIO_F_ERROR; | |
700 | } | |
701 | return 1; | |
760ac839 LW |
702 | } |
703 | ||
704 | #undef PerlIO_clearerr | |
705 | void | |
c78749f2 | 706 | PerlIO_clearerr(PerlIO *f) |
760ac839 | 707 | { |
6f9d8c32 NIS |
708 | if (f) |
709 | { | |
710 | f->flags &= ~PERLIO_F_ERROR; | |
711 | } | |
760ac839 LW |
712 | } |
713 | ||
714 | #undef PerlIO_setlinebuf | |
715 | void | |
c78749f2 | 716 | PerlIO_setlinebuf(PerlIO *f) |
760ac839 | 717 | { |
6f9d8c32 NIS |
718 | if (f) |
719 | { | |
720 | f->flags &= ~PERLIO_F_LINEBUF; | |
721 | } | |
760ac839 LW |
722 | } |
723 | ||
724 | #undef PerlIO_write | |
5b54f415 | 725 | SSize_t |
6f9d8c32 | 726 | PerlIO_write(PerlIO *f, const void *vbuf, Size_t count) |
760ac839 | 727 | { |
6f9d8c32 NIS |
728 | const STDCHAR *buf = (const STDCHAR *) vbuf; |
729 | Size_t written = 0; | |
6f9d8c32 NIS |
730 | if (f) |
731 | { | |
732 | if (!f->buf) | |
733 | PerlIO_alloc_buf(f); | |
f89522bf NIS |
734 | if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_RDONLY) |
735 | return 0; | |
6f9d8c32 NIS |
736 | while (count > 0) |
737 | { | |
bb9950b7 NIS |
738 | SSize_t avail = f->bufsiz - (f->ptr - f->buf); |
739 | if ((SSize_t) count < avail) | |
6f9d8c32 NIS |
740 | avail = count; |
741 | f->flags |= PERLIO_F_WRBUF; | |
b1ef6e3b | 742 | if (f->flags & PERLIO_F_LINEBUF) |
6f9d8c32 NIS |
743 | { |
744 | while (avail > 0) | |
745 | { | |
746 | int ch = *buf++; | |
747 | *(f->ptr)++ = ch; | |
748 | count--; | |
749 | avail--; | |
750 | written++; | |
751 | if (ch == '\n') | |
bb9950b7 NIS |
752 | { |
753 | PerlIO_flush(f); | |
754 | break; | |
755 | } | |
6f9d8c32 NIS |
756 | } |
757 | } | |
758 | else | |
759 | { | |
760 | if (avail) | |
761 | { | |
762 | Copy(buf,f->ptr,avail,char); | |
763 | count -= avail; | |
764 | buf += avail; | |
765 | written += avail; | |
766 | f->ptr += avail; | |
767 | } | |
768 | } | |
769 | if (f->ptr >= (f->buf + f->bufsiz)) | |
770 | PerlIO_flush(f); | |
771 | } | |
772 | } | |
773 | return written; | |
760ac839 LW |
774 | } |
775 | ||
6f9d8c32 NIS |
776 | #undef PerlIO_putc |
777 | int | |
778 | PerlIO_putc(PerlIO *f, int ch) | |
760ac839 | 779 | { |
6f9d8c32 | 780 | STDCHAR buf = ch; |
f89522bf | 781 | PerlIO_write(f,&buf,1); |
760ac839 LW |
782 | } |
783 | ||
760ac839 | 784 | #undef PerlIO_tell |
5ff3f7a4 | 785 | Off_t |
c78749f2 | 786 | PerlIO_tell(PerlIO *f) |
760ac839 | 787 | { |
bb9950b7 NIS |
788 | Off_t posn = f->posn; |
789 | if (f->buf) | |
790 | posn += (f->ptr - f->buf); | |
6f9d8c32 | 791 | return posn; |
760ac839 LW |
792 | } |
793 | ||
794 | #undef PerlIO_seek | |
795 | int | |
c78749f2 | 796 | PerlIO_seek(PerlIO *f, Off_t offset, int whence) |
760ac839 | 797 | { |
bb9950b7 | 798 | int code; |
bb9950b7 | 799 | code = PerlIO_flush(f); |
6f9d8c32 NIS |
800 | if (code == 0) |
801 | { | |
802 | f->flags &= ~PERLIO_F_EOF; | |
bb9950b7 | 803 | f->posn = PerlLIO_lseek(f->fd,offset,whence); |
6f9d8c32 NIS |
804 | if (f->posn == (Off_t) -1) |
805 | { | |
806 | f->posn = 0; | |
807 | code = -1; | |
808 | } | |
809 | } | |
810 | return code; | |
760ac839 LW |
811 | } |
812 | ||
813 | #undef PerlIO_rewind | |
814 | void | |
c78749f2 | 815 | PerlIO_rewind(PerlIO *f) |
760ac839 | 816 | { |
6f9d8c32 NIS |
817 | PerlIO_seek(f,(Off_t)0,SEEK_SET); |
818 | } | |
819 | ||
820 | #undef PerlIO_vprintf | |
821 | int | |
822 | PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) | |
823 | { | |
824 | dTHX; | |
bb9950b7 | 825 | SV *sv = newSVpvn("",0); |
6f9d8c32 NIS |
826 | char *s; |
827 | STRLEN len; | |
828 | sv_vcatpvf(sv, fmt, &ap); | |
829 | s = SvPV(sv,len); | |
bb9950b7 | 830 | return PerlIO_write(f,s,len); |
760ac839 LW |
831 | } |
832 | ||
833 | #undef PerlIO_printf | |
6f9d8c32 | 834 | int |
760ac839 | 835 | PerlIO_printf(PerlIO *f,const char *fmt,...) |
760ac839 LW |
836 | { |
837 | va_list ap; | |
838 | int result; | |
760ac839 | 839 | va_start(ap,fmt); |
6f9d8c32 | 840 | result = PerlIO_vprintf(f,fmt,ap); |
760ac839 LW |
841 | va_end(ap); |
842 | return result; | |
843 | } | |
844 | ||
845 | #undef PerlIO_stdoutf | |
6f9d8c32 | 846 | int |
760ac839 | 847 | PerlIO_stdoutf(const char *fmt,...) |
760ac839 LW |
848 | { |
849 | va_list ap; | |
850 | int result; | |
760ac839 | 851 | va_start(ap,fmt); |
760ac839 LW |
852 | result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap); |
853 | va_end(ap); | |
854 | return result; | |
855 | } | |
856 | ||
857 | #undef PerlIO_tmpfile | |
858 | PerlIO * | |
c78749f2 | 859 | PerlIO_tmpfile(void) |
760ac839 | 860 | { |
6f9d8c32 | 861 | dTHX; |
b1ef6e3b | 862 | /* I have no idea how portable mkstemp() is ... */ |
6f9d8c32 NIS |
863 | SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0); |
864 | int fd = mkstemp(SvPVX(sv)); | |
865 | PerlIO *f = NULL; | |
866 | if (fd >= 0) | |
867 | { | |
b1ef6e3b | 868 | f = PerlIO_fdopen(fd,"w+"); |
6f9d8c32 NIS |
869 | if (f) |
870 | { | |
871 | f->flags |= PERLIO_F_TEMP; | |
872 | } | |
873 | unlink(SvPVX(sv)); | |
874 | SvREFCNT_dec(sv); | |
875 | } | |
876 | return f; | |
760ac839 LW |
877 | } |
878 | ||
879 | #undef PerlIO_importFILE | |
880 | PerlIO * | |
c78749f2 | 881 | PerlIO_importFILE(FILE *f, int fl) |
760ac839 | 882 | { |
6f9d8c32 | 883 | int fd = fileno(f); |
b1ef6e3b | 884 | /* Should really push stdio discipline when we have them */ |
6f9d8c32 | 885 | return PerlIO_fdopen(fd,"r+"); |
760ac839 LW |
886 | } |
887 | ||
888 | #undef PerlIO_exportFILE | |
889 | FILE * | |
c78749f2 | 890 | PerlIO_exportFILE(PerlIO *f, int fl) |
760ac839 | 891 | { |
6f9d8c32 | 892 | PerlIO_flush(f); |
b1ef6e3b | 893 | /* Should really push stdio discipline when we have them */ |
6f9d8c32 | 894 | return fdopen(PerlIO_fileno(f),"r+"); |
760ac839 LW |
895 | } |
896 | ||
897 | #undef PerlIO_findFILE | |
898 | FILE * | |
c78749f2 | 899 | PerlIO_findFILE(PerlIO *f) |
760ac839 | 900 | { |
6f9d8c32 | 901 | return PerlIO_exportFILE(f,0); |
760ac839 LW |
902 | } |
903 | ||
904 | #undef PerlIO_releaseFILE | |
905 | void | |
c78749f2 | 906 | PerlIO_releaseFILE(PerlIO *p, FILE *f) |
760ac839 LW |
907 | { |
908 | } | |
909 | ||
6f9d8c32 NIS |
910 | #undef HAS_FSETPOS |
911 | #undef HAS_FGETPOS | |
912 | ||
913 | /*======================================================================================*/ | |
760ac839 LW |
914 | |
915 | #endif /* USE_SFIO */ | |
916 | #endif /* PERLIO_IS_STDIO */ | |
917 | ||
918 | #ifndef HAS_FSETPOS | |
919 | #undef PerlIO_setpos | |
920 | int | |
c78749f2 | 921 | PerlIO_setpos(PerlIO *f, const Fpos_t *pos) |
760ac839 | 922 | { |
6f9d8c32 | 923 | return PerlIO_seek(f,*pos,0); |
760ac839 | 924 | } |
c411622e | 925 | #else |
926 | #ifndef PERLIO_IS_STDIO | |
927 | #undef PerlIO_setpos | |
928 | int | |
c78749f2 | 929 | PerlIO_setpos(PerlIO *f, const Fpos_t *pos) |
c411622e | 930 | { |
2d4389e4 | 931 | #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) |
d9b3e12d JH |
932 | return fsetpos64(f, pos); |
933 | #else | |
c411622e | 934 | return fsetpos(f, pos); |
d9b3e12d | 935 | #endif |
c411622e | 936 | } |
937 | #endif | |
760ac839 LW |
938 | #endif |
939 | ||
940 | #ifndef HAS_FGETPOS | |
941 | #undef PerlIO_getpos | |
942 | int | |
c78749f2 | 943 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
760ac839 LW |
944 | { |
945 | *pos = PerlIO_tell(f); | |
946 | return 0; | |
947 | } | |
c411622e | 948 | #else |
949 | #ifndef PERLIO_IS_STDIO | |
950 | #undef PerlIO_getpos | |
951 | int | |
c78749f2 | 952 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
c411622e | 953 | { |
2d4389e4 | 954 | #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) |
d9b3e12d JH |
955 | return fgetpos64(f, pos); |
956 | #else | |
c411622e | 957 | return fgetpos(f, pos); |
d9b3e12d | 958 | #endif |
c411622e | 959 | } |
960 | #endif | |
760ac839 LW |
961 | #endif |
962 | ||
963 | #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) | |
964 | ||
965 | int | |
c78749f2 | 966 | vprintf(char *pat, char *args) |
662a7e3f CS |
967 | { |
968 | _doprnt(pat, args, stdout); | |
969 | return 0; /* wrong, but perl doesn't use the return value */ | |
970 | } | |
971 | ||
972 | int | |
c78749f2 | 973 | vfprintf(FILE *fd, char *pat, char *args) |
760ac839 LW |
974 | { |
975 | _doprnt(pat, args, fd); | |
976 | return 0; /* wrong, but perl doesn't use the return value */ | |
977 | } | |
978 | ||
979 | #endif | |
980 | ||
981 | #ifndef PerlIO_vsprintf | |
6f9d8c32 | 982 | int |
8ac85365 | 983 | PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) |
760ac839 LW |
984 | { |
985 | int val = vsprintf(s, fmt, ap); | |
986 | if (n >= 0) | |
987 | { | |
8c86a920 | 988 | if (strlen(s) >= (STRLEN)n) |
760ac839 | 989 | { |
bf49b057 GS |
990 | dTHX; |
991 | PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); | |
992 | my_exit(1); | |
760ac839 LW |
993 | } |
994 | } | |
995 | return val; | |
996 | } | |
997 | #endif | |
998 | ||
999 | #ifndef PerlIO_sprintf | |
6f9d8c32 | 1000 | int |
760ac839 | 1001 | PerlIO_sprintf(char *s, int n, const char *fmt,...) |
760ac839 LW |
1002 | { |
1003 | va_list ap; | |
1004 | int result; | |
760ac839 | 1005 | va_start(ap,fmt); |
760ac839 LW |
1006 | result = PerlIO_vsprintf(s, n, fmt, ap); |
1007 | va_end(ap); | |
1008 | return result; | |
1009 | } | |
1010 | #endif | |
1011 | ||
c5be433b GS |
1012 | #endif /* !PERL_IMPLICIT_SYS */ |
1013 |