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