Commit | Line | Data |
760ac839 |
1 | /* perlio.c |
2 | * |
1761cee5 |
3 | * Copyright (c) 1996-2000, Nick Ing-Simmons |
760ac839 |
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 |
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 |
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 |
25 | */ |
26 | |
27 | #include "EXTERN.h" |
864dbfa3 |
28 | #define PERL_IN_PERLIO_C |
760ac839 |
29 | #include "perl.h" |
30 | |
32e30700 |
31 | #if !defined(PERL_IMPLICIT_SYS) |
32 | |
6f9d8c32 |
33 | #ifdef PERLIO_IS_STDIO |
760ac839 |
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 |
40 | of other functions that may be required by loadable |
41 | extensions e.g. for FileHandle::tmpfile |
760ac839 |
42 | */ |
43 | } |
44 | |
33dcbb9a |
45 | #undef PerlIO_tmpfile |
46 | PerlIO * |
8ac85365 |
47 | PerlIO_tmpfile(void) |
33dcbb9a |
48 | { |
49 | return tmpfile(); |
50 | } |
51 | |
760ac839 |
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 |
60 | get pulled in from libsfio.a |
61 | */ |
62 | |
63 | #undef PerlIO_tmpfile |
64 | PerlIO * |
c78749f2 |
65 | PerlIO_tmpfile(void) |
760ac839 |
66 | { |
67 | return sftmp(0); |
68 | } |
69 | |
70 | void |
c78749f2 |
71 | PerlIO_init(void) |
760ac839 |
72 | { |
6f9d8c32 |
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 |
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 |
81 | * lot of small writes to pipes. |
82 | */ |
83 | sfset(sfstdout,SF_SHARE,0); |
84 | } |
85 | |
17c3b450 |
86 | #else /* USE_SFIO */ |
760ac839 |
87 | |
6f9d8c32 |
88 | /*======================================================================================*/ |
89 | |
90 | /* Implement all the PerlIO interface ourselves. |
760ac839 |
91 | */ |
92 | |
b1ef6e3b |
93 | /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */ |
02f66e2f |
94 | #ifdef I_UNISTD |
95 | #include <unistd.h> |
96 | #endif |
97 | |
6f9d8c32 |
98 | #undef printf |
99 | void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2))); |
100 | |
6f9d8c32 |
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 |
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 |
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 |
154 | |
155 | void |
156 | PerlIO_alloc_buf(PerlIO *f) |
157 | { |
158 | if (!f->bufsiz) |
bb9950b7 |
159 | f->bufsiz = 4096; |
6f9d8c32 |
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 |
168 | } |
169 | |
b1ef6e3b |
170 | |
171 | /* This "flush" is akin to sfio's sync in that it handles files in either |
172 | read or write state |
173 | */ |
6f9d8c32 |
174 | #undef PerlIO_flush |
175 | int |
176 | PerlIO_flush(PerlIO *f) |
177 | { |
178 | int code = 0; |
179 | if (f) |
180 | { |
6f9d8c32 |
181 | if (f->flags & PERLIO_F_WRBUF) |
182 | { |
b1ef6e3b |
183 | /* write() the buffer */ |
6f9d8c32 |
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 |
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 |
205 | f->posn += (f->ptr - f->buf); |
206 | if (f->ptr < f->end) |
207 | { |
b1ef6e3b |
208 | /* We did not consume all of it */ |
6f9d8c32 |
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 |
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 |
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 |
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 |
272 | return oflags; |
273 | } |
274 | |
760ac839 |
275 | PerlIO * |
6f9d8c32 |
276 | PerlIO_allocate(void) |
277 | { |
b1ef6e3b |
278 | /* Find a free slot in the table, growing table as necessary */ |
6f9d8c32 |
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 |
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 |
327 | return f; |
328 | } |
329 | |
330 | #undef PerlIO_fileno |
331 | int |
332 | PerlIO_fileno(PerlIO *f) |
760ac839 |
333 | { |
6f9d8c32 |
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 |
346 | if (f) |
347 | { |
bb9950b7 |
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 |
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 |
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 |
402 | f = PerlIO_fdopen(fd,mode); |
403 | if (!f) |
404 | close(fd); |
405 | } |
406 | } |
6f9d8c32 |
407 | return f; |
408 | } |
409 | |
410 | #undef PerlIO_reopen |
411 | PerlIO * |
412 | PerlIO_reopen(const char *path, const char *mode, PerlIO *f) |
413 | { |
6f9d8c32 |
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 |
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 |
445 | } |
446 | |
447 | #undef PerlIO_stdin |
448 | PerlIO * |
c78749f2 |
449 | PerlIO_stdin(void) |
760ac839 |
450 | { |
6f9d8c32 |
451 | if (!_perlio) |
452 | PerlIO_init(); |
453 | return _perlio[0]; |
760ac839 |
454 | } |
455 | |
456 | #undef PerlIO_stdout |
457 | PerlIO * |
c78749f2 |
458 | PerlIO_stdout(void) |
760ac839 |
459 | { |
6f9d8c32 |
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 |
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 |
479 | } |
480 | |
481 | #undef PerlIO_has_cntptr |
6f9d8c32 |
482 | int |
c78749f2 |
483 | PerlIO_has_cntptr(PerlIO *f) |
760ac839 |
484 | { |
760ac839 |
485 | return 1; |
760ac839 |
486 | } |
487 | |
488 | #undef PerlIO_canset_cnt |
6f9d8c32 |
489 | int |
c78749f2 |
490 | PerlIO_canset_cnt(PerlIO *f) |
760ac839 |
491 | { |
760ac839 |
492 | return 1; |
760ac839 |
493 | } |
494 | |
495 | #undef PerlIO_set_cnt |
496 | void |
a20bf0c3 |
497 | PerlIO_set_cnt(PerlIO *f, int cnt) |
760ac839 |
498 | { |
6f9d8c32 |
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 |
507 | } |
508 | |
6f9d8c32 |
509 | #undef PerlIO_get_cnt |
510 | int |
511 | PerlIO_get_cnt(PerlIO *f) |
760ac839 |
512 | { |
6f9d8c32 |
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 |
521 | } |
522 | |
6f9d8c32 |
523 | #undef PerlIO_set_ptrcnt |
524 | void |
525 | PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) |
760ac839 |
526 | { |
6f9d8c32 |
527 | if (f) |
528 | { |
6f9d8c32 |
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 |
533 | { |
534 | dTHX; |
b1ef6e3b |
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 |
540 | } |
541 | |
542 | #undef PerlIO_get_bufsiz |
6f9d8c32 |
543 | int |
a20bf0c3 |
544 | PerlIO_get_bufsiz(PerlIO *f) |
760ac839 |
545 | { |
6f9d8c32 |
546 | if (f) |
547 | { |
548 | if (!f->buf) |
549 | PerlIO_alloc_buf(f); |
550 | return f->bufsiz; |
551 | } |
760ac839 |
552 | return -1; |
760ac839 |
553 | } |
554 | |
555 | #undef PerlIO_get_ptr |
888911fc |
556 | STDCHAR * |
a20bf0c3 |
557 | PerlIO_get_ptr(PerlIO *f) |
760ac839 |
558 | { |
6f9d8c32 |
559 | if (f) |
560 | { |
561 | if (!f->buf) |
562 | PerlIO_alloc_buf(f); |
563 | return f->ptr; |
564 | } |
760ac839 |
565 | return NULL; |
760ac839 |
566 | } |
567 | |
568 | #undef PerlIO_get_base |
888911fc |
569 | STDCHAR * |
a20bf0c3 |
570 | PerlIO_get_base(PerlIO *f) |
760ac839 |
571 | { |
6f9d8c32 |
572 | if (f) |
573 | { |
574 | if (!f->buf) |
575 | PerlIO_alloc_buf(f); |
576 | return f->buf; |
577 | } |
760ac839 |
578 | return NULL; |
760ac839 |
579 | } |
580 | |
6f9d8c32 |
581 | #undef PerlIO_has_base |
582 | int |
c78749f2 |
583 | PerlIO_has_base(PerlIO *f) |
760ac839 |
584 | { |
6f9d8c32 |
585 | if (f) |
586 | { |
587 | if (!f->buf) |
588 | PerlIO_alloc_buf(f); |
589 | return f->buf != NULL; |
590 | } |
760ac839 |
591 | } |
592 | |
593 | #undef PerlIO_puts |
594 | int |
c78749f2 |
595 | PerlIO_puts(PerlIO *f, const char *s) |
760ac839 |
596 | { |
6f9d8c32 |
597 | STRLEN len = strlen(s); |
598 | return PerlIO_write(f,s,len); |
760ac839 |
599 | } |
600 | |
601 | #undef PerlIO_eof |
6f9d8c32 |
602 | int |
c78749f2 |
603 | PerlIO_eof(PerlIO *f) |
760ac839 |
604 | { |
6f9d8c32 |
605 | if (f) |
606 | { |
607 | return (f->flags & PERLIO_F_EOF) != 0; |
608 | } |
609 | return 1; |
760ac839 |
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 |
621 | #undef PerlIO_ungetc |
622 | int |
623 | PerlIO_ungetc(PerlIO *f, int ch) |
624 | { |
6f9d8c32 |
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 |
643 | if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_WRONLY) |
644 | return 0; |
6f9d8c32 |
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 |
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 |
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 |
691 | } |
692 | |
693 | #undef PerlIO_error |
6f9d8c32 |
694 | int |
c78749f2 |
695 | PerlIO_error(PerlIO *f) |
760ac839 |
696 | { |
6f9d8c32 |
697 | if (f) |
698 | { |
699 | return f->flags & PERLIO_F_ERROR; |
700 | } |
701 | return 1; |
760ac839 |
702 | } |
703 | |
704 | #undef PerlIO_clearerr |
705 | void |
c78749f2 |
706 | PerlIO_clearerr(PerlIO *f) |
760ac839 |
707 | { |
6f9d8c32 |
708 | if (f) |
709 | { |
710 | f->flags &= ~PERLIO_F_ERROR; |
711 | } |
760ac839 |
712 | } |
713 | |
714 | #undef PerlIO_setlinebuf |
715 | void |
c78749f2 |
716 | PerlIO_setlinebuf(PerlIO *f) |
760ac839 |
717 | { |
6f9d8c32 |
718 | if (f) |
719 | { |
720 | f->flags &= ~PERLIO_F_LINEBUF; |
721 | } |
760ac839 |
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 |
728 | const STDCHAR *buf = (const STDCHAR *) vbuf; |
729 | Size_t written = 0; |
6f9d8c32 |
730 | if (f) |
731 | { |
732 | if (!f->buf) |
733 | PerlIO_alloc_buf(f); |
f89522bf |
734 | if ((f->oflags & (O_RDONLY|O_WRONLY|O_RDWR)) == O_RDONLY) |
735 | return 0; |
6f9d8c32 |
736 | while (count > 0) |
737 | { |
bb9950b7 |
738 | SSize_t avail = f->bufsiz - (f->ptr - f->buf); |
739 | if ((SSize_t) count < avail) |
6f9d8c32 |
740 | avail = count; |
741 | f->flags |= PERLIO_F_WRBUF; |
b1ef6e3b |
742 | if (f->flags & PERLIO_F_LINEBUF) |
6f9d8c32 |
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 |
752 | { |
753 | PerlIO_flush(f); |
754 | break; |
755 | } |
6f9d8c32 |
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 |
774 | } |
775 | |
6f9d8c32 |
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 |
782 | } |
783 | |
760ac839 |
784 | #undef PerlIO_tell |
5ff3f7a4 |
785 | Off_t |
c78749f2 |
786 | PerlIO_tell(PerlIO *f) |
760ac839 |
787 | { |
bb9950b7 |
788 | Off_t posn = f->posn; |
789 | if (f->buf) |
790 | posn += (f->ptr - f->buf); |
6f9d8c32 |
791 | return posn; |
760ac839 |
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 |
800 | if (code == 0) |
801 | { |
802 | f->flags &= ~PERLIO_F_EOF; |
bb9950b7 |
803 | f->posn = PerlLIO_lseek(f->fd,offset,whence); |
6f9d8c32 |
804 | if (f->posn == (Off_t) -1) |
805 | { |
806 | f->posn = 0; |
807 | code = -1; |
808 | } |
809 | } |
810 | return code; |
760ac839 |
811 | } |
812 | |
813 | #undef PerlIO_rewind |
814 | void |
c78749f2 |
815 | PerlIO_rewind(PerlIO *f) |
760ac839 |
816 | { |
6f9d8c32 |
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 |
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 |
831 | } |
832 | |
833 | #undef PerlIO_printf |
6f9d8c32 |
834 | int |
760ac839 |
835 | PerlIO_printf(PerlIO *f,const char *fmt,...) |
760ac839 |
836 | { |
837 | va_list ap; |
838 | int result; |
760ac839 |
839 | va_start(ap,fmt); |
6f9d8c32 |
840 | result = PerlIO_vprintf(f,fmt,ap); |
760ac839 |
841 | va_end(ap); |
842 | return result; |
843 | } |
844 | |
845 | #undef PerlIO_stdoutf |
6f9d8c32 |
846 | int |
760ac839 |
847 | PerlIO_stdoutf(const char *fmt,...) |
760ac839 |
848 | { |
849 | va_list ap; |
850 | int result; |
760ac839 |
851 | va_start(ap,fmt); |
760ac839 |
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 |
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 |
869 | if (f) |
870 | { |
871 | f->flags |= PERLIO_F_TEMP; |
872 | } |
873 | unlink(SvPVX(sv)); |
874 | SvREFCNT_dec(sv); |
875 | } |
876 | return f; |
760ac839 |
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 |
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 |
895 | } |
896 | |
897 | #undef PerlIO_findFILE |
898 | FILE * |
c78749f2 |
899 | PerlIO_findFILE(PerlIO *f) |
760ac839 |
900 | { |
6f9d8c32 |
901 | return PerlIO_exportFILE(f,0); |
760ac839 |
902 | } |
903 | |
904 | #undef PerlIO_releaseFILE |
905 | void |
c78749f2 |
906 | PerlIO_releaseFILE(PerlIO *p, FILE *f) |
760ac839 |
907 | { |
908 | } |
909 | |
6f9d8c32 |
910 | #undef HAS_FSETPOS |
911 | #undef HAS_FGETPOS |
912 | |
913 | /*======================================================================================*/ |
760ac839 |
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 |
932 | return fsetpos64(f, pos); |
933 | #else |
c411622e |
934 | return fsetpos(f, pos); |
d9b3e12d |
935 | #endif |
c411622e |
936 | } |
937 | #endif |
760ac839 |
938 | #endif |
939 | |
940 | #ifndef HAS_FGETPOS |
941 | #undef PerlIO_getpos |
942 | int |
c78749f2 |
943 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
760ac839 |
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 |
955 | return fgetpos64(f, pos); |
956 | #else |
c411622e |
957 | return fgetpos(f, pos); |
d9b3e12d |
958 | #endif |
c411622e |
959 | } |
960 | #endif |
760ac839 |
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 |
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 |
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 |
984 | { |
985 | int val = vsprintf(s, fmt, ap); |
986 | if (n >= 0) |
987 | { |
8c86a920 |
988 | if (strlen(s) >= (STRLEN)n) |
760ac839 |
989 | { |
bf49b057 |
990 | dTHX; |
991 | PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); |
992 | my_exit(1); |
760ac839 |
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 |
1002 | { |
1003 | va_list ap; |
1004 | int result; |
760ac839 |
1005 | va_start(ap,fmt); |
760ac839 |
1006 | result = PerlIO_vsprintf(s, n, fmt, ap); |
1007 | va_end(ap); |
1008 | return result; |
1009 | } |
1010 | #endif |
1011 | |
c5be433b |
1012 | #endif /* !PERL_IMPLICIT_SYS */ |
1013 | |