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