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