This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix for stdio as default "discipline" - PerlIO_init() was fdopen(2,"w")'ing
[perl5.git] / perlio.c
CommitLineData
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
35void
8ac85365 36PerlIO_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
PP
45#undef PerlIO_tmpfile
46PerlIO *
8ac85365 47PerlIO_tmpfile(void)
33dcbb9a
PP
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
64PerlIO *
c78749f2 65PerlIO_tmpfile(void)
760ac839
LW
66{
67 return sftmp(0);
68}
69
70void
c78749f2 71PerlIO_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 */
6f9d8c32 87/*======================================================================================*/
6f9d8c32 88/* Implement all the PerlIO interface ourselves.
9e353e3b 89 */
760ac839 90
b1ef6e3b 91/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
02f66e2f
NIS
92#ifdef I_UNISTD
93#include <unistd.h>
94#endif
95
6f9d8c32
NIS
96#undef printf
97void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
98
6f9d8c32
NIS
99void
100PerlIO_debug(char *fmt,...)
101{
102 static int dbg = 0;
103 if (!dbg)
104 {
105 char *s = getenv("PERLIO_DEBUG");
106 if (s && *s)
107 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
108 else
109 dbg = -1;
110 }
111 if (dbg > 0)
112 {
113 dTHX;
114 va_list ap;
115 SV *sv = newSVpvn("",0);
116 char *s;
117 STRLEN len;
118 va_start(ap,fmt);
c7fc522f
NIS
119 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ",
120 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
121 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
122
6f9d8c32
NIS
123 s = SvPV(sv,len);
124 write(dbg,s,len);
125 va_end(ap);
126 SvREFCNT_dec(sv);
127 }
128}
129
9e353e3b
NIS
130/*--------------------------------------------------------------------------------------*/
131
132typedef struct
133{
134 char * name;
135 Size_t size;
136 IV kind;
137 IV (*Fileno)(PerlIO *f);
138 PerlIO * (*Fdopen)(int fd, const char *mode);
139 PerlIO * (*Open)(const char *path, const char *mode);
140 int (*Reopen)(const char *path, const char *mode, PerlIO *f);
141 /* Unix-like functions - cf sfio line disciplines */
142 SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
143 SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
144 SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
145 IV (*Seek)(PerlIO *f, Off_t offset, int whence);
146 Off_t (*Tell)(PerlIO *f);
147 IV (*Close)(PerlIO *f);
148 /* Stdio-like buffered IO functions */
149 IV (*Flush)(PerlIO *f);
150 IV (*Eof)(PerlIO *f);
151 IV (*Error)(PerlIO *f);
152 void (*Clearerr)(PerlIO *f);
153 void (*Setlinebuf)(PerlIO *f);
154 /* Perl's snooping functions */
155 STDCHAR * (*Get_base)(PerlIO *f);
156 Size_t (*Get_bufsiz)(PerlIO *f);
157 STDCHAR * (*Get_ptr)(PerlIO *f);
158 SSize_t (*Get_cnt)(PerlIO *f);
159 void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
160} PerlIO_funcs;
161
6f9d8c32
NIS
162
163struct _PerlIO
164{
9e353e3b
NIS
165 PerlIOl * next; /* Lower layer */
166 PerlIO_funcs * tab; /* Functions for this layer */
167 IV flags; /* Various flags for state */
6f9d8c32
NIS
168};
169
9e353e3b
NIS
170/*--------------------------------------------------------------------------------------*/
171
172/* Flag values */
173#define PERLIO_F_EOF 0x0010000
174#define PERLIO_F_CANWRITE 0x0020000
175#define PERLIO_F_CANREAD 0x0040000
176#define PERLIO_F_ERROR 0x0080000
177#define PERLIO_F_TRUNCATE 0x0100000
178#define PERLIO_F_APPEND 0x0200000
179#define PERLIO_F_BINARY 0x0400000
180#define PERLIO_F_TEMP 0x0800000
181#define PERLIO_F_LINEBUF 0x0100000
182#define PERLIO_F_WRBUF 0x2000000
183#define PERLIO_F_RDBUF 0x4000000
184#define PERLIO_F_OPEN 0x8000000
185
186#define PerlIOBase(f) (*(f))
187#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
188#define PerlIONext(f) (&(PerlIOBase(f)->next))
189
190/*--------------------------------------------------------------------------------------*/
191/* Inner level routines */
192
b1ef6e3b 193/* Table of pointers to the PerlIO structs (malloc'ed) */
6f9d8c32 194PerlIO **_perlio = NULL;
b1ef6e3b 195int _perlio_size = 0;
6f9d8c32 196
760ac839 197PerlIO *
6f9d8c32
NIS
198PerlIO_allocate(void)
199{
b1ef6e3b 200 /* Find a free slot in the table, growing table as necessary */
6f9d8c32
NIS
201 PerlIO *f;
202 int i = 0;
203 while (1)
204 {
205 PerlIO **table = _perlio;
206 while (i < _perlio_size)
207 {
208 f = table[i];
6f9d8c32
NIS
209 if (!f)
210 {
211 Newz('F',f,1,PerlIO);
212 if (!f)
213 return NULL;
214 table[i] = f;
215 }
9e353e3b 216 if (!*f)
6f9d8c32 217 {
9e353e3b 218 PerlIO_debug(__FUNCTION__ " f=%p\n",f);
6f9d8c32
NIS
219 return f;
220 }
221 i++;
222 }
223 Newz('I',table,_perlio_size+16,PerlIO *);
224 if (!table)
225 return NULL;
226 Copy(_perlio,table,_perlio_size,PerlIO *);
227 if (_perlio)
228 Safefree(_perlio);
229 _perlio = table;
230 _perlio_size += 16;
231 }
232}
233
9e353e3b
NIS
234void
235PerlIO_pop(PerlIO *f)
760ac839 236{
9e353e3b
NIS
237 PerlIOl *l = *f;
238 if (l)
6f9d8c32 239 {
9e353e3b
NIS
240 *f = l->next;
241 Safefree(l);
6f9d8c32 242 }
6f9d8c32
NIS
243}
244
245#undef PerlIO_close
246int
247PerlIO_close(PerlIO *f)
248{
9e353e3b
NIS
249 int code = (*PerlIOBase(f)->tab->Close)(f);
250 while (*f)
6f9d8c32 251 {
9e353e3b 252 PerlIO_pop(f);
6f9d8c32
NIS
253 }
254 return code;
255}
256
257void
258PerlIO_cleanup(void)
259{
b1ef6e3b 260 /* Close all the files */
6f9d8c32 261 int i;
6f9d8c32
NIS
262 for (i=_perlio_size-1; i >= 0; i--)
263 {
264 PerlIO *f = _perlio[i];
265 if (f)
266 {
9e353e3b
NIS
267 if (*f)
268 PerlIO_close(f);
6f9d8c32
NIS
269 Safefree(f);
270 }
271 }
272 if (_perlio)
273 Safefree(_perlio);
274 _perlio = NULL;
275 _perlio_size = 0;
276}
277
9e353e3b
NIS
278
279
280/*--------------------------------------------------------------------------------------*/
281/* Given the abstraction above the public API functions */
282
283#undef PerlIO_fileno
284int
285PerlIO_fileno(PerlIO *f)
286{
287 return (*PerlIOBase(f)->tab->Fileno)(f);
288}
289
290extern PerlIO_funcs PerlIO_unix;
291extern PerlIO_funcs PerlIO_stdio;
292extern PerlIO_funcs PerlIO_perlio;
293
294#define PerlIO_default_top() &PerlIO_stdio
295#define PerlIO_default_btm() &PerlIO_unix
296
297#undef PerlIO_fdopen
298PerlIO *
299PerlIO_fdopen(int fd, const char *mode)
300{
301 PerlIO_funcs *tab = PerlIO_default_top();
302 return (*tab->Fdopen)(fd,mode);
303}
304
6f9d8c32
NIS
305#undef PerlIO_open
306PerlIO *
307PerlIO_open(const char *path, const char *mode)
308{
9e353e3b
NIS
309 PerlIO_funcs *tab = PerlIO_default_top();
310 return (*tab->Open)(path,mode);
6f9d8c32
NIS
311}
312
9e353e3b
NIS
313IV
314PerlIOBase_init(PerlIO *f, const char *mode)
6f9d8c32 315{
9e353e3b
NIS
316 PerlIOl *l = PerlIOBase(f);
317 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
318 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
319 if (mode)
6f9d8c32 320 {
9e353e3b
NIS
321 switch (*mode++)
322 {
323 case 'r':
324 l->flags = PERLIO_F_CANREAD;
325 break;
326 case 'a':
327 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
328 break;
329 case 'w':
330 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
331 break;
332 default:
333 errno = EINVAL;
334 return -1;
335 }
336 while (*mode)
6f9d8c32 337 {
9e353e3b 338 switch (*mode++)
6f9d8c32 339 {
9e353e3b
NIS
340 case '+':
341 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
342 break;
343 case 'b':
344 l->flags |= PERLIO_F_BINARY;
345 break;
346 default:
347 errno = EINVAL;
348 return -1;
6f9d8c32
NIS
349 }
350 }
9e353e3b
NIS
351 }
352 else
353 {
354 if (l->next)
6f9d8c32 355 {
9e353e3b
NIS
356 l->flags |= l->next->flags &
357 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
358 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
6f9d8c32
NIS
359 }
360 }
9e353e3b 361 return 0;
6f9d8c32
NIS
362}
363
9e353e3b
NIS
364#undef PerlIO_reopen
365PerlIO *
366PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
6f9d8c32 367{
9e353e3b 368 if (f)
6f9d8c32 369 {
9e353e3b
NIS
370 PerlIO_flush(f);
371 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
372 {
373 PerlIOBase_init(f,mode);
374 return f;
375 }
376 return NULL;
6f9d8c32 377 }
9e353e3b
NIS
378 else
379 return PerlIO_open(path,mode);
760ac839
LW
380}
381
9e353e3b
NIS
382#undef PerlIO_read
383SSize_t
384PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 385{
9e353e3b 386 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
760ac839
LW
387}
388
9e353e3b 389#undef PerlIO_ungetc
6f9d8c32 390int
9e353e3b 391PerlIO_ungetc(PerlIO *f, int ch)
760ac839 392{
9e353e3b
NIS
393 STDCHAR buf = ch;
394 if ((*PerlIOBase(f)->tab->Unread)(f,&buf,1) == 1)
395 return ch;
396 return -1;
760ac839
LW
397}
398
9e353e3b
NIS
399#undef PerlIO_write
400SSize_t
401PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 402{
9e353e3b 403 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
760ac839
LW
404}
405
9e353e3b 406#undef PerlIO_seek
6f9d8c32 407int
9e353e3b 408PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 409{
9e353e3b 410 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
760ac839
LW
411}
412
9e353e3b
NIS
413#undef PerlIO_tell
414Off_t
415PerlIO_tell(PerlIO *f)
760ac839 416{
9e353e3b 417 return (*PerlIOBase(f)->tab->Tell)(f);
760ac839
LW
418}
419
9e353e3b 420#undef PerlIO_flush
6f9d8c32 421int
9e353e3b 422PerlIO_flush(PerlIO *f)
760ac839 423{
6f9d8c32
NIS
424 if (f)
425 {
9e353e3b 426 return (*PerlIOBase(f)->tab->Flush)(f);
6f9d8c32 427 }
9e353e3b 428 else
6f9d8c32 429 {
9e353e3b
NIS
430 int code = 0;
431 int i;
432 for (i=_perlio_size-1; i >= 0; i--)
6f9d8c32 433 {
9e353e3b
NIS
434 if ((f = _perlio[i]))
435 {
436 if (*f && PerlIO_flush(f) != 0)
437 code = -1;
438 }
6f9d8c32 439 }
9e353e3b 440 return code;
6f9d8c32 441 }
760ac839
LW
442}
443
9e353e3b 444#undef PerlIO_eof
6f9d8c32 445int
9e353e3b 446PerlIO_eof(PerlIO *f)
760ac839 447{
9e353e3b
NIS
448 return (*PerlIOBase(f)->tab->Eof)(f);
449}
450
451#undef PerlIO_error
452int
453PerlIO_error(PerlIO *f)
454{
455 return (*PerlIOBase(f)->tab->Error)(f);
456}
457
458#undef PerlIO_clearerr
459void
460PerlIO_clearerr(PerlIO *f)
461{
462 (*PerlIOBase(f)->tab->Clearerr)(f);
463}
464
465#undef PerlIO_setlinebuf
466void
467PerlIO_setlinebuf(PerlIO *f)
468{
469 (*PerlIOBase(f)->tab->Setlinebuf)(f);
470}
471
472#undef PerlIO_has_base
473int
474PerlIO_has_base(PerlIO *f)
475{
476 if (f && *f)
6f9d8c32 477 {
9e353e3b 478 return (PerlIOBase(f)->tab->Get_base != NULL);
6f9d8c32 479 }
9e353e3b 480 return 0;
760ac839
LW
481}
482
9e353e3b
NIS
483#undef PerlIO_fast_gets
484int
485PerlIO_fast_gets(PerlIO *f)
760ac839 486{
9e353e3b 487 if (f && *f)
6f9d8c32 488 {
c7fc522f
NIS
489 PerlIOl *l = PerlIOBase(f);
490 return (l->tab->Set_ptrcnt != NULL);
6f9d8c32 491 }
9e353e3b
NIS
492 return 0;
493}
494
495#undef PerlIO_has_cntptr
496int
497PerlIO_has_cntptr(PerlIO *f)
498{
499 if (f && *f)
500 {
501 PerlIO_funcs *tab = PerlIOBase(f)->tab;
502 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
503 }
504 return 0;
505}
506
507#undef PerlIO_canset_cnt
508int
509PerlIO_canset_cnt(PerlIO *f)
510{
511 if (f && *f)
512 {
c7fc522f
NIS
513 PerlIOl *l = PerlIOBase(f);
514 return (l->tab->Set_ptrcnt != NULL);
9e353e3b 515 }
c7fc522f 516 return 0;
760ac839
LW
517}
518
519#undef PerlIO_get_base
888911fc 520STDCHAR *
a20bf0c3 521PerlIO_get_base(PerlIO *f)
760ac839 522{
9e353e3b
NIS
523 return (*PerlIOBase(f)->tab->Get_base)(f);
524}
525
526#undef PerlIO_get_bufsiz
527int
528PerlIO_get_bufsiz(PerlIO *f)
529{
530 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
531}
532
533#undef PerlIO_get_ptr
534STDCHAR *
535PerlIO_get_ptr(PerlIO *f)
536{
537 return (*PerlIOBase(f)->tab->Get_ptr)(f);
538}
539
540#undef PerlIO_get_cnt
541SSize_t
542PerlIO_get_cnt(PerlIO *f)
543{
544 return (*PerlIOBase(f)->tab->Get_cnt)(f);
545}
546
547#undef PerlIO_set_cnt
548void
549PerlIO_set_cnt(PerlIO *f,SSize_t cnt)
550{
551 return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
552}
553
554#undef PerlIO_set_ptrcnt
555void
556PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
557{
558 return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
559}
560
561/*--------------------------------------------------------------------------------------*/
562/* "Methods" of the "base class" */
563
564IV
565PerlIOBase_fileno(PerlIO *f)
566{
567 return PerlIO_fileno(PerlIONext(f));
568}
569
570PerlIO *
571PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
572{
573 PerlIOl *l = NULL;
574 Newc('L',l,tab->size,char,PerlIOl);
575 if (l)
6f9d8c32 576 {
9e353e3b
NIS
577 Zero(l,tab->size,char);
578 l->next = *f;
579 l->tab = tab;
580 *f = l;
581 PerlIOBase_init(f,mode);
6f9d8c32 582 }
9e353e3b 583 return f;
760ac839
LW
584}
585
9e353e3b
NIS
586SSize_t
587PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
588{
589 Off_t old = PerlIO_tell(f);
590 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
591 {
592 Off_t new = PerlIO_tell(f);
593 return old - new;
594 }
595 return 0;
596}
597
598IV
599PerlIOBase_sync(PerlIO *f)
600{
601 return 0;
602}
603
604IV
605PerlIOBase_close(PerlIO *f)
606{
607 IV code = 0;
608 if (PerlIO_flush(f) != 0)
609 code = -1;
610 if (PerlIO_close(PerlIONext(f)) != 0)
611 code = -1;
612 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
613 return code;
614}
615
616IV
617PerlIOBase_eof(PerlIO *f)
618{
619 if (f && *f)
620 {
621 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
622 }
623 return 1;
624}
625
626IV
627PerlIOBase_error(PerlIO *f)
628{
629 if (f && *f)
630 {
631 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
632 }
633 return 1;
634}
635
636void
637PerlIOBase_clearerr(PerlIO *f)
638{
639 if (f && *f)
640 {
641 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
642 }
643}
644
645void
646PerlIOBase_setlinebuf(PerlIO *f)
647{
648
649}
650
651
652
653/*--------------------------------------------------------------------------------------*/
654/* Bottom-most level for UNIX-like case */
655
656typedef struct
657{
658 struct _PerlIO base; /* The generic part */
659 int fd; /* UNIX like file descriptor */
660 int oflags; /* open/fcntl flags */
661} PerlIOUnix;
662
6f9d8c32 663int
9e353e3b 664PerlIOUnix_oflags(const char *mode)
760ac839 665{
9e353e3b
NIS
666 int oflags = -1;
667 switch(*mode)
668 {
669 case 'r':
670 oflags = O_RDONLY;
671 if (*++mode == '+')
672 {
673 oflags = O_RDWR;
674 mode++;
675 }
676 break;
677
678 case 'w':
679 oflags = O_CREAT|O_TRUNC;
680 if (*++mode == '+')
681 {
682 oflags |= O_RDWR;
683 mode++;
684 }
685 else
686 oflags |= O_WRONLY;
687 break;
688
689 case 'a':
690 oflags = O_CREAT|O_APPEND;
691 if (*++mode == '+')
692 {
693 oflags |= O_RDWR;
694 mode++;
695 }
696 else
697 oflags |= O_WRONLY;
698 break;
699 }
700 if (*mode || oflags == -1)
6f9d8c32 701 {
9e353e3b
NIS
702 errno = EINVAL;
703 oflags = -1;
6f9d8c32 704 }
9e353e3b
NIS
705 return oflags;
706}
707
708IV
709PerlIOUnix_fileno(PerlIO *f)
710{
711 return PerlIOSelf(f,PerlIOUnix)->fd;
712}
713
714PerlIO *
715PerlIOUnix_fdopen(int fd,const char *mode)
716{
717 PerlIO *f = NULL;
c7fc522f
NIS
718 if (*mode == 'I')
719 mode++;
9e353e3b
NIS
720 if (fd >= 0)
721 {
722 int oflags = PerlIOUnix_oflags(mode);
723 if (oflags != -1)
724 {
725 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
726 s->fd = fd;
727 s->oflags = oflags;
728 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
729 }
730 }
731 return f;
732}
733
734PerlIO *
735PerlIOUnix_open(const char *path,const char *mode)
736{
737 PerlIO *f = NULL;
738 int oflags = PerlIOUnix_oflags(mode);
739 if (oflags != -1)
740 {
741 int fd = open(path,oflags,0666);
742 if (fd >= 0)
743 {
744 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
745 s->fd = fd;
746 s->oflags = oflags;
747 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
748 }
749 }
750 return f;
760ac839
LW
751}
752
760ac839 753int
9e353e3b 754PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
760ac839 755{
9e353e3b
NIS
756 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
757 int oflags = PerlIOUnix_oflags(mode);
758 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
759 (*PerlIOBase(f)->tab->Close)(f);
760 if (oflags != -1)
761 {
762 int fd = open(path,oflags,0666);
763 if (fd >= 0)
764 {
765 s->fd = fd;
766 s->oflags = oflags;
767 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
768 return 0;
769 }
770 }
771 return -1;
772}
773
774SSize_t
775PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
776{
777 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
778 while (1)
779 {
780 SSize_t len = read(fd,vbuf,count);
781 if (len >= 0 || errno != EINTR)
782 return len;
783 }
784}
785
786SSize_t
787PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
788{
789 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
790 while (1)
791 {
792 SSize_t len = write(fd,vbuf,count);
793 if (len >= 0 || errno != EINTR)
794 return len;
795 }
796}
797
798IV
799PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
800{
801 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
802 return (new == (Off_t) -1) ? -1 : 0;
803}
804
805Off_t
806PerlIOUnix_tell(PerlIO *f)
807{
808 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
809}
810
811IV
812PerlIOUnix_close(PerlIO *f)
813{
814 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
815 int code = 0;
816 while (close(fd) != 0)
817 {
818 if (errno != EINTR)
819 {
820 code = -1;
821 break;
822 }
823 }
824 if (code == 0)
825 {
826 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
827 }
828 return code;
829}
830
831PerlIO_funcs PerlIO_unix = {
832 "unix",
833 sizeof(PerlIOUnix),
834 0,
835 PerlIOUnix_fileno,
836 PerlIOUnix_fdopen,
837 PerlIOUnix_open,
838 PerlIOUnix_reopen,
839 PerlIOUnix_read,
840 PerlIOBase_unread,
841 PerlIOUnix_write,
842 PerlIOUnix_seek,
843 PerlIOUnix_tell,
844 PerlIOUnix_close,
845 PerlIOBase_sync,
846 PerlIOBase_eof,
847 PerlIOBase_error,
848 PerlIOBase_clearerr,
849 PerlIOBase_setlinebuf,
850 NULL, /* get_base */
851 NULL, /* get_bufsiz */
852 NULL, /* get_ptr */
853 NULL, /* get_cnt */
854 NULL, /* set_ptrcnt */
855};
856
857/*--------------------------------------------------------------------------------------*/
858/* stdio as a layer */
859
860typedef struct
861{
862 struct _PerlIO base;
863 FILE * stdio; /* The stream */
864} PerlIOStdio;
865
866IV
867PerlIOStdio_fileno(PerlIO *f)
868{
869 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
870}
871
872
873PerlIO *
874PerlIOStdio_fdopen(int fd,const char *mode)
875{
876 PerlIO *f = NULL;
c7fc522f
NIS
877 int init = 0;
878 if (*mode == 'I')
879 {
880 init = 1;
881 mode++;
882 }
9e353e3b
NIS
883 if (fd >= 0)
884 {
c7fc522f
NIS
885 FILE *stdio = NULL;
886 if (init)
887 {
888 switch(fd)
889 {
890 case 0:
891 stdio = stdin;
892 break;
893 case 1:
894 stdio = stdout;
895 break;
896 case 2:
897 stdio = stderr;
898 break;
899 }
900 }
901 else
902 stdio = fdopen(fd,mode);
9e353e3b
NIS
903 if (stdio)
904 {
905 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
906 s->stdio = stdio;
907 }
908 }
909 return f;
910}
911
912#undef PerlIO_importFILE
913PerlIO *
914PerlIO_importFILE(FILE *stdio, int fl)
915{
916 PerlIO *f = NULL;
917 if (stdio)
918 {
919 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
920 s->stdio = stdio;
921 }
922 return f;
923}
924
925PerlIO *
926PerlIOStdio_open(const char *path,const char *mode)
927{
928 PerlIO *f = NULL;
929 FILE *stdio = fopen(path,mode);
930 if (stdio)
931 {
932 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
933 s->stdio = stdio;
934 }
935 return f;
760ac839
LW
936}
937
6f9d8c32 938int
9e353e3b
NIS
939PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
940{
941 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
942 FILE *stdio = freopen(path,mode,s->stdio);
943 if (!s->stdio)
944 return -1;
945 s->stdio = stdio;
946 return 0;
947}
948
949SSize_t
950PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
951{
952 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 953 SSize_t got = 0;
9e353e3b
NIS
954 if (count == 1)
955 {
956 STDCHAR *buf = (STDCHAR *) vbuf;
957 /* Perl is expecting PerlIO_getc() to fill the buffer
958 * Linux's stdio does not do that for fread()
959 */
960 int ch = fgetc(s);
961 if (ch != EOF)
962 {
963 *buf = ch;
c7fc522f 964 got = 1;
9e353e3b 965 }
9e353e3b 966 }
c7fc522f
NIS
967 else
968 got = fread(vbuf,1,count,s);
969 return got;
9e353e3b
NIS
970}
971
972SSize_t
973PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
974{
975 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
976 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
977 SSize_t unread = 0;
978 while (count > 0)
979 {
980 int ch = *buf-- & 0xff;
981 if (ungetc(ch,s) != ch)
982 break;
983 unread++;
984 count--;
985 }
986 return unread;
987}
988
989SSize_t
990PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
991{
992 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
993}
994
995IV
996PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
997{
c7fc522f
NIS
998 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
999 return fseek(stdio,offset,whence);
9e353e3b
NIS
1000}
1001
1002Off_t
1003PerlIOStdio_tell(PerlIO *f)
1004{
c7fc522f
NIS
1005 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1006 return ftell(stdio);
9e353e3b
NIS
1007}
1008
1009IV
1010PerlIOStdio_close(PerlIO *f)
1011{
1012 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1013}
1014
1015IV
1016PerlIOStdio_flush(PerlIO *f)
1017{
1018 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1019 return fflush(stdio);
1020}
1021
1022IV
1023PerlIOStdio_eof(PerlIO *f)
1024{
1025 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1026}
1027
1028IV
1029PerlIOStdio_error(PerlIO *f)
1030{
1031 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1032}
1033
1034void
1035PerlIOStdio_clearerr(PerlIO *f)
1036{
1037 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1038}
1039
1040void
1041PerlIOStdio_setlinebuf(PerlIO *f)
1042{
1043#ifdef HAS_SETLINEBUF
1044 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1045#else
1046 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1047#endif
1048}
1049
1050#ifdef FILE_base
1051STDCHAR *
1052PerlIOStdio_get_base(PerlIO *f)
1053{
1054 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1055 return FILE_base(stdio);
1056}
1057
1058Size_t
1059PerlIOStdio_get_bufsiz(PerlIO *f)
1060{
1061 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1062 return FILE_bufsiz(stdio);
1063}
1064#endif
1065
1066#ifdef USE_STDIO_PTR
1067STDCHAR *
1068PerlIOStdio_get_ptr(PerlIO *f)
1069{
1070 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1071 return FILE_ptr(stdio);
1072}
1073
1074SSize_t
1075PerlIOStdio_get_cnt(PerlIO *f)
1076{
1077 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1078 return FILE_cnt(stdio);
1079}
1080
1081void
1082PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1083{
1084 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1085 if (ptr != NULL)
1086 {
1087#ifdef STDIO_PTR_LVALUE
1088 FILE_ptr(stdio) = ptr;
1089#ifdef STDIO_PTR_LVAL_SETS_CNT
1090 if (FILE_cnt(stdio) != (cnt))
1091 {
1092 dTHX;
1093 assert(FILE_cnt(stdio) == (cnt));
1094 }
1095#endif
1096#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1097 /* Setting ptr _does_ change cnt - we are done */
1098 return;
1099#endif
1100#else /* STDIO_PTR_LVALUE */
1101 abort();
1102#endif /* STDIO_PTR_LVALUE */
1103 }
1104/* Now (or only) set cnt */
1105#ifdef STDIO_CNT_LVALUE
1106 FILE_cnt(stdio) = cnt;
1107#else /* STDIO_CNT_LVALUE */
1108#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1109 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1110#else /* STDIO_PTR_LVAL_SETS_CNT */
1111 abort();
1112#endif /* STDIO_PTR_LVAL_SETS_CNT */
1113#endif /* STDIO_CNT_LVALUE */
1114}
1115
1116#endif
1117
1118PerlIO_funcs PerlIO_stdio = {
1119 "stdio",
1120 sizeof(PerlIOStdio),
1121 0,
1122 PerlIOStdio_fileno,
1123 PerlIOStdio_fdopen,
1124 PerlIOStdio_open,
1125 PerlIOStdio_reopen,
1126 PerlIOStdio_read,
1127 PerlIOStdio_unread,
1128 PerlIOStdio_write,
1129 PerlIOStdio_seek,
1130 PerlIOStdio_tell,
1131 PerlIOStdio_close,
1132 PerlIOStdio_flush,
1133 PerlIOStdio_eof,
1134 PerlIOStdio_error,
1135 PerlIOStdio_clearerr,
1136 PerlIOStdio_setlinebuf,
1137#ifdef FILE_base
1138 PerlIOStdio_get_base,
1139 PerlIOStdio_get_bufsiz,
1140#else
1141 NULL,
1142 NULL,
1143#endif
1144#ifdef USE_STDIO_PTR
1145 PerlIOStdio_get_ptr,
1146 PerlIOStdio_get_cnt,
1147#if (defined(STDIO_PTR_LVALUE) && \
1148 (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1149 PerlIOStdio_set_ptrcnt
1150#else /* STDIO_PTR_LVALUE */
1151 NULL
1152#endif /* STDIO_PTR_LVALUE */
1153#else /* USE_STDIO_PTR */
1154 NULL,
1155 NULL,
1156 NULL
1157#endif /* USE_STDIO_PTR */
1158};
1159
1160#undef PerlIO_exportFILE
1161FILE *
1162PerlIO_exportFILE(PerlIO *f, int fl)
1163{
1164 PerlIO_flush(f);
1165 /* Should really push stdio discipline when we have them */
1166 return fdopen(PerlIO_fileno(f),"r+");
1167}
1168
1169#undef PerlIO_findFILE
1170FILE *
1171PerlIO_findFILE(PerlIO *f)
1172{
1173 return PerlIO_exportFILE(f,0);
1174}
1175
1176#undef PerlIO_releaseFILE
1177void
1178PerlIO_releaseFILE(PerlIO *p, FILE *f)
1179{
1180}
1181
1182/*--------------------------------------------------------------------------------------*/
1183/* perlio buffer layer */
1184
1185typedef struct
760ac839 1186{
9e353e3b
NIS
1187 struct _PerlIO base;
1188 Off_t posn; /* Offset of buf into the file */
1189 STDCHAR * buf; /* Start of buffer */
1190 STDCHAR * end; /* End of valid part of buffer */
1191 STDCHAR * ptr; /* Current position in buffer */
1192 Size_t bufsiz; /* Size of buffer */
1193 IV oneword; /* Emergency buffer */
1194} PerlIOBuf;
1195
1196
1197PerlIO *
1198PerlIOBuf_fdopen(int fd, const char *mode)
1199{
1200 PerlIO_funcs *tab = PerlIO_default_btm();
c7fc522f
NIS
1201 int init = 0;
1202 PerlIO *f;
1203 if (*mode == 'I')
1204 {
1205 init = 1;
1206 mode++;
1207 }
1208 f = (*tab->Fdopen)(fd,mode);
6f9d8c32
NIS
1209 if (f)
1210 {
c7fc522f
NIS
1211 /* Initial stderr is unbuffered */
1212 if (!init || fd != 2)
1213 {
1214 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1215 b->posn = PerlIO_tell(PerlIONext(f));
1216 }
6f9d8c32 1217 }
9e353e3b 1218 return f;
760ac839
LW
1219}
1220
9e353e3b
NIS
1221PerlIO *
1222PerlIOBuf_open(const char *path, const char *mode)
8c86a920 1223{
9e353e3b
NIS
1224 PerlIO_funcs *tab = PerlIO_default_btm();
1225 PerlIO *f = (*tab->Open)(path,mode);
1226 if (f)
1227 {
1228 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1229 b->posn = 0;
1230 }
1231 return f;
1232}
1233
1234int
1235PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1236{
1237 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1238}
1239
1240void
1241PerlIOBuf_alloc_buf(PerlIOBuf *b)
1242{
1243 if (!b->bufsiz)
1244 b->bufsiz = 4096;
1245 New('B',b->buf,b->bufsiz,char);
1246 if (!b->buf)
1247 {
1248 b->buf = (STDCHAR *)&b->oneword;
1249 b->bufsiz = sizeof(b->oneword);
1250 }
1251 b->ptr = b->buf;
1252 b->end = b->ptr;
8c86a920
PP
1253}
1254
9e353e3b
NIS
1255/* This "flush" is akin to sfio's sync in that it handles files in either
1256 read or write state
1257*/
1258IV
1259PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1260{
9e353e3b
NIS
1261 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1262 int code = 0;
1263 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1264 {
1265 /* write() the buffer */
1266 STDCHAR *p = b->buf;
1267 int count;
1268 while (p < b->ptr)
1269 {
1270 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1271 if (count > 0)
1272 {
1273 p += count;
1274 }
1275 else if (count < 0)
1276 {
1277 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1278 code = -1;
1279 break;
1280 }
1281 }
1282 b->posn += (p - b->buf);
1283 }
1284 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1285 {
9e353e3b
NIS
1286 /* Note position change */
1287 b->posn += (b->ptr - b->buf);
1288 if (b->ptr < b->end)
1289 {
1290 /* We did not consume all of it */
1291 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1292 {
1293 b->posn = PerlIO_tell(PerlIONext(f));
1294 }
1295 }
6f9d8c32 1296 }
9e353e3b
NIS
1297 b->ptr = b->end = b->buf;
1298 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1299 if (PerlIO_flush(PerlIONext(f)) != 0)
1300 code = -1;
1301 return code;
6f9d8c32
NIS
1302}
1303
6f9d8c32 1304SSize_t
9e353e3b 1305PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1306{
9e353e3b 1307 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
6f9d8c32
NIS
1308 STDCHAR *buf = (STDCHAR *) vbuf;
1309 if (f)
1310 {
1311 Size_t got = 0;
9e353e3b
NIS
1312 if (!b->ptr)
1313 PerlIOBuf_alloc_buf(b);
1314 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1315 return 0;
6f9d8c32
NIS
1316 while (count > 0)
1317 {
9e353e3b 1318 SSize_t avail = (b->end - b->ptr);
6f9d8c32
NIS
1319 if ((SSize_t) count < avail)
1320 avail = count;
1321 if (avail > 0)
1322 {
9e353e3b 1323 Copy(b->ptr,buf,avail,char);
6f9d8c32 1324 got += avail;
9e353e3b 1325 b->ptr += avail;
6f9d8c32
NIS
1326 count -= avail;
1327 buf += avail;
1328 }
9e353e3b 1329 if (count && (b->ptr >= b->end))
6f9d8c32 1330 {
bb9950b7 1331 PerlIO_flush(f);
9e353e3b
NIS
1332 b->ptr = b->end = b->buf;
1333 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
6f9d8c32
NIS
1334 if (avail <= 0)
1335 {
1336 if (avail == 0)
9e353e3b 1337 PerlIOBase(f)->flags |= PERLIO_F_EOF;
6f9d8c32 1338 else
9e353e3b 1339 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
6f9d8c32
NIS
1340 break;
1341 }
9e353e3b
NIS
1342 b->end = b->buf+avail;
1343 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
6f9d8c32
NIS
1344 }
1345 }
1346 return got;
1347 }
1348 return 0;
1349}
1350
9e353e3b
NIS
1351SSize_t
1352PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1353{
9e353e3b
NIS
1354 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1355 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1356 SSize_t unread = 0;
1357 SSize_t avail;
1358 if (!b->buf)
1359 PerlIOBuf_alloc_buf(b);
1360 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1361 PerlIO_flush(f);
1362 if (b->buf)
1363 {
1364 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1365 {
1366 avail = (b->ptr - b->buf);
1367 if (avail > (SSize_t) count)
1368 avail = count;
1369 b->ptr -= avail;
1370 }
1371 else
1372 {
1373 avail = b->bufsiz;
1374 if (avail > (SSize_t) count)
1375 avail = count;
1376 b->end = b->ptr + avail;
1377 }
1378 if (avail > 0)
1379 {
1380 buf -= avail;
1381 if (buf != b->ptr)
1382 {
1383 Copy(buf,b->ptr,avail,char);
1384 }
1385 count -= avail;
1386 unread += avail;
1387 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1388 }
1389 }
1390 return unread;
760ac839
LW
1391}
1392
9e353e3b
NIS
1393SSize_t
1394PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1395{
9e353e3b
NIS
1396 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1397 const STDCHAR *buf = (const STDCHAR *) vbuf;
1398 Size_t written = 0;
1399 if (!b->buf)
1400 PerlIOBuf_alloc_buf(b);
1401 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1402 return 0;
1403 while (count > 0)
1404 {
1405 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1406 if ((SSize_t) count < avail)
1407 avail = count;
1408 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1409 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1410 {
1411 while (avail > 0)
1412 {
1413 int ch = *buf++;
1414 *(b->ptr)++ = ch;
1415 count--;
1416 avail--;
1417 written++;
1418 if (ch == '\n')
1419 {
1420 PerlIO_flush(f);
1421 break;
1422 }
1423 }
1424 }
1425 else
1426 {
1427 if (avail)
1428 {
1429 Copy(buf,b->ptr,avail,char);
1430 count -= avail;
1431 buf += avail;
1432 written += avail;
1433 b->ptr += avail;
1434 }
1435 }
1436 if (b->ptr >= (b->buf + b->bufsiz))
1437 PerlIO_flush(f);
1438 }
1439 return written;
1440}
1441
1442IV
1443PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1444{
1445 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1446 int code;
1447 code = PerlIO_flush(f);
1448 if (code == 0)
1449 {
1450 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1451 code = PerlIO_seek(PerlIONext(f),offset,whence);
1452 if (code == 0)
1453 {
1454 b->posn = PerlIO_tell(PerlIONext(f));
1455 }
1456 }
1457 return code;
1458}
1459
1460Off_t
1461PerlIOBuf_tell(PerlIO *f)
1462{
1463 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1464 Off_t posn = b->posn;
1465 if (b->buf)
1466 posn += (b->ptr - b->buf);
1467 return posn;
1468}
1469
1470IV
1471PerlIOBuf_close(PerlIO *f)
1472{
1473 IV code = PerlIOBase_close(f);
1474 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1475 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 1476 {
9e353e3b 1477 Safefree(b->buf);
6f9d8c32 1478 }
9e353e3b
NIS
1479 b->buf = NULL;
1480 b->ptr = b->end = b->buf;
1481 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1482 return code;
760ac839
LW
1483}
1484
760ac839 1485void
9e353e3b 1486PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 1487{
6f9d8c32
NIS
1488 if (f)
1489 {
9e353e3b 1490 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 1491 }
760ac839
LW
1492}
1493
760ac839 1494void
9e353e3b 1495PerlIOBuf_set_cnt(PerlIO *f, int cnt)
760ac839 1496{
9e353e3b
NIS
1497 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1498 dTHX;
1499 if (!b->buf)
1500 PerlIOBuf_alloc_buf(b);
1501 b->ptr = b->end - cnt;
1502 assert(b->ptr >= b->buf);
1503}
1504
1505STDCHAR *
1506PerlIOBuf_get_ptr(PerlIO *f)
1507{
1508 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1509 if (!b->buf)
1510 PerlIOBuf_alloc_buf(b);
1511 return b->ptr;
1512}
1513
1514int
1515PerlIOBuf_get_cnt(PerlIO *f)
1516{
1517 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1518 if (!b->buf)
1519 PerlIOBuf_alloc_buf(b);
1520 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1521 return (b->end - b->ptr);
1522 return 0;
1523}
1524
1525STDCHAR *
1526PerlIOBuf_get_base(PerlIO *f)
1527{
1528 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1529 if (!b->buf)
1530 PerlIOBuf_alloc_buf(b);
1531 return b->buf;
1532}
1533
1534Size_t
1535PerlIOBuf_bufsiz(PerlIO *f)
1536{
1537 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1538 if (!b->buf)
1539 PerlIOBuf_alloc_buf(b);
1540 return (b->end - b->buf);
1541}
1542
1543void
1544PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1545{
1546 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1547 if (!b->buf)
1548 PerlIOBuf_alloc_buf(b);
1549 b->ptr = ptr;
1550 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 1551 {
9e353e3b
NIS
1552 dTHX;
1553 assert(PerlIO_get_cnt(f) == cnt);
1554 assert(b->ptr >= b->buf);
6f9d8c32 1555 }
9e353e3b 1556 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
1557}
1558
9e353e3b
NIS
1559PerlIO_funcs PerlIO_perlio = {
1560 "perlio",
1561 sizeof(PerlIOBuf),
1562 0,
1563 PerlIOBase_fileno,
1564 PerlIOBuf_fdopen,
1565 PerlIOBuf_open,
1566 PerlIOBase_reopen,
1567 PerlIOBuf_read,
1568 PerlIOBuf_unread,
1569 PerlIOBuf_write,
1570 PerlIOBuf_seek,
1571 PerlIOBuf_tell,
1572 PerlIOBuf_close,
1573 PerlIOBuf_flush,
1574 PerlIOBase_eof,
1575 PerlIOBase_error,
1576 PerlIOBase_clearerr,
1577 PerlIOBuf_setlinebuf,
1578 PerlIOBuf_get_base,
1579 PerlIOBuf_bufsiz,
1580 PerlIOBuf_get_ptr,
1581 PerlIOBuf_get_cnt,
1582 PerlIOBuf_set_ptrcnt,
1583};
1584
1585void
1586PerlIO_init(void)
760ac839 1587{
9e353e3b 1588 if (!_perlio)
6f9d8c32 1589 {
9e353e3b 1590 atexit(&PerlIO_cleanup);
c7fc522f
NIS
1591 PerlIO_fdopen(0,"Ir");
1592 PerlIO_fdopen(1,"Iw");
1593 PerlIO_fdopen(2,"Iw");
6f9d8c32 1594 }
760ac839
LW
1595}
1596
9e353e3b
NIS
1597#undef PerlIO_stdin
1598PerlIO *
1599PerlIO_stdin(void)
1600{
1601 if (!_perlio)
1602 PerlIO_init();
1603 return _perlio[0];
1604}
1605
1606#undef PerlIO_stdout
1607PerlIO *
1608PerlIO_stdout(void)
1609{
1610 if (!_perlio)
1611 PerlIO_init();
1612 return _perlio[1];
1613}
1614
1615#undef PerlIO_stderr
1616PerlIO *
1617PerlIO_stderr(void)
1618{
1619 if (!_perlio)
1620 PerlIO_init();
1621 return _perlio[2];
1622}
1623
1624/*--------------------------------------------------------------------------------------*/
1625
1626#undef PerlIO_getname
1627char *
1628PerlIO_getname(PerlIO *f, char *buf)
1629{
1630 dTHX;
1631 Perl_croak(aTHX_ "Don't know how to get file name");
1632 return NULL;
1633}
1634
1635
1636/*--------------------------------------------------------------------------------------*/
1637/* Functions which can be called on any kind of PerlIO implemented
1638 in terms of above
1639*/
1640
1641#undef PerlIO_getc
6f9d8c32 1642int
9e353e3b 1643PerlIO_getc(PerlIO *f)
760ac839 1644{
9e353e3b
NIS
1645 STDCHAR buf;
1646 int count = PerlIO_read(f,&buf,1);
1647 if (count == 1)
1648 return (unsigned char) buf;
1649 return -1;
760ac839
LW
1650}
1651
9e353e3b
NIS
1652#undef PerlIO_putc
1653int
1654PerlIO_putc(PerlIO *f, int ch)
760ac839 1655{
9e353e3b
NIS
1656 STDCHAR buf = ch;
1657 return PerlIO_write(f,&buf,1);
760ac839
LW
1658}
1659
9e353e3b 1660#undef PerlIO_puts
760ac839 1661int
9e353e3b 1662PerlIO_puts(PerlIO *f, const char *s)
760ac839 1663{
9e353e3b
NIS
1664 STRLEN len = strlen(s);
1665 return PerlIO_write(f,s,len);
760ac839
LW
1666}
1667
1668#undef PerlIO_rewind
1669void
c78749f2 1670PerlIO_rewind(PerlIO *f)
760ac839 1671{
6f9d8c32 1672 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 1673 PerlIO_clearerr(f);
6f9d8c32
NIS
1674}
1675
1676#undef PerlIO_vprintf
1677int
1678PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1679{
1680 dTHX;
bb9950b7 1681 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
1682 char *s;
1683 STRLEN len;
1684 sv_vcatpvf(sv, fmt, &ap);
1685 s = SvPV(sv,len);
bb9950b7 1686 return PerlIO_write(f,s,len);
760ac839
LW
1687}
1688
1689#undef PerlIO_printf
6f9d8c32 1690int
760ac839 1691PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
1692{
1693 va_list ap;
1694 int result;
760ac839 1695 va_start(ap,fmt);
6f9d8c32 1696 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
1697 va_end(ap);
1698 return result;
1699}
1700
1701#undef PerlIO_stdoutf
6f9d8c32 1702int
760ac839 1703PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
1704{
1705 va_list ap;
1706 int result;
760ac839 1707 va_start(ap,fmt);
760ac839
LW
1708 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1709 va_end(ap);
1710 return result;
1711}
1712
1713#undef PerlIO_tmpfile
1714PerlIO *
c78749f2 1715PerlIO_tmpfile(void)
760ac839 1716{
6f9d8c32 1717 dTHX;
b1ef6e3b 1718 /* I have no idea how portable mkstemp() is ... */
6f9d8c32
NIS
1719 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1720 int fd = mkstemp(SvPVX(sv));
1721 PerlIO *f = NULL;
1722 if (fd >= 0)
1723 {
b1ef6e3b 1724 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
1725 if (f)
1726 {
9e353e3b 1727 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32
NIS
1728 }
1729 unlink(SvPVX(sv));
1730 SvREFCNT_dec(sv);
1731 }
1732 return f;
760ac839
LW
1733}
1734
6f9d8c32
NIS
1735#undef HAS_FSETPOS
1736#undef HAS_FGETPOS
1737
760ac839
LW
1738#endif /* USE_SFIO */
1739#endif /* PERLIO_IS_STDIO */
1740
9e353e3b
NIS
1741/*======================================================================================*/
1742/* Now some functions in terms of above which may be needed even if
1743 we are not in true PerlIO mode
1744 */
1745
760ac839
LW
1746#ifndef HAS_FSETPOS
1747#undef PerlIO_setpos
1748int
c78749f2 1749PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 1750{
6f9d8c32 1751 return PerlIO_seek(f,*pos,0);
760ac839 1752}
c411622e
PP
1753#else
1754#ifndef PERLIO_IS_STDIO
1755#undef PerlIO_setpos
1756int
c78749f2 1757PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 1758{
2d4389e4 1759#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
1760 return fsetpos64(f, pos);
1761#else
c411622e 1762 return fsetpos(f, pos);
d9b3e12d 1763#endif
c411622e
PP
1764}
1765#endif
760ac839
LW
1766#endif
1767
1768#ifndef HAS_FGETPOS
1769#undef PerlIO_getpos
1770int
c78749f2 1771PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
1772{
1773 *pos = PerlIO_tell(f);
1774 return 0;
1775}
c411622e
PP
1776#else
1777#ifndef PERLIO_IS_STDIO
1778#undef PerlIO_getpos
1779int
c78749f2 1780PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 1781{
2d4389e4 1782#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
1783 return fgetpos64(f, pos);
1784#else
c411622e 1785 return fgetpos(f, pos);
d9b3e12d 1786#endif
c411622e
PP
1787}
1788#endif
760ac839
LW
1789#endif
1790
1791#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1792
1793int
c78749f2 1794vprintf(char *pat, char *args)
662a7e3f
CS
1795{
1796 _doprnt(pat, args, stdout);
1797 return 0; /* wrong, but perl doesn't use the return value */
1798}
1799
1800int
c78749f2 1801vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
1802{
1803 _doprnt(pat, args, fd);
1804 return 0; /* wrong, but perl doesn't use the return value */
1805}
1806
1807#endif
1808
1809#ifndef PerlIO_vsprintf
6f9d8c32 1810int
8ac85365 1811PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
1812{
1813 int val = vsprintf(s, fmt, ap);
1814 if (n >= 0)
1815 {
8c86a920 1816 if (strlen(s) >= (STRLEN)n)
760ac839 1817 {
bf49b057
GS
1818 dTHX;
1819 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1820 my_exit(1);
760ac839
LW
1821 }
1822 }
1823 return val;
1824}
1825#endif
1826
1827#ifndef PerlIO_sprintf
6f9d8c32 1828int
760ac839 1829PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
1830{
1831 va_list ap;
1832 int result;
760ac839 1833 va_start(ap,fmt);
760ac839
LW
1834 result = PerlIO_vsprintf(s, n, fmt, ap);
1835 va_end(ap);
1836 return result;
1837}
1838#endif
1839
c5be433b
GS
1840#endif /* !PERL_IMPLICIT_SYS */
1841