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