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