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 | { |
181 | PerlIO_debug(__FUNCTION__ " f=%p flags=%08X c=%d buf=%p ptr=%p\n", |
182 | f,f->flags,(f->ptr-f->buf),f->buf,f->ptr); |
183 | if (f->flags & PERLIO_F_WRBUF) |
184 | { |
b1ef6e3b |
185 | /* write() the buffer */ |
6f9d8c32 |
186 | STDCHAR *p = f->buf; |
187 | int count; |
188 | while (p < f->ptr) |
189 | { |
190 | count = write(f->fd,p,f->ptr - p); |
191 | if (count > 0) |
192 | { |
193 | p += count; |
194 | } |
195 | else if (count < 0 && errno != EINTR) |
196 | { |
bb9950b7 |
197 | f->flags |= PERLIO_F_ERROR; |
6f9d8c32 |
198 | code = -1; |
199 | break; |
200 | } |
201 | } |
202 | f->posn += (p - f->buf); |
203 | } |
204 | else if (f->flags & PERLIO_F_RDBUF) |
205 | { |
b1ef6e3b |
206 | /* Note position change */ |
6f9d8c32 |
207 | f->posn += (f->ptr - f->buf); |
208 | if (f->ptr < f->end) |
209 | { |
b1ef6e3b |
210 | /* We did not consume all of it */ |
6f9d8c32 |
211 | f->posn = lseek(f->fd,f->posn,SEEK_SET); |
212 | } |
213 | } |
214 | f->ptr = f->end = f->buf; |
215 | f->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); |
216 | } |
217 | else |
218 | { |
219 | int i; |
220 | for (i=_perlio_size; i >= 0; i--) |
221 | { |
222 | if ((f = _perlio[i])) |
223 | { |
224 | if (PerlIO_flush(f) != 0) |
225 | code = -1; |
226 | } |
227 | } |
228 | } |
229 | return code; |
230 | } |
231 | |
232 | int |
233 | PerlIO_oflags(const char *mode) |
234 | { |
235 | int oflags = -1; |
236 | PerlIO_debug(__FUNCTION__ " %s = ",mode); |
237 | switch(*mode) |
238 | { |
239 | case 'r': |
240 | oflags = O_RDONLY; |
241 | if (*++mode == '+') |
242 | { |
243 | oflags = O_RDWR; |
244 | mode++; |
245 | } |
246 | break; |
247 | |
248 | case 'w': |
249 | oflags = O_CREAT|O_TRUNC; |
250 | if (*++mode == '+') |
251 | { |
252 | oflags |= O_RDWR; |
253 | mode++; |
254 | } |
255 | else |
256 | oflags |= O_WRONLY; |
257 | break; |
258 | |
259 | case 'a': |
bb9950b7 |
260 | oflags = O_CREAT|O_APPEND; |
6f9d8c32 |
261 | if (*++mode == '+') |
262 | { |
263 | oflags |= O_RDWR; |
264 | mode++; |
265 | } |
266 | else |
267 | oflags |= O_WRONLY; |
268 | break; |
269 | } |
270 | if (*mode || oflags == -1) |
271 | { |
272 | errno = EINVAL; |
273 | oflags = -1; |
274 | } |
275 | PerlIO_debug(" %X '%s'\n",oflags,mode); |
276 | return oflags; |
277 | } |
278 | |
760ac839 |
279 | PerlIO * |
6f9d8c32 |
280 | PerlIO_allocate(void) |
281 | { |
b1ef6e3b |
282 | /* Find a free slot in the table, growing table as necessary */ |
6f9d8c32 |
283 | PerlIO *f; |
284 | int i = 0; |
285 | while (1) |
286 | { |
287 | PerlIO **table = _perlio; |
288 | while (i < _perlio_size) |
289 | { |
290 | f = table[i]; |
291 | PerlIO_debug(__FUNCTION__ " try %d %p\n",i,f); |
292 | if (!f) |
293 | { |
294 | Newz('F',f,1,PerlIO); |
295 | if (!f) |
296 | return NULL; |
297 | table[i] = f; |
298 | } |
299 | if (!(f->flags & PERLIO_F_USED)) |
300 | { |
301 | Zero(f,1,PerlIO); |
302 | f->flags = PERLIO_F_USED; |
303 | return f; |
304 | } |
305 | i++; |
306 | } |
307 | Newz('I',table,_perlio_size+16,PerlIO *); |
308 | if (!table) |
309 | return NULL; |
310 | Copy(_perlio,table,_perlio_size,PerlIO *); |
311 | if (_perlio) |
312 | Safefree(_perlio); |
313 | _perlio = table; |
314 | _perlio_size += 16; |
315 | } |
316 | } |
317 | |
318 | #undef PerlIO_fdopen |
319 | PerlIO * |
320 | PerlIO_fdopen(int fd, const char *mode) |
321 | { |
322 | PerlIO *f = NULL; |
323 | if (fd >= 0) |
324 | { |
325 | if ((f = PerlIO_allocate())) |
326 | { |
327 | f->fd = fd; |
328 | f->oflags = PerlIO_oflags(mode); |
329 | f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED); |
330 | } |
331 | } |
332 | PerlIO_debug(__FUNCTION__ " fd=%d m=%s f=%p\n",fd,mode,f); |
333 | return f; |
334 | } |
335 | |
336 | #undef PerlIO_fileno |
337 | int |
338 | PerlIO_fileno(PerlIO *f) |
760ac839 |
339 | { |
6f9d8c32 |
340 | if (f && (f->flags & PERLIO_F_OPEN)) |
341 | { |
342 | return f->fd; |
343 | } |
344 | return -1; |
345 | } |
346 | |
347 | #undef PerlIO_close |
348 | int |
349 | PerlIO_close(PerlIO *f) |
350 | { |
bb9950b7 |
351 | int code = 0; |
6f9d8c32 |
352 | if (f) |
353 | { |
bb9950b7 |
354 | if (PerlIO_flush(f) != 0) |
355 | code = -1; |
356 | while (close(f->fd) != 0) |
357 | { |
358 | if (errno != EINTR) |
359 | { |
360 | code = -1; |
361 | break; |
362 | } |
363 | } |
6f9d8c32 |
364 | f->flags &= ~PERLIO_F_OPEN; |
365 | f->fd = -1; |
366 | if (f->buf && f->buf != (STDCHAR *) &f->oneword) |
367 | { |
368 | Safefree(f->buf); |
369 | } |
370 | f->buf = NULL; |
371 | f->ptr = f->end = f->buf; |
372 | f->flags &= ~(PERLIO_F_USED|PERLIO_F_RDBUF|PERLIO_F_WRBUF); |
373 | } |
374 | return code; |
375 | } |
376 | |
377 | void |
378 | PerlIO_cleanup(void) |
379 | { |
b1ef6e3b |
380 | /* Close all the files */ |
6f9d8c32 |
381 | int i; |
382 | PerlIO_debug(__FUNCTION__ "\n"); |
383 | for (i=_perlio_size-1; i >= 0; i--) |
384 | { |
385 | PerlIO *f = _perlio[i]; |
386 | if (f) |
387 | { |
388 | PerlIO_close(f); |
389 | Safefree(f); |
390 | } |
391 | } |
392 | if (_perlio) |
393 | Safefree(_perlio); |
394 | _perlio = NULL; |
395 | _perlio_size = 0; |
396 | } |
397 | |
398 | #undef PerlIO_open |
399 | PerlIO * |
400 | PerlIO_open(const char *path, const char *mode) |
401 | { |
402 | PerlIO *f = NULL; |
403 | int oflags = PerlIO_oflags(mode); |
404 | if (oflags != -1) |
405 | { |
406 | int fd = open(path,oflags,0666); |
407 | if (fd >= 0) |
408 | { |
409 | PerlIO_debug(__FUNCTION__ "fd=%d\n",fd); |
410 | f = PerlIO_fdopen(fd,mode); |
411 | if (!f) |
412 | close(fd); |
413 | } |
414 | } |
415 | PerlIO_debug(__FUNCTION__ " path=%s m=%s f=%p\n",path,mode,f); |
416 | return f; |
417 | } |
418 | |
419 | #undef PerlIO_reopen |
420 | PerlIO * |
421 | PerlIO_reopen(const char *path, const char *mode, PerlIO *f) |
422 | { |
423 | PerlIO_debug(__FUNCTION__ " n=%s m=%s f=%p\n",path,mode,f); |
424 | if (f) |
425 | { |
426 | int oflags = PerlIO_oflags(mode); |
427 | PerlIO_close(f); |
428 | if (oflags != -1) |
429 | { |
430 | int fd = open(path,oflags,0666); |
431 | if (fd >= 0) |
432 | { |
433 | PerlIO_debug(__FUNCTION__ "fd=%d\n",fd); |
434 | f->oflags = oflags; |
435 | f->flags |= (PERLIO_F_OPEN|PERLIO_F_USED); |
436 | } |
437 | } |
438 | else |
439 | { |
440 | return NULL; |
441 | } |
442 | } |
443 | return PerlIO_open(path,mode); |
444 | } |
445 | |
446 | void |
447 | PerlIO_init(void) |
448 | { |
449 | if (!_perlio) |
450 | { |
451 | atexit(&PerlIO_cleanup); |
452 | PerlIO_fdopen(0,"r"); |
453 | PerlIO_fdopen(1,"w"); |
454 | PerlIO_fdopen(2,"w"); |
455 | } |
456 | PerlIO_debug(__FUNCTION__ "\n"); |
760ac839 |
457 | } |
458 | |
459 | #undef PerlIO_stdin |
460 | PerlIO * |
c78749f2 |
461 | PerlIO_stdin(void) |
760ac839 |
462 | { |
6f9d8c32 |
463 | if (!_perlio) |
464 | PerlIO_init(); |
465 | return _perlio[0]; |
760ac839 |
466 | } |
467 | |
468 | #undef PerlIO_stdout |
469 | PerlIO * |
c78749f2 |
470 | PerlIO_stdout(void) |
760ac839 |
471 | { |
6f9d8c32 |
472 | if (!_perlio) |
473 | PerlIO_init(); |
474 | return _perlio[1]; |
475 | } |
476 | |
477 | #undef PerlIO_stderr |
478 | PerlIO * |
479 | PerlIO_stderr(void) |
480 | { |
481 | if (!_perlio) |
482 | PerlIO_init(); |
483 | return _perlio[2]; |
760ac839 |
484 | } |
485 | |
760ac839 |
486 | #undef PerlIO_fast_gets |
6f9d8c32 |
487 | int |
c78749f2 |
488 | PerlIO_fast_gets(PerlIO *f) |
760ac839 |
489 | { |
760ac839 |
490 | return 1; |
760ac839 |
491 | } |
492 | |
493 | #undef PerlIO_has_cntptr |
6f9d8c32 |
494 | int |
c78749f2 |
495 | PerlIO_has_cntptr(PerlIO *f) |
760ac839 |
496 | { |
760ac839 |
497 | return 1; |
760ac839 |
498 | } |
499 | |
500 | #undef PerlIO_canset_cnt |
6f9d8c32 |
501 | int |
c78749f2 |
502 | PerlIO_canset_cnt(PerlIO *f) |
760ac839 |
503 | { |
760ac839 |
504 | return 1; |
760ac839 |
505 | } |
506 | |
507 | #undef PerlIO_set_cnt |
508 | void |
a20bf0c3 |
509 | PerlIO_set_cnt(PerlIO *f, int cnt) |
760ac839 |
510 | { |
6f9d8c32 |
511 | if (f) |
512 | { |
513 | dTHX; |
514 | if (!f->buf) |
515 | PerlIO_alloc_buf(f); |
516 | f->ptr = f->end - cnt; |
517 | assert(f->ptr >= f->buf); |
518 | } |
760ac839 |
519 | } |
520 | |
6f9d8c32 |
521 | #undef PerlIO_get_cnt |
522 | int |
523 | PerlIO_get_cnt(PerlIO *f) |
760ac839 |
524 | { |
6f9d8c32 |
525 | if (f) |
526 | { |
527 | if (!f->buf) |
528 | PerlIO_alloc_buf(f); |
529 | if (f->flags & PERLIO_F_RDBUF) |
530 | return (f->end - f->ptr); |
531 | } |
532 | return 0; |
760ac839 |
533 | } |
534 | |
6f9d8c32 |
535 | #undef PerlIO_set_ptrcnt |
536 | void |
537 | PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) |
760ac839 |
538 | { |
6f9d8c32 |
539 | if (f) |
540 | { |
6f9d8c32 |
541 | if (!f->buf) |
542 | PerlIO_alloc_buf(f); |
543 | f->ptr = ptr; |
b1ef6e3b |
544 | if (PerlIO_get_cnt(f) != cnt || f->ptr < f->buf) |
6f9d8c32 |
545 | { |
546 | dTHX; |
b1ef6e3b |
547 | assert(PerlIO_get_cnt(f) == cnt); |
548 | assert(f->ptr >= f->buf); |
6f9d8c32 |
549 | } |
bb9950b7 |
550 | f->flags |= PERLIO_F_RDBUF; |
6f9d8c32 |
551 | } |
760ac839 |
552 | } |
553 | |
554 | #undef PerlIO_get_bufsiz |
6f9d8c32 |
555 | int |
a20bf0c3 |
556 | PerlIO_get_bufsiz(PerlIO *f) |
760ac839 |
557 | { |
6f9d8c32 |
558 | if (f) |
559 | { |
560 | if (!f->buf) |
561 | PerlIO_alloc_buf(f); |
562 | return f->bufsiz; |
563 | } |
760ac839 |
564 | return -1; |
760ac839 |
565 | } |
566 | |
567 | #undef PerlIO_get_ptr |
888911fc |
568 | STDCHAR * |
a20bf0c3 |
569 | PerlIO_get_ptr(PerlIO *f) |
760ac839 |
570 | { |
6f9d8c32 |
571 | if (f) |
572 | { |
573 | if (!f->buf) |
574 | PerlIO_alloc_buf(f); |
575 | return f->ptr; |
576 | } |
760ac839 |
577 | return NULL; |
760ac839 |
578 | } |
579 | |
580 | #undef PerlIO_get_base |
888911fc |
581 | STDCHAR * |
a20bf0c3 |
582 | PerlIO_get_base(PerlIO *f) |
760ac839 |
583 | { |
6f9d8c32 |
584 | if (f) |
585 | { |
586 | if (!f->buf) |
587 | PerlIO_alloc_buf(f); |
588 | return f->buf; |
589 | } |
760ac839 |
590 | return NULL; |
760ac839 |
591 | } |
592 | |
6f9d8c32 |
593 | #undef PerlIO_has_base |
594 | int |
c78749f2 |
595 | PerlIO_has_base(PerlIO *f) |
760ac839 |
596 | { |
6f9d8c32 |
597 | if (f) |
598 | { |
599 | if (!f->buf) |
600 | PerlIO_alloc_buf(f); |
601 | return f->buf != NULL; |
602 | } |
760ac839 |
603 | } |
604 | |
605 | #undef PerlIO_puts |
606 | int |
c78749f2 |
607 | PerlIO_puts(PerlIO *f, const char *s) |
760ac839 |
608 | { |
6f9d8c32 |
609 | STRLEN len = strlen(s); |
610 | return PerlIO_write(f,s,len); |
760ac839 |
611 | } |
612 | |
613 | #undef PerlIO_eof |
6f9d8c32 |
614 | int |
c78749f2 |
615 | PerlIO_eof(PerlIO *f) |
760ac839 |
616 | { |
6f9d8c32 |
617 | if (f) |
618 | { |
619 | return (f->flags & PERLIO_F_EOF) != 0; |
620 | } |
621 | return 1; |
760ac839 |
622 | } |
623 | |
8c86a920 |
624 | #undef PerlIO_getname |
625 | char * |
a20bf0c3 |
626 | PerlIO_getname(PerlIO *f, char *buf) |
8c86a920 |
627 | { |
961e40ee |
628 | dTHX; |
cea2e8a9 |
629 | Perl_croak(aTHX_ "Don't know how to get file name"); |
c64afb19 |
630 | return NULL; |
8c86a920 |
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; |
640 | return ch; |
641 | } |
bb9950b7 |
642 | PerlIO_debug(__FUNCTION__ " f=%p c=%c - cannot\n",f,ch); |
6f9d8c32 |
643 | return -1; |
644 | } |
645 | |
646 | #undef PerlIO_read |
647 | SSize_t |
648 | PerlIO_read(PerlIO *f, void *vbuf, Size_t count) |
649 | { |
650 | STDCHAR *buf = (STDCHAR *) vbuf; |
651 | if (f) |
652 | { |
653 | Size_t got = 0; |
654 | if (!f->ptr) |
655 | PerlIO_alloc_buf(f); |
656 | |
657 | while (count > 0) |
658 | { |
659 | SSize_t avail = (f->end - f->ptr); |
660 | if ((SSize_t) count < avail) |
661 | avail = count; |
662 | if (avail > 0) |
663 | { |
664 | Copy(f->ptr,buf,avail,char); |
665 | got += avail; |
666 | f->ptr += avail; |
667 | count -= avail; |
668 | buf += avail; |
669 | } |
670 | if (count && (f->ptr >= f->end)) |
671 | { |
bb9950b7 |
672 | PerlIO_flush(f); |
6f9d8c32 |
673 | f->ptr = f->end = f->buf; |
674 | avail = read(f->fd,f->ptr,f->bufsiz); |
675 | if (avail <= 0) |
676 | { |
677 | if (avail == 0) |
678 | f->flags |= PERLIO_F_EOF; |
679 | else if (errno == EINTR) |
680 | continue; |
681 | else |
682 | f->flags |= PERLIO_F_ERROR; |
683 | break; |
684 | } |
685 | f->end = f->buf+avail; |
686 | f->flags |= PERLIO_F_RDBUF; |
687 | } |
688 | } |
689 | return got; |
690 | } |
691 | return 0; |
692 | } |
693 | |
760ac839 |
694 | #undef PerlIO_getc |
6f9d8c32 |
695 | int |
c78749f2 |
696 | PerlIO_getc(PerlIO *f) |
760ac839 |
697 | { |
6f9d8c32 |
698 | STDCHAR buf; |
699 | int count = PerlIO_read(f,&buf,1); |
700 | if (count == 1) |
b1ef6e3b |
701 | return (unsigned char) buf; |
6f9d8c32 |
702 | return -1; |
760ac839 |
703 | } |
704 | |
705 | #undef PerlIO_error |
6f9d8c32 |
706 | int |
c78749f2 |
707 | PerlIO_error(PerlIO *f) |
760ac839 |
708 | { |
6f9d8c32 |
709 | if (f) |
710 | { |
711 | return f->flags & PERLIO_F_ERROR; |
712 | } |
713 | return 1; |
760ac839 |
714 | } |
715 | |
716 | #undef PerlIO_clearerr |
717 | void |
c78749f2 |
718 | PerlIO_clearerr(PerlIO *f) |
760ac839 |
719 | { |
6f9d8c32 |
720 | if (f) |
721 | { |
722 | f->flags &= ~PERLIO_F_ERROR; |
723 | } |
760ac839 |
724 | } |
725 | |
726 | #undef PerlIO_setlinebuf |
727 | void |
c78749f2 |
728 | PerlIO_setlinebuf(PerlIO *f) |
760ac839 |
729 | { |
6f9d8c32 |
730 | if (f) |
731 | { |
732 | f->flags &= ~PERLIO_F_LINEBUF; |
733 | } |
760ac839 |
734 | } |
735 | |
736 | #undef PerlIO_write |
5b54f415 |
737 | SSize_t |
6f9d8c32 |
738 | PerlIO_write(PerlIO *f, const void *vbuf, Size_t count) |
760ac839 |
739 | { |
6f9d8c32 |
740 | const STDCHAR *buf = (const STDCHAR *) vbuf; |
741 | Size_t written = 0; |
742 | PerlIO_debug(__FUNCTION__ " f=%p c=%d\n",f,count); |
743 | if (f) |
744 | { |
745 | if (!f->buf) |
746 | PerlIO_alloc_buf(f); |
747 | while (count > 0) |
748 | { |
bb9950b7 |
749 | SSize_t avail = f->bufsiz - (f->ptr - f->buf); |
750 | if ((SSize_t) count < avail) |
6f9d8c32 |
751 | avail = count; |
752 | f->flags |= PERLIO_F_WRBUF; |
b1ef6e3b |
753 | if (f->flags & PERLIO_F_LINEBUF) |
6f9d8c32 |
754 | { |
755 | while (avail > 0) |
756 | { |
757 | int ch = *buf++; |
758 | *(f->ptr)++ = ch; |
759 | count--; |
760 | avail--; |
761 | written++; |
762 | if (ch == '\n') |
bb9950b7 |
763 | { |
764 | PerlIO_flush(f); |
765 | break; |
766 | } |
6f9d8c32 |
767 | } |
768 | } |
769 | else |
770 | { |
771 | if (avail) |
772 | { |
773 | Copy(buf,f->ptr,avail,char); |
774 | count -= avail; |
775 | buf += avail; |
776 | written += avail; |
777 | f->ptr += avail; |
778 | } |
779 | } |
780 | if (f->ptr >= (f->buf + f->bufsiz)) |
781 | PerlIO_flush(f); |
782 | } |
783 | } |
784 | return written; |
760ac839 |
785 | } |
786 | |
6f9d8c32 |
787 | #undef PerlIO_putc |
788 | int |
789 | PerlIO_putc(PerlIO *f, int ch) |
760ac839 |
790 | { |
6f9d8c32 |
791 | STDCHAR buf = ch; |
792 | PerlIO_write(f,&ch,1); |
760ac839 |
793 | } |
794 | |
760ac839 |
795 | #undef PerlIO_tell |
5ff3f7a4 |
796 | Off_t |
c78749f2 |
797 | PerlIO_tell(PerlIO *f) |
760ac839 |
798 | { |
bb9950b7 |
799 | Off_t posn = f->posn; |
800 | if (f->buf) |
801 | posn += (f->ptr - f->buf); |
b1ef6e3b |
802 | PerlIO_debug(__FUNCTION__ " f=%p b=%ld a=%ld\n",f,(long)f->posn,(long)posn); |
6f9d8c32 |
803 | return posn; |
760ac839 |
804 | } |
805 | |
806 | #undef PerlIO_seek |
807 | int |
c78749f2 |
808 | PerlIO_seek(PerlIO *f, Off_t offset, int whence) |
760ac839 |
809 | { |
bb9950b7 |
810 | int code; |
811 | PerlIO_debug(__FUNCTION__ " f=%p i=%ld+%d\n",f,(long)f->posn,(f->ptr-f->buf)); |
812 | code = PerlIO_flush(f); |
6f9d8c32 |
813 | if (code == 0) |
814 | { |
815 | f->flags &= ~PERLIO_F_EOF; |
bb9950b7 |
816 | f->posn = PerlLIO_lseek(f->fd,offset,whence); |
817 | PerlIO_debug(__FUNCTION__ " f=%p o=%ld w=%d p=%ld\n", |
818 | f,(long)offset,whence,(long)f->posn); |
6f9d8c32 |
819 | if (f->posn == (Off_t) -1) |
820 | { |
821 | f->posn = 0; |
822 | code = -1; |
823 | } |
824 | } |
825 | return code; |
760ac839 |
826 | } |
827 | |
828 | #undef PerlIO_rewind |
829 | void |
c78749f2 |
830 | PerlIO_rewind(PerlIO *f) |
760ac839 |
831 | { |
6f9d8c32 |
832 | PerlIO_seek(f,(Off_t)0,SEEK_SET); |
833 | } |
834 | |
835 | #undef PerlIO_vprintf |
836 | int |
837 | PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) |
838 | { |
839 | dTHX; |
bb9950b7 |
840 | SV *sv = newSVpvn("",0); |
6f9d8c32 |
841 | char *s; |
842 | STRLEN len; |
843 | sv_vcatpvf(sv, fmt, &ap); |
844 | s = SvPV(sv,len); |
bb9950b7 |
845 | return PerlIO_write(f,s,len); |
760ac839 |
846 | } |
847 | |
848 | #undef PerlIO_printf |
6f9d8c32 |
849 | int |
760ac839 |
850 | PerlIO_printf(PerlIO *f,const char *fmt,...) |
760ac839 |
851 | { |
852 | va_list ap; |
853 | int result; |
760ac839 |
854 | va_start(ap,fmt); |
6f9d8c32 |
855 | result = PerlIO_vprintf(f,fmt,ap); |
760ac839 |
856 | va_end(ap); |
857 | return result; |
858 | } |
859 | |
860 | #undef PerlIO_stdoutf |
6f9d8c32 |
861 | int |
760ac839 |
862 | PerlIO_stdoutf(const char *fmt,...) |
760ac839 |
863 | { |
864 | va_list ap; |
865 | int result; |
760ac839 |
866 | va_start(ap,fmt); |
760ac839 |
867 | result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap); |
868 | va_end(ap); |
869 | return result; |
870 | } |
871 | |
872 | #undef PerlIO_tmpfile |
873 | PerlIO * |
c78749f2 |
874 | PerlIO_tmpfile(void) |
760ac839 |
875 | { |
6f9d8c32 |
876 | dTHX; |
b1ef6e3b |
877 | /* I have no idea how portable mkstemp() is ... */ |
6f9d8c32 |
878 | SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0); |
879 | int fd = mkstemp(SvPVX(sv)); |
880 | PerlIO *f = NULL; |
881 | if (fd >= 0) |
882 | { |
b1ef6e3b |
883 | f = PerlIO_fdopen(fd,"w+"); |
6f9d8c32 |
884 | if (f) |
885 | { |
886 | f->flags |= PERLIO_F_TEMP; |
887 | } |
888 | unlink(SvPVX(sv)); |
889 | SvREFCNT_dec(sv); |
890 | } |
891 | return f; |
760ac839 |
892 | } |
893 | |
894 | #undef PerlIO_importFILE |
895 | PerlIO * |
c78749f2 |
896 | PerlIO_importFILE(FILE *f, int fl) |
760ac839 |
897 | { |
6f9d8c32 |
898 | int fd = fileno(f); |
b1ef6e3b |
899 | /* Should really push stdio discipline when we have them */ |
6f9d8c32 |
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); |
b1ef6e3b |
908 | /* Should really push stdio discipline when we have them */ |
6f9d8c32 |
909 | return fdopen(PerlIO_fileno(f),"r+"); |
760ac839 |
910 | } |
911 | |
912 | #undef PerlIO_findFILE |
913 | FILE * |
c78749f2 |
914 | PerlIO_findFILE(PerlIO *f) |
760ac839 |
915 | { |
6f9d8c32 |
916 | return PerlIO_exportFILE(f,0); |
760ac839 |
917 | } |
918 | |
919 | #undef PerlIO_releaseFILE |
920 | void |
c78749f2 |
921 | PerlIO_releaseFILE(PerlIO *p, FILE *f) |
760ac839 |
922 | { |
923 | } |
924 | |
6f9d8c32 |
925 | #undef HAS_FSETPOS |
926 | #undef HAS_FGETPOS |
927 | |
928 | /*======================================================================================*/ |
760ac839 |
929 | |
930 | #endif /* USE_SFIO */ |
931 | #endif /* PERLIO_IS_STDIO */ |
932 | |
933 | #ifndef HAS_FSETPOS |
934 | #undef PerlIO_setpos |
935 | int |
c78749f2 |
936 | PerlIO_setpos(PerlIO *f, const Fpos_t *pos) |
760ac839 |
937 | { |
6f9d8c32 |
938 | return PerlIO_seek(f,*pos,0); |
760ac839 |
939 | } |
c411622e |
940 | #else |
941 | #ifndef PERLIO_IS_STDIO |
942 | #undef PerlIO_setpos |
943 | int |
c78749f2 |
944 | PerlIO_setpos(PerlIO *f, const Fpos_t *pos) |
c411622e |
945 | { |
2d4389e4 |
946 | #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) |
d9b3e12d |
947 | return fsetpos64(f, pos); |
948 | #else |
c411622e |
949 | return fsetpos(f, pos); |
d9b3e12d |
950 | #endif |
c411622e |
951 | } |
952 | #endif |
760ac839 |
953 | #endif |
954 | |
955 | #ifndef HAS_FGETPOS |
956 | #undef PerlIO_getpos |
957 | int |
c78749f2 |
958 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
760ac839 |
959 | { |
960 | *pos = PerlIO_tell(f); |
961 | return 0; |
962 | } |
c411622e |
963 | #else |
964 | #ifndef PERLIO_IS_STDIO |
965 | #undef PerlIO_getpos |
966 | int |
c78749f2 |
967 | PerlIO_getpos(PerlIO *f, Fpos_t *pos) |
c411622e |
968 | { |
2d4389e4 |
969 | #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) |
d9b3e12d |
970 | return fgetpos64(f, pos); |
971 | #else |
c411622e |
972 | return fgetpos(f, pos); |
d9b3e12d |
973 | #endif |
c411622e |
974 | } |
975 | #endif |
760ac839 |
976 | #endif |
977 | |
978 | #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) |
979 | |
980 | int |
c78749f2 |
981 | vprintf(char *pat, char *args) |
662a7e3f |
982 | { |
983 | _doprnt(pat, args, stdout); |
984 | return 0; /* wrong, but perl doesn't use the return value */ |
985 | } |
986 | |
987 | int |
c78749f2 |
988 | vfprintf(FILE *fd, char *pat, char *args) |
760ac839 |
989 | { |
990 | _doprnt(pat, args, fd); |
991 | return 0; /* wrong, but perl doesn't use the return value */ |
992 | } |
993 | |
994 | #endif |
995 | |
996 | #ifndef PerlIO_vsprintf |
6f9d8c32 |
997 | int |
8ac85365 |
998 | PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) |
760ac839 |
999 | { |
1000 | int val = vsprintf(s, fmt, ap); |
1001 | if (n >= 0) |
1002 | { |
8c86a920 |
1003 | if (strlen(s) >= (STRLEN)n) |
760ac839 |
1004 | { |
bf49b057 |
1005 | dTHX; |
1006 | PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); |
1007 | my_exit(1); |
760ac839 |
1008 | } |
1009 | } |
1010 | return val; |
1011 | } |
1012 | #endif |
1013 | |
1014 | #ifndef PerlIO_sprintf |
6f9d8c32 |
1015 | int |
760ac839 |
1016 | PerlIO_sprintf(char *s, int n, const char *fmt,...) |
760ac839 |
1017 | { |
1018 | va_list ap; |
1019 | int result; |
760ac839 |
1020 | va_start(ap,fmt); |
760ac839 |
1021 | result = PerlIO_vsprintf(s, n, fmt, ap); |
1022 | va_end(ap); |
1023 | return result; |
1024 | } |
1025 | #endif |
1026 | |
c5be433b |
1027 | #endif /* !PERL_IMPLICIT_SYS */ |
1028 | |