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