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