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