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