This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[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
375 Perl_croak(aTHX_ "Unknown layer %.*s",(e-s),s);
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
9e353e3b 516#undef PerlIO_ungetc
6f9d8c32 517int
9e353e3b 518PerlIO_ungetc(PerlIO *f, int ch)
760ac839 519{
9e353e3b
NIS
520 STDCHAR buf = ch;
521 if ((*PerlIOBase(f)->tab->Unread)(f,&buf,1) == 1)
522 return ch;
523 return -1;
760ac839
LW
524}
525
9e353e3b
NIS
526#undef PerlIO_write
527SSize_t
528PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 529{
9e353e3b 530 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
760ac839
LW
531}
532
9e353e3b 533#undef PerlIO_seek
6f9d8c32 534int
9e353e3b 535PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 536{
9e353e3b 537 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
760ac839
LW
538}
539
9e353e3b
NIS
540#undef PerlIO_tell
541Off_t
542PerlIO_tell(PerlIO *f)
760ac839 543{
9e353e3b 544 return (*PerlIOBase(f)->tab->Tell)(f);
760ac839
LW
545}
546
9e353e3b 547#undef PerlIO_flush
6f9d8c32 548int
9e353e3b 549PerlIO_flush(PerlIO *f)
760ac839 550{
6f9d8c32
NIS
551 if (f)
552 {
9e353e3b 553 return (*PerlIOBase(f)->tab->Flush)(f);
6f9d8c32 554 }
9e353e3b 555 else
6f9d8c32 556 {
05d1247b 557 PerlIO **table = &_perlio;
9e353e3b 558 int code = 0;
05d1247b 559 while ((f = *table))
6f9d8c32 560 {
05d1247b
NIS
561 int i;
562 table = (PerlIO **)(f++);
563 for (i=1; i < PERLIO_TABLE_SIZE; i++)
9e353e3b
NIS
564 {
565 if (*f && PerlIO_flush(f) != 0)
566 code = -1;
05d1247b 567 f++;
9e353e3b 568 }
6f9d8c32 569 }
9e353e3b 570 return code;
6f9d8c32 571 }
760ac839
LW
572}
573
f3862f8b
NIS
574#undef PerlIO_isutf8
575int
576PerlIO_isutf8(PerlIO *f)
577{
578 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
579}
580
9e353e3b 581#undef PerlIO_eof
6f9d8c32 582int
9e353e3b 583PerlIO_eof(PerlIO *f)
760ac839 584{
9e353e3b
NIS
585 return (*PerlIOBase(f)->tab->Eof)(f);
586}
587
588#undef PerlIO_error
589int
590PerlIO_error(PerlIO *f)
591{
592 return (*PerlIOBase(f)->tab->Error)(f);
593}
594
595#undef PerlIO_clearerr
596void
597PerlIO_clearerr(PerlIO *f)
598{
599 (*PerlIOBase(f)->tab->Clearerr)(f);
600}
601
602#undef PerlIO_setlinebuf
603void
604PerlIO_setlinebuf(PerlIO *f)
605{
606 (*PerlIOBase(f)->tab->Setlinebuf)(f);
607}
608
609#undef PerlIO_has_base
610int
611PerlIO_has_base(PerlIO *f)
612{
613 if (f && *f)
6f9d8c32 614 {
9e353e3b 615 return (PerlIOBase(f)->tab->Get_base != NULL);
6f9d8c32 616 }
9e353e3b 617 return 0;
760ac839
LW
618}
619
9e353e3b
NIS
620#undef PerlIO_fast_gets
621int
622PerlIO_fast_gets(PerlIO *f)
760ac839 623{
9e353e3b 624 if (f && *f)
6f9d8c32 625 {
c7fc522f
NIS
626 PerlIOl *l = PerlIOBase(f);
627 return (l->tab->Set_ptrcnt != NULL);
6f9d8c32 628 }
9e353e3b
NIS
629 return 0;
630}
631
632#undef PerlIO_has_cntptr
633int
634PerlIO_has_cntptr(PerlIO *f)
635{
636 if (f && *f)
637 {
638 PerlIO_funcs *tab = PerlIOBase(f)->tab;
639 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
640 }
641 return 0;
642}
643
644#undef PerlIO_canset_cnt
645int
646PerlIO_canset_cnt(PerlIO *f)
647{
648 if (f && *f)
649 {
c7fc522f
NIS
650 PerlIOl *l = PerlIOBase(f);
651 return (l->tab->Set_ptrcnt != NULL);
9e353e3b 652 }
c7fc522f 653 return 0;
760ac839
LW
654}
655
656#undef PerlIO_get_base
888911fc 657STDCHAR *
a20bf0c3 658PerlIO_get_base(PerlIO *f)
760ac839 659{
9e353e3b
NIS
660 return (*PerlIOBase(f)->tab->Get_base)(f);
661}
662
663#undef PerlIO_get_bufsiz
664int
665PerlIO_get_bufsiz(PerlIO *f)
666{
667 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
668}
669
670#undef PerlIO_get_ptr
671STDCHAR *
672PerlIO_get_ptr(PerlIO *f)
673{
674 return (*PerlIOBase(f)->tab->Get_ptr)(f);
675}
676
677#undef PerlIO_get_cnt
05d1247b 678int
9e353e3b
NIS
679PerlIO_get_cnt(PerlIO *f)
680{
681 return (*PerlIOBase(f)->tab->Get_cnt)(f);
682}
683
684#undef PerlIO_set_cnt
685void
05d1247b 686PerlIO_set_cnt(PerlIO *f,int cnt)
9e353e3b 687{
f3862f8b 688 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
9e353e3b
NIS
689}
690
691#undef PerlIO_set_ptrcnt
692void
05d1247b 693PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
9e353e3b 694{
f3862f8b 695 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
9e353e3b
NIS
696}
697
698/*--------------------------------------------------------------------------------------*/
699/* "Methods" of the "base class" */
700
701IV
702PerlIOBase_fileno(PerlIO *f)
703{
704 return PerlIO_fileno(PerlIONext(f));
705}
706
707PerlIO *
708PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
709{
710 PerlIOl *l = NULL;
711 Newc('L',l,tab->size,char,PerlIOl);
712 if (l)
6f9d8c32 713 {
9e353e3b
NIS
714 Zero(l,tab->size,char);
715 l->next = *f;
716 l->tab = tab;
717 *f = l;
718 PerlIOBase_init(f,mode);
6f9d8c32 719 }
9e353e3b 720 return f;
760ac839
LW
721}
722
9e353e3b
NIS
723SSize_t
724PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
725{
726 Off_t old = PerlIO_tell(f);
727 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
728 {
729 Off_t new = PerlIO_tell(f);
730 return old - new;
731 }
732 return 0;
733}
734
735IV
736PerlIOBase_sync(PerlIO *f)
737{
738 return 0;
739}
740
741IV
742PerlIOBase_close(PerlIO *f)
743{
744 IV code = 0;
745 if (PerlIO_flush(f) != 0)
746 code = -1;
747 if (PerlIO_close(PerlIONext(f)) != 0)
748 code = -1;
749 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
750 return code;
751}
752
753IV
754PerlIOBase_eof(PerlIO *f)
755{
756 if (f && *f)
757 {
758 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
759 }
760 return 1;
761}
762
763IV
764PerlIOBase_error(PerlIO *f)
765{
766 if (f && *f)
767 {
768 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
769 }
770 return 1;
771}
772
773void
774PerlIOBase_clearerr(PerlIO *f)
775{
776 if (f && *f)
777 {
778 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
779 }
780}
781
782void
783PerlIOBase_setlinebuf(PerlIO *f)
784{
785
786}
787
788
789
790/*--------------------------------------------------------------------------------------*/
791/* Bottom-most level for UNIX-like case */
792
793typedef struct
794{
795 struct _PerlIO base; /* The generic part */
796 int fd; /* UNIX like file descriptor */
797 int oflags; /* open/fcntl flags */
798} PerlIOUnix;
799
6f9d8c32 800int
9e353e3b 801PerlIOUnix_oflags(const char *mode)
760ac839 802{
9e353e3b
NIS
803 int oflags = -1;
804 switch(*mode)
805 {
806 case 'r':
807 oflags = O_RDONLY;
808 if (*++mode == '+')
809 {
810 oflags = O_RDWR;
811 mode++;
812 }
813 break;
814
815 case 'w':
816 oflags = O_CREAT|O_TRUNC;
817 if (*++mode == '+')
818 {
819 oflags |= O_RDWR;
820 mode++;
821 }
822 else
823 oflags |= O_WRONLY;
824 break;
825
826 case 'a':
827 oflags = O_CREAT|O_APPEND;
828 if (*++mode == '+')
829 {
830 oflags |= O_RDWR;
831 mode++;
832 }
833 else
834 oflags |= O_WRONLY;
835 break;
836 }
837 if (*mode || oflags == -1)
6f9d8c32 838 {
9e353e3b
NIS
839 errno = EINVAL;
840 oflags = -1;
6f9d8c32 841 }
9e353e3b
NIS
842 return oflags;
843}
844
845IV
846PerlIOUnix_fileno(PerlIO *f)
847{
848 return PerlIOSelf(f,PerlIOUnix)->fd;
849}
850
851PerlIO *
852PerlIOUnix_fdopen(int fd,const char *mode)
853{
854 PerlIO *f = NULL;
c7fc522f
NIS
855 if (*mode == 'I')
856 mode++;
9e353e3b
NIS
857 if (fd >= 0)
858 {
859 int oflags = PerlIOUnix_oflags(mode);
860 if (oflags != -1)
861 {
862 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
863 s->fd = fd;
864 s->oflags = oflags;
865 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
866 }
867 }
868 return f;
869}
870
871PerlIO *
872PerlIOUnix_open(const char *path,const char *mode)
873{
874 PerlIO *f = NULL;
875 int oflags = PerlIOUnix_oflags(mode);
876 if (oflags != -1)
877 {
878 int fd = open(path,oflags,0666);
879 if (fd >= 0)
880 {
881 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
882 s->fd = fd;
883 s->oflags = oflags;
884 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
885 }
886 }
887 return f;
760ac839
LW
888}
889
760ac839 890int
9e353e3b 891PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
760ac839 892{
9e353e3b
NIS
893 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
894 int oflags = PerlIOUnix_oflags(mode);
895 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
896 (*PerlIOBase(f)->tab->Close)(f);
897 if (oflags != -1)
898 {
899 int fd = open(path,oflags,0666);
900 if (fd >= 0)
901 {
902 s->fd = fd;
903 s->oflags = oflags;
904 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
905 return 0;
906 }
907 }
908 return -1;
909}
910
911SSize_t
912PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
913{
914 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
915 while (1)
916 {
917 SSize_t len = read(fd,vbuf,count);
918 if (len >= 0 || errno != EINTR)
919 return len;
920 }
921}
922
923SSize_t
924PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
925{
926 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
927 while (1)
928 {
929 SSize_t len = write(fd,vbuf,count);
930 if (len >= 0 || errno != EINTR)
931 return len;
932 }
933}
934
935IV
936PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
937{
938 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
939 return (new == (Off_t) -1) ? -1 : 0;
940}
941
942Off_t
943PerlIOUnix_tell(PerlIO *f)
944{
945 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
946}
947
948IV
949PerlIOUnix_close(PerlIO *f)
950{
951 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
952 int code = 0;
953 while (close(fd) != 0)
954 {
955 if (errno != EINTR)
956 {
957 code = -1;
958 break;
959 }
960 }
961 if (code == 0)
962 {
963 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
964 }
965 return code;
966}
967
968PerlIO_funcs PerlIO_unix = {
969 "unix",
970 sizeof(PerlIOUnix),
971 0,
972 PerlIOUnix_fileno,
973 PerlIOUnix_fdopen,
974 PerlIOUnix_open,
975 PerlIOUnix_reopen,
976 PerlIOUnix_read,
977 PerlIOBase_unread,
978 PerlIOUnix_write,
979 PerlIOUnix_seek,
980 PerlIOUnix_tell,
981 PerlIOUnix_close,
982 PerlIOBase_sync,
983 PerlIOBase_eof,
984 PerlIOBase_error,
985 PerlIOBase_clearerr,
986 PerlIOBase_setlinebuf,
987 NULL, /* get_base */
988 NULL, /* get_bufsiz */
989 NULL, /* get_ptr */
990 NULL, /* get_cnt */
991 NULL, /* set_ptrcnt */
992};
993
994/*--------------------------------------------------------------------------------------*/
995/* stdio as a layer */
996
997typedef struct
998{
999 struct _PerlIO base;
1000 FILE * stdio; /* The stream */
1001} PerlIOStdio;
1002
1003IV
1004PerlIOStdio_fileno(PerlIO *f)
1005{
1006 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1007}
1008
1009
1010PerlIO *
1011PerlIOStdio_fdopen(int fd,const char *mode)
1012{
1013 PerlIO *f = NULL;
c7fc522f
NIS
1014 int init = 0;
1015 if (*mode == 'I')
1016 {
1017 init = 1;
1018 mode++;
1019 }
9e353e3b
NIS
1020 if (fd >= 0)
1021 {
c7fc522f
NIS
1022 FILE *stdio = NULL;
1023 if (init)
1024 {
1025 switch(fd)
1026 {
1027 case 0:
1028 stdio = stdin;
1029 break;
1030 case 1:
1031 stdio = stdout;
1032 break;
1033 case 2:
1034 stdio = stderr;
1035 break;
1036 }
1037 }
1038 else
1039 stdio = fdopen(fd,mode);
9e353e3b
NIS
1040 if (stdio)
1041 {
1042 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1043 s->stdio = stdio;
1044 }
1045 }
1046 return f;
1047}
1048
1049#undef PerlIO_importFILE
1050PerlIO *
1051PerlIO_importFILE(FILE *stdio, int fl)
1052{
1053 PerlIO *f = NULL;
1054 if (stdio)
1055 {
1056 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1057 s->stdio = stdio;
1058 }
1059 return f;
1060}
1061
1062PerlIO *
1063PerlIOStdio_open(const char *path,const char *mode)
1064{
1065 PerlIO *f = NULL;
1066 FILE *stdio = fopen(path,mode);
1067 if (stdio)
1068 {
1069 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1070 s->stdio = stdio;
1071 }
1072 return f;
760ac839
LW
1073}
1074
6f9d8c32 1075int
9e353e3b
NIS
1076PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1077{
1078 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1079 FILE *stdio = freopen(path,mode,s->stdio);
1080 if (!s->stdio)
1081 return -1;
1082 s->stdio = stdio;
1083 return 0;
1084}
1085
1086SSize_t
1087PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1088{
1089 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 1090 SSize_t got = 0;
9e353e3b
NIS
1091 if (count == 1)
1092 {
1093 STDCHAR *buf = (STDCHAR *) vbuf;
1094 /* Perl is expecting PerlIO_getc() to fill the buffer
1095 * Linux's stdio does not do that for fread()
1096 */
1097 int ch = fgetc(s);
1098 if (ch != EOF)
1099 {
1100 *buf = ch;
c7fc522f 1101 got = 1;
9e353e3b 1102 }
9e353e3b 1103 }
c7fc522f
NIS
1104 else
1105 got = fread(vbuf,1,count,s);
1106 return got;
9e353e3b
NIS
1107}
1108
1109SSize_t
1110PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1111{
1112 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1113 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1114 SSize_t unread = 0;
1115 while (count > 0)
1116 {
1117 int ch = *buf-- & 0xff;
1118 if (ungetc(ch,s) != ch)
1119 break;
1120 unread++;
1121 count--;
1122 }
1123 return unread;
1124}
1125
1126SSize_t
1127PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1128{
1129 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1130}
1131
1132IV
1133PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1134{
c7fc522f
NIS
1135 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1136 return fseek(stdio,offset,whence);
9e353e3b
NIS
1137}
1138
1139Off_t
1140PerlIOStdio_tell(PerlIO *f)
1141{
c7fc522f
NIS
1142 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1143 return ftell(stdio);
9e353e3b
NIS
1144}
1145
1146IV
1147PerlIOStdio_close(PerlIO *f)
1148{
1149 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1150}
1151
1152IV
1153PerlIOStdio_flush(PerlIO *f)
1154{
1155 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1156 return fflush(stdio);
1157}
1158
1159IV
1160PerlIOStdio_eof(PerlIO *f)
1161{
1162 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1163}
1164
1165IV
1166PerlIOStdio_error(PerlIO *f)
1167{
1168 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1169}
1170
1171void
1172PerlIOStdio_clearerr(PerlIO *f)
1173{
1174 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1175}
1176
1177void
1178PerlIOStdio_setlinebuf(PerlIO *f)
1179{
1180#ifdef HAS_SETLINEBUF
1181 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1182#else
1183 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1184#endif
1185}
1186
1187#ifdef FILE_base
1188STDCHAR *
1189PerlIOStdio_get_base(PerlIO *f)
1190{
1191 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1192 return FILE_base(stdio);
1193}
1194
1195Size_t
1196PerlIOStdio_get_bufsiz(PerlIO *f)
1197{
1198 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1199 return FILE_bufsiz(stdio);
1200}
1201#endif
1202
1203#ifdef USE_STDIO_PTR
1204STDCHAR *
1205PerlIOStdio_get_ptr(PerlIO *f)
1206{
1207 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1208 return FILE_ptr(stdio);
1209}
1210
1211SSize_t
1212PerlIOStdio_get_cnt(PerlIO *f)
1213{
1214 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1215 return FILE_cnt(stdio);
1216}
1217
1218void
1219PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1220{
1221 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1222 if (ptr != NULL)
1223 {
1224#ifdef STDIO_PTR_LVALUE
1225 FILE_ptr(stdio) = ptr;
1226#ifdef STDIO_PTR_LVAL_SETS_CNT
1227 if (FILE_cnt(stdio) != (cnt))
1228 {
1229 dTHX;
1230 assert(FILE_cnt(stdio) == (cnt));
1231 }
1232#endif
1233#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1234 /* Setting ptr _does_ change cnt - we are done */
1235 return;
1236#endif
1237#else /* STDIO_PTR_LVALUE */
1238 abort();
1239#endif /* STDIO_PTR_LVALUE */
1240 }
1241/* Now (or only) set cnt */
1242#ifdef STDIO_CNT_LVALUE
1243 FILE_cnt(stdio) = cnt;
1244#else /* STDIO_CNT_LVALUE */
1245#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1246 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1247#else /* STDIO_PTR_LVAL_SETS_CNT */
1248 abort();
1249#endif /* STDIO_PTR_LVAL_SETS_CNT */
1250#endif /* STDIO_CNT_LVALUE */
1251}
1252
1253#endif
1254
1255PerlIO_funcs PerlIO_stdio = {
1256 "stdio",
1257 sizeof(PerlIOStdio),
1258 0,
1259 PerlIOStdio_fileno,
1260 PerlIOStdio_fdopen,
1261 PerlIOStdio_open,
1262 PerlIOStdio_reopen,
1263 PerlIOStdio_read,
1264 PerlIOStdio_unread,
1265 PerlIOStdio_write,
1266 PerlIOStdio_seek,
1267 PerlIOStdio_tell,
1268 PerlIOStdio_close,
1269 PerlIOStdio_flush,
1270 PerlIOStdio_eof,
1271 PerlIOStdio_error,
1272 PerlIOStdio_clearerr,
1273 PerlIOStdio_setlinebuf,
1274#ifdef FILE_base
1275 PerlIOStdio_get_base,
1276 PerlIOStdio_get_bufsiz,
1277#else
1278 NULL,
1279 NULL,
1280#endif
1281#ifdef USE_STDIO_PTR
1282 PerlIOStdio_get_ptr,
1283 PerlIOStdio_get_cnt,
1284#if (defined(STDIO_PTR_LVALUE) && \
1285 (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1286 PerlIOStdio_set_ptrcnt
1287#else /* STDIO_PTR_LVALUE */
1288 NULL
1289#endif /* STDIO_PTR_LVALUE */
1290#else /* USE_STDIO_PTR */
1291 NULL,
1292 NULL,
1293 NULL
1294#endif /* USE_STDIO_PTR */
1295};
1296
1297#undef PerlIO_exportFILE
1298FILE *
1299PerlIO_exportFILE(PerlIO *f, int fl)
1300{
1301 PerlIO_flush(f);
1302 /* Should really push stdio discipline when we have them */
1303 return fdopen(PerlIO_fileno(f),"r+");
1304}
1305
1306#undef PerlIO_findFILE
1307FILE *
1308PerlIO_findFILE(PerlIO *f)
1309{
1310 return PerlIO_exportFILE(f,0);
1311}
1312
1313#undef PerlIO_releaseFILE
1314void
1315PerlIO_releaseFILE(PerlIO *p, FILE *f)
1316{
1317}
1318
1319/*--------------------------------------------------------------------------------------*/
1320/* perlio buffer layer */
1321
1322typedef struct
760ac839 1323{
9e353e3b
NIS
1324 struct _PerlIO base;
1325 Off_t posn; /* Offset of buf into the file */
1326 STDCHAR * buf; /* Start of buffer */
1327 STDCHAR * end; /* End of valid part of buffer */
1328 STDCHAR * ptr; /* Current position in buffer */
1329 Size_t bufsiz; /* Size of buffer */
1330 IV oneword; /* Emergency buffer */
1331} PerlIOBuf;
1332
1333
1334PerlIO *
1335PerlIOBuf_fdopen(int fd, const char *mode)
1336{
1337 PerlIO_funcs *tab = PerlIO_default_btm();
c7fc522f
NIS
1338 int init = 0;
1339 PerlIO *f;
1340 if (*mode == 'I')
1341 {
1342 init = 1;
1343 mode++;
1344 }
1345 f = (*tab->Fdopen)(fd,mode);
6f9d8c32
NIS
1346 if (f)
1347 {
c7fc522f
NIS
1348 /* Initial stderr is unbuffered */
1349 if (!init || fd != 2)
1350 {
1351 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1352 b->posn = PerlIO_tell(PerlIONext(f));
1353 }
6f9d8c32 1354 }
9e353e3b 1355 return f;
760ac839
LW
1356}
1357
9e353e3b
NIS
1358PerlIO *
1359PerlIOBuf_open(const char *path, const char *mode)
8c86a920 1360{
9e353e3b
NIS
1361 PerlIO_funcs *tab = PerlIO_default_btm();
1362 PerlIO *f = (*tab->Open)(path,mode);
1363 if (f)
1364 {
1365 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1366 b->posn = 0;
1367 }
1368 return f;
1369}
1370
1371int
1372PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1373{
1374 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1375}
1376
1377void
1378PerlIOBuf_alloc_buf(PerlIOBuf *b)
1379{
1380 if (!b->bufsiz)
1381 b->bufsiz = 4096;
05d1247b 1382 New('B',b->buf,b->bufsiz,STDCHAR);
9e353e3b
NIS
1383 if (!b->buf)
1384 {
1385 b->buf = (STDCHAR *)&b->oneword;
1386 b->bufsiz = sizeof(b->oneword);
1387 }
1388 b->ptr = b->buf;
1389 b->end = b->ptr;
8c86a920
PP
1390}
1391
9e353e3b
NIS
1392/* This "flush" is akin to sfio's sync in that it handles files in either
1393 read or write state
1394*/
1395IV
1396PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1397{
9e353e3b
NIS
1398 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1399 int code = 0;
1400 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1401 {
1402 /* write() the buffer */
1403 STDCHAR *p = b->buf;
1404 int count;
1405 while (p < b->ptr)
1406 {
1407 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1408 if (count > 0)
1409 {
1410 p += count;
1411 }
1412 else if (count < 0)
1413 {
1414 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1415 code = -1;
1416 break;
1417 }
1418 }
1419 b->posn += (p - b->buf);
1420 }
1421 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1422 {
9e353e3b
NIS
1423 /* Note position change */
1424 b->posn += (b->ptr - b->buf);
1425 if (b->ptr < b->end)
1426 {
1427 /* We did not consume all of it */
1428 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1429 {
1430 b->posn = PerlIO_tell(PerlIONext(f));
1431 }
1432 }
6f9d8c32 1433 }
9e353e3b
NIS
1434 b->ptr = b->end = b->buf;
1435 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1436 if (PerlIO_flush(PerlIONext(f)) != 0)
1437 code = -1;
1438 return code;
6f9d8c32
NIS
1439}
1440
6f9d8c32 1441SSize_t
9e353e3b 1442PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1443{
9e353e3b 1444 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
6f9d8c32
NIS
1445 STDCHAR *buf = (STDCHAR *) vbuf;
1446 if (f)
1447 {
1448 Size_t got = 0;
9e353e3b
NIS
1449 if (!b->ptr)
1450 PerlIOBuf_alloc_buf(b);
1451 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1452 return 0;
6f9d8c32
NIS
1453 while (count > 0)
1454 {
9e353e3b 1455 SSize_t avail = (b->end - b->ptr);
6f9d8c32
NIS
1456 if ((SSize_t) count < avail)
1457 avail = count;
1458 if (avail > 0)
1459 {
9e353e3b 1460 Copy(b->ptr,buf,avail,char);
6f9d8c32 1461 got += avail;
9e353e3b 1462 b->ptr += avail;
6f9d8c32
NIS
1463 count -= avail;
1464 buf += avail;
1465 }
9e353e3b 1466 if (count && (b->ptr >= b->end))
6f9d8c32 1467 {
bb9950b7 1468 PerlIO_flush(f);
9e353e3b
NIS
1469 b->ptr = b->end = b->buf;
1470 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
6f9d8c32
NIS
1471 if (avail <= 0)
1472 {
1473 if (avail == 0)
9e353e3b 1474 PerlIOBase(f)->flags |= PERLIO_F_EOF;
6f9d8c32 1475 else
9e353e3b 1476 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
6f9d8c32
NIS
1477 break;
1478 }
9e353e3b
NIS
1479 b->end = b->buf+avail;
1480 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
6f9d8c32
NIS
1481 }
1482 }
1483 return got;
1484 }
1485 return 0;
1486}
1487
9e353e3b
NIS
1488SSize_t
1489PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1490{
9e353e3b
NIS
1491 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1492 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1493 SSize_t unread = 0;
1494 SSize_t avail;
1495 if (!b->buf)
1496 PerlIOBuf_alloc_buf(b);
1497 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1498 PerlIO_flush(f);
1499 if (b->buf)
1500 {
1501 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1502 {
1503 avail = (b->ptr - b->buf);
1504 if (avail > (SSize_t) count)
1505 avail = count;
1506 b->ptr -= avail;
1507 }
1508 else
1509 {
1510 avail = b->bufsiz;
1511 if (avail > (SSize_t) count)
1512 avail = count;
1513 b->end = b->ptr + avail;
1514 }
1515 if (avail > 0)
1516 {
1517 buf -= avail;
1518 if (buf != b->ptr)
1519 {
1520 Copy(buf,b->ptr,avail,char);
1521 }
1522 count -= avail;
1523 unread += avail;
1524 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1525 }
1526 }
1527 return unread;
760ac839
LW
1528}
1529
9e353e3b
NIS
1530SSize_t
1531PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1532{
9e353e3b
NIS
1533 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1534 const STDCHAR *buf = (const STDCHAR *) vbuf;
1535 Size_t written = 0;
1536 if (!b->buf)
1537 PerlIOBuf_alloc_buf(b);
1538 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1539 return 0;
1540 while (count > 0)
1541 {
1542 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1543 if ((SSize_t) count < avail)
1544 avail = count;
1545 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1546 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1547 {
1548 while (avail > 0)
1549 {
1550 int ch = *buf++;
1551 *(b->ptr)++ = ch;
1552 count--;
1553 avail--;
1554 written++;
1555 if (ch == '\n')
1556 {
1557 PerlIO_flush(f);
1558 break;
1559 }
1560 }
1561 }
1562 else
1563 {
1564 if (avail)
1565 {
1566 Copy(buf,b->ptr,avail,char);
1567 count -= avail;
1568 buf += avail;
1569 written += avail;
1570 b->ptr += avail;
1571 }
1572 }
1573 if (b->ptr >= (b->buf + b->bufsiz))
1574 PerlIO_flush(f);
1575 }
1576 return written;
1577}
1578
1579IV
1580PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1581{
1582 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1583 int code;
1584 code = PerlIO_flush(f);
1585 if (code == 0)
1586 {
1587 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1588 code = PerlIO_seek(PerlIONext(f),offset,whence);
1589 if (code == 0)
1590 {
1591 b->posn = PerlIO_tell(PerlIONext(f));
1592 }
1593 }
1594 return code;
1595}
1596
1597Off_t
1598PerlIOBuf_tell(PerlIO *f)
1599{
1600 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1601 Off_t posn = b->posn;
1602 if (b->buf)
1603 posn += (b->ptr - b->buf);
1604 return posn;
1605}
1606
1607IV
1608PerlIOBuf_close(PerlIO *f)
1609{
1610 IV code = PerlIOBase_close(f);
1611 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1612 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 1613 {
9e353e3b 1614 Safefree(b->buf);
6f9d8c32 1615 }
9e353e3b
NIS
1616 b->buf = NULL;
1617 b->ptr = b->end = b->buf;
1618 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1619 return code;
760ac839
LW
1620}
1621
760ac839 1622void
9e353e3b 1623PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 1624{
6f9d8c32
NIS
1625 if (f)
1626 {
9e353e3b 1627 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 1628 }
760ac839
LW
1629}
1630
760ac839 1631void
9e353e3b 1632PerlIOBuf_set_cnt(PerlIO *f, int cnt)
760ac839 1633{
9e353e3b
NIS
1634 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1635 dTHX;
1636 if (!b->buf)
1637 PerlIOBuf_alloc_buf(b);
1638 b->ptr = b->end - cnt;
1639 assert(b->ptr >= b->buf);
1640}
1641
1642STDCHAR *
1643PerlIOBuf_get_ptr(PerlIO *f)
1644{
1645 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1646 if (!b->buf)
1647 PerlIOBuf_alloc_buf(b);
1648 return b->ptr;
1649}
1650
05d1247b 1651SSize_t
9e353e3b
NIS
1652PerlIOBuf_get_cnt(PerlIO *f)
1653{
1654 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1655 if (!b->buf)
1656 PerlIOBuf_alloc_buf(b);
1657 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1658 return (b->end - b->ptr);
1659 return 0;
1660}
1661
1662STDCHAR *
1663PerlIOBuf_get_base(PerlIO *f)
1664{
1665 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1666 if (!b->buf)
1667 PerlIOBuf_alloc_buf(b);
1668 return b->buf;
1669}
1670
1671Size_t
1672PerlIOBuf_bufsiz(PerlIO *f)
1673{
1674 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1675 if (!b->buf)
1676 PerlIOBuf_alloc_buf(b);
1677 return (b->end - b->buf);
1678}
1679
1680void
05d1247b 1681PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS
1682{
1683 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1684 if (!b->buf)
1685 PerlIOBuf_alloc_buf(b);
1686 b->ptr = ptr;
1687 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 1688 {
9e353e3b
NIS
1689 dTHX;
1690 assert(PerlIO_get_cnt(f) == cnt);
1691 assert(b->ptr >= b->buf);
6f9d8c32 1692 }
9e353e3b 1693 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
1694}
1695
9e353e3b
NIS
1696PerlIO_funcs PerlIO_perlio = {
1697 "perlio",
1698 sizeof(PerlIOBuf),
1699 0,
1700 PerlIOBase_fileno,
1701 PerlIOBuf_fdopen,
1702 PerlIOBuf_open,
1703 PerlIOBase_reopen,
1704 PerlIOBuf_read,
1705 PerlIOBuf_unread,
1706 PerlIOBuf_write,
1707 PerlIOBuf_seek,
1708 PerlIOBuf_tell,
1709 PerlIOBuf_close,
1710 PerlIOBuf_flush,
1711 PerlIOBase_eof,
1712 PerlIOBase_error,
1713 PerlIOBase_clearerr,
1714 PerlIOBuf_setlinebuf,
1715 PerlIOBuf_get_base,
1716 PerlIOBuf_bufsiz,
1717 PerlIOBuf_get_ptr,
1718 PerlIOBuf_get_cnt,
1719 PerlIOBuf_set_ptrcnt,
1720};
1721
1722void
1723PerlIO_init(void)
760ac839 1724{
9e353e3b 1725 if (!_perlio)
6f9d8c32 1726 {
9e353e3b 1727 atexit(&PerlIO_cleanup);
6f9d8c32 1728 }
760ac839
LW
1729}
1730
9e353e3b
NIS
1731#undef PerlIO_stdin
1732PerlIO *
1733PerlIO_stdin(void)
1734{
1735 if (!_perlio)
f3862f8b 1736 PerlIO_stdstreams();
05d1247b 1737 return &_perlio[1];
9e353e3b
NIS
1738}
1739
1740#undef PerlIO_stdout
1741PerlIO *
1742PerlIO_stdout(void)
1743{
1744 if (!_perlio)
f3862f8b 1745 PerlIO_stdstreams();
05d1247b 1746 return &_perlio[2];
9e353e3b
NIS
1747}
1748
1749#undef PerlIO_stderr
1750PerlIO *
1751PerlIO_stderr(void)
1752{
1753 if (!_perlio)
f3862f8b 1754 PerlIO_stdstreams();
05d1247b 1755 return &_perlio[3];
9e353e3b
NIS
1756}
1757
1758/*--------------------------------------------------------------------------------------*/
1759
1760#undef PerlIO_getname
1761char *
1762PerlIO_getname(PerlIO *f, char *buf)
1763{
1764 dTHX;
1765 Perl_croak(aTHX_ "Don't know how to get file name");
1766 return NULL;
1767}
1768
1769
1770/*--------------------------------------------------------------------------------------*/
1771/* Functions which can be called on any kind of PerlIO implemented
1772 in terms of above
1773*/
1774
1775#undef PerlIO_getc
6f9d8c32 1776int
9e353e3b 1777PerlIO_getc(PerlIO *f)
760ac839 1778{
9e353e3b
NIS
1779 STDCHAR buf;
1780 int count = PerlIO_read(f,&buf,1);
1781 if (count == 1)
1782 return (unsigned char) buf;
1783 return -1;
760ac839
LW
1784}
1785
9e353e3b
NIS
1786#undef PerlIO_putc
1787int
1788PerlIO_putc(PerlIO *f, int ch)
760ac839 1789{
9e353e3b
NIS
1790 STDCHAR buf = ch;
1791 return PerlIO_write(f,&buf,1);
760ac839
LW
1792}
1793
9e353e3b 1794#undef PerlIO_puts
760ac839 1795int
9e353e3b 1796PerlIO_puts(PerlIO *f, const char *s)
760ac839 1797{
9e353e3b
NIS
1798 STRLEN len = strlen(s);
1799 return PerlIO_write(f,s,len);
760ac839
LW
1800}
1801
1802#undef PerlIO_rewind
1803void
c78749f2 1804PerlIO_rewind(PerlIO *f)
760ac839 1805{
6f9d8c32 1806 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 1807 PerlIO_clearerr(f);
6f9d8c32
NIS
1808}
1809
1810#undef PerlIO_vprintf
1811int
1812PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1813{
1814 dTHX;
bb9950b7 1815 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
1816 char *s;
1817 STRLEN len;
1818 sv_vcatpvf(sv, fmt, &ap);
1819 s = SvPV(sv,len);
bb9950b7 1820 return PerlIO_write(f,s,len);
760ac839
LW
1821}
1822
1823#undef PerlIO_printf
6f9d8c32 1824int
760ac839 1825PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
1826{
1827 va_list ap;
1828 int result;
760ac839 1829 va_start(ap,fmt);
6f9d8c32 1830 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
1831 va_end(ap);
1832 return result;
1833}
1834
1835#undef PerlIO_stdoutf
6f9d8c32 1836int
760ac839 1837PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
1838{
1839 va_list ap;
1840 int result;
760ac839 1841 va_start(ap,fmt);
760ac839
LW
1842 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1843 va_end(ap);
1844 return result;
1845}
1846
1847#undef PerlIO_tmpfile
1848PerlIO *
c78749f2 1849PerlIO_tmpfile(void)
760ac839 1850{
6f9d8c32 1851 dTHX;
b1ef6e3b 1852 /* I have no idea how portable mkstemp() is ... */
6f9d8c32
NIS
1853 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1854 int fd = mkstemp(SvPVX(sv));
1855 PerlIO *f = NULL;
1856 if (fd >= 0)
1857 {
b1ef6e3b 1858 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
1859 if (f)
1860 {
9e353e3b 1861 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32
NIS
1862 }
1863 unlink(SvPVX(sv));
1864 SvREFCNT_dec(sv);
1865 }
1866 return f;
760ac839
LW
1867}
1868
6f9d8c32
NIS
1869#undef HAS_FSETPOS
1870#undef HAS_FGETPOS
1871
760ac839
LW
1872#endif /* USE_SFIO */
1873#endif /* PERLIO_IS_STDIO */
1874
9e353e3b
NIS
1875/*======================================================================================*/
1876/* Now some functions in terms of above which may be needed even if
1877 we are not in true PerlIO mode
1878 */
1879
760ac839
LW
1880#ifndef HAS_FSETPOS
1881#undef PerlIO_setpos
1882int
c78749f2 1883PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 1884{
6f9d8c32 1885 return PerlIO_seek(f,*pos,0);
760ac839 1886}
c411622e
PP
1887#else
1888#ifndef PERLIO_IS_STDIO
1889#undef PerlIO_setpos
1890int
c78749f2 1891PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 1892{
2d4389e4 1893#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
1894 return fsetpos64(f, pos);
1895#else
c411622e 1896 return fsetpos(f, pos);
d9b3e12d 1897#endif
c411622e
PP
1898}
1899#endif
760ac839
LW
1900#endif
1901
1902#ifndef HAS_FGETPOS
1903#undef PerlIO_getpos
1904int
c78749f2 1905PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
1906{
1907 *pos = PerlIO_tell(f);
1908 return 0;
1909}
c411622e
PP
1910#else
1911#ifndef PERLIO_IS_STDIO
1912#undef PerlIO_getpos
1913int
c78749f2 1914PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 1915{
2d4389e4 1916#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
1917 return fgetpos64(f, pos);
1918#else
c411622e 1919 return fgetpos(f, pos);
d9b3e12d 1920#endif
c411622e
PP
1921}
1922#endif
760ac839
LW
1923#endif
1924
1925#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1926
1927int
c78749f2 1928vprintf(char *pat, char *args)
662a7e3f
CS
1929{
1930 _doprnt(pat, args, stdout);
1931 return 0; /* wrong, but perl doesn't use the return value */
1932}
1933
1934int
c78749f2 1935vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
1936{
1937 _doprnt(pat, args, fd);
1938 return 0; /* wrong, but perl doesn't use the return value */
1939}
1940
1941#endif
1942
1943#ifndef PerlIO_vsprintf
6f9d8c32 1944int
8ac85365 1945PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
1946{
1947 int val = vsprintf(s, fmt, ap);
1948 if (n >= 0)
1949 {
8c86a920 1950 if (strlen(s) >= (STRLEN)n)
760ac839 1951 {
bf49b057
GS
1952 dTHX;
1953 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1954 my_exit(1);
760ac839
LW
1955 }
1956 }
1957 return val;
1958}
1959#endif
1960
1961#ifndef PerlIO_sprintf
6f9d8c32 1962int
760ac839 1963PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
1964{
1965 va_list ap;
1966 int result;
760ac839 1967 va_start(ap,fmt);
760ac839
LW
1968 result = PerlIO_vsprintf(s, n, fmt, ap);
1969 va_end(ap);
1970 return result;
1971}
1972#endif
1973
c5be433b
GS
1974#endif /* !PERL_IMPLICIT_SYS */
1975