This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix 'mmap' lib/filehand.t (ungetc) test fail.
[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 42}
60382766
NIS
43
44int
f5b9d040 45perlsio_binmode(FILE *fp, int iotype, int mode)
60382766
NIS
46{
47/* This used to be contents of do_binmode in doio.c */
48#ifdef DOSISH
49# if defined(atarist) || defined(__MINT__)
f5b9d040 50 if (!fflush(fp)) {
60382766
NIS
51 if (mode & O_BINARY)
52 ((FILE*)fp)->_flag |= _IOBIN;
53 else
54 ((FILE*)fp)->_flag &= ~ _IOBIN;
55 return 1;
56 }
57 return 0;
58# else
f5b9d040 59 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
60382766
NIS
60# if defined(WIN32) && defined(__BORLANDC__)
61 /* The translation mode of the stream is maintained independent
62 * of the translation mode of the fd in the Borland RTL (heavy
63 * digging through their runtime sources reveal). User has to
64 * set the mode explicitly for the stream (though they don't
65 * document this anywhere). GSAR 97-5-24
66 */
f5b9d040 67 fseek(fp,0L,0);
60382766 68 if (mode & O_BINARY)
f5b9d040 69 fp->flags |= _F_BIN;
60382766 70 else
f5b9d040 71 fp->flags &= ~ _F_BIN;
60382766
NIS
72# endif
73 return 1;
74 }
75 else
76 return 0;
77# endif
78#else
79# if defined(USEMYBINMODE)
80 if (my_binmode(fp, iotype, mode) != FALSE)
81 return 1;
82 else
83 return 0;
84# else
85 return 1;
86# endif
87#endif
88}
89
f5b9d040
NIS
90int
91PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
92{
93 return perlsio_binmode(fp,iotype,mode);
94}
60382766 95
ac27b0f5
NIS
96#endif
97
32e30700
GS
98#if !defined(PERL_IMPLICIT_SYS)
99
6f9d8c32 100#ifdef PERLIO_IS_STDIO
760ac839
LW
101
102void
8ac85365 103PerlIO_init(void)
760ac839 104{
6f9d8c32 105 /* Does nothing (yet) except force this file to be included
760ac839 106 in perl binary. That allows this file to force inclusion
6f9d8c32
NIS
107 of other functions that may be required by loadable
108 extensions e.g. for FileHandle::tmpfile
760ac839
LW
109 */
110}
111
33dcbb9a
PP
112#undef PerlIO_tmpfile
113PerlIO *
8ac85365 114PerlIO_tmpfile(void)
33dcbb9a
PP
115{
116 return tmpfile();
117}
118
760ac839
LW
119#else /* PERLIO_IS_STDIO */
120
121#ifdef USE_SFIO
122
123#undef HAS_FSETPOS
124#undef HAS_FGETPOS
125
6f9d8c32 126/* This section is just to make sure these functions
760ac839
LW
127 get pulled in from libsfio.a
128*/
129
130#undef PerlIO_tmpfile
131PerlIO *
c78749f2 132PerlIO_tmpfile(void)
760ac839
LW
133{
134 return sftmp(0);
135}
136
137void
c78749f2 138PerlIO_init(void)
760ac839 139{
6f9d8c32
NIS
140 /* Force this file to be included in perl binary. Which allows
141 * this file to force inclusion of other functions that may be
142 * required by loadable extensions e.g. for FileHandle::tmpfile
760ac839
LW
143 */
144
145 /* Hack
146 * sfio does its own 'autoflush' on stdout in common cases.
6f9d8c32 147 * Flush results in a lot of lseek()s to regular files and
760ac839
LW
148 * lot of small writes to pipes.
149 */
150 sfset(sfstdout,SF_SHARE,0);
151}
152
17c3b450 153#else /* USE_SFIO */
6f9d8c32 154/*======================================================================================*/
6f9d8c32 155/* Implement all the PerlIO interface ourselves.
9e353e3b 156 */
760ac839 157
76ced9ad
NIS
158#include "perliol.h"
159
b1ef6e3b 160/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
02f66e2f
NIS
161#ifdef I_UNISTD
162#include <unistd.h>
163#endif
06da4f11
NIS
164#ifdef HAS_MMAP
165#include <sys/mman.h>
166#endif
167
f3862f8b 168#include "XSUB.h"
02f66e2f 169
88b61e10 170void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
6f9d8c32 171
6f9d8c32 172void
88b61e10 173PerlIO_debug(const char *fmt,...)
6f9d8c32
NIS
174{
175 static int dbg = 0;
88b61e10
NIS
176 va_list ap;
177 va_start(ap,fmt);
6f9d8c32
NIS
178 if (!dbg)
179 {
00b02797 180 char *s = PerlEnv_getenv("PERLIO_DEBUG");
6f9d8c32 181 if (s && *s)
00b02797 182 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
6f9d8c32
NIS
183 else
184 dbg = -1;
185 }
186 if (dbg > 0)
187 {
188 dTHX;
6f9d8c32
NIS
189 SV *sv = newSVpvn("",0);
190 char *s;
191 STRLEN len;
05d1247b
NIS
192 s = CopFILE(PL_curcop);
193 if (!s)
194 s = "(none)";
195 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
c7fc522f
NIS
196 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
197
6f9d8c32 198 s = SvPV(sv,len);
00b02797 199 PerlLIO_write(dbg,s,len);
6f9d8c32
NIS
200 SvREFCNT_dec(sv);
201 }
88b61e10 202 va_end(ap);
6f9d8c32
NIS
203}
204
9e353e3b
NIS
205/*--------------------------------------------------------------------------------------*/
206
9e353e3b
NIS
207/* Inner level routines */
208
b1ef6e3b 209/* Table of pointers to the PerlIO structs (malloc'ed) */
05d1247b
NIS
210PerlIO *_perlio = NULL;
211#define PERLIO_TABLE_SIZE 64
6f9d8c32 212
760ac839 213PerlIO *
6f9d8c32
NIS
214PerlIO_allocate(void)
215{
f3862f8b 216 /* Find a free slot in the table, allocating new table as necessary */
05d1247b 217 PerlIO **last = &_perlio;
6f9d8c32 218 PerlIO *f;
05d1247b 219 while ((f = *last))
6f9d8c32 220 {
05d1247b
NIS
221 int i;
222 last = (PerlIO **)(f);
223 for (i=1; i < PERLIO_TABLE_SIZE; i++)
6f9d8c32 224 {
05d1247b 225 if (!*++f)
6f9d8c32 226 {
6f9d8c32
NIS
227 return f;
228 }
6f9d8c32 229 }
6f9d8c32 230 }
05d1247b
NIS
231 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
232 if (!f)
233 return NULL;
234 *last = f;
235 return f+1;
236}
237
238void
239PerlIO_cleantable(PerlIO **tablep)
240{
241 PerlIO *table = *tablep;
242 if (table)
243 {
244 int i;
245 PerlIO_cleantable((PerlIO **) &(table[0]));
246 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
247 {
248 PerlIO *f = table+i;
60382766 249 if (*f)
3789aae2
NIS
250 {
251 PerlIO_close(f);
252 }
05d1247b
NIS
253 }
254 Safefree(table);
255 *tablep = NULL;
256 }
257}
258
4a4a6116
NIS
259HV *PerlIO_layer_hv;
260AV *PerlIO_layer_av;
261
05d1247b
NIS
262void
263PerlIO_cleanup(void)
264{
265 PerlIO_cleantable(&_perlio);
6f9d8c32
NIS
266}
267
9e353e3b
NIS
268void
269PerlIO_pop(PerlIO *f)
760ac839 270{
9e353e3b
NIS
271 PerlIOl *l = *f;
272 if (l)
6f9d8c32 273 {
86295796 274 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
06da4f11 275 (*l->tab->Popped)(f);
9e353e3b
NIS
276 *f = l->next;
277 Safefree(l);
6f9d8c32 278 }
6f9d8c32
NIS
279}
280
9e353e3b 281/*--------------------------------------------------------------------------------------*/
b931b1d9 282/* XS Interface for perl code */
9e353e3b 283
b931b1d9 284XS(XS_perlio_import)
f3862f8b
NIS
285{
286 dXSARGS;
287 GV *gv = CvGV(cv);
288 char *s = GvNAME(gv);
289 STRLEN l = GvNAMELEN(gv);
290 PerlIO_debug("%.*s\n",(int) l,s);
291 XSRETURN_EMPTY;
292}
293
b931b1d9 294XS(XS_perlio_unimport)
f3862f8b
NIS
295{
296 dXSARGS;
297 GV *gv = CvGV(cv);
298 char *s = GvNAME(gv);
299 STRLEN l = GvNAMELEN(gv);
300 PerlIO_debug("%.*s\n",(int) l,s);
301 XSRETURN_EMPTY;
302}
303
f3862f8b 304SV *
ac27b0f5 305PerlIO_find_layer(const char *name, STRLEN len)
f3862f8b
NIS
306{
307 dTHX;
308 SV **svp;
309 SV *sv;
310 if (len <= 0)
311 len = strlen(name);
312 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
313 if (svp && (sv = *svp) && SvROK(sv))
314 return *svp;
315 return NULL;
316}
317
b13b2135
NIS
318
319static int
320perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
321{
322 if (SvROK(sv))
323 {
b931b1d9 324 IO *io = GvIOn((GV *)SvRV(sv));
b13b2135
NIS
325 PerlIO *ifp = IoIFP(io);
326 PerlIO *ofp = IoOFP(io);
327 AV *av = (AV *) mg->mg_obj;
328 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
329 }
330 return 0;
331}
332
333static int
334perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
335{
336 if (SvROK(sv))
337 {
b931b1d9 338 IO *io = GvIOn((GV *)SvRV(sv));
b13b2135
NIS
339 PerlIO *ifp = IoIFP(io);
340 PerlIO *ofp = IoOFP(io);
341 AV *av = (AV *) mg->mg_obj;
342 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
343 }
344 return 0;
345}
346
347static int
348perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
349{
350 Perl_warn(aTHX_ "clear %_",sv);
351 return 0;
352}
353
354static int
355perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
356{
357 Perl_warn(aTHX_ "free %_",sv);
358 return 0;
359}
360
361MGVTBL perlio_vtab = {
362 perlio_mg_get,
363 perlio_mg_set,
364 NULL, /* len */
365 NULL,
366 perlio_mg_free
367};
368
369XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
370{
371 dXSARGS;
372 SV *sv = SvRV(ST(1));
373 AV *av = newAV();
374 MAGIC *mg;
375 int count = 0;
376 int i;
377 sv_magic(sv, (SV *)av, '~', NULL, 0);
378 SvRMAGICAL_off(sv);
379 mg = mg_find(sv,'~');
380 mg->mg_virtual = &perlio_vtab;
381 mg_magical(sv);
382 Perl_warn(aTHX_ "attrib %_",sv);
383 for (i=2; i < items; i++)
384 {
385 STRLEN len;
ac27b0f5 386 const char *name = SvPV(ST(i),len);
b13b2135
NIS
387 SV *layer = PerlIO_find_layer(name,len);
388 if (layer)
389 {
390 av_push(av,SvREFCNT_inc(layer));
391 }
392 else
393 {
394 ST(count) = ST(i);
395 count++;
396 }
397 }
398 SvREFCNT_dec(av);
399 XSRETURN(count);
400}
401
f3862f8b
NIS
402void
403PerlIO_define_layer(PerlIO_funcs *tab)
404{
405 dTHX;
b931b1d9 406 HV *stash = gv_stashpv("perlio::Layer", TRUE);
e7778b43 407 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
f3862f8b
NIS
408 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
409}
410
411PerlIO_funcs *
412PerlIO_default_layer(I32 n)
413{
414 dTHX;
415 SV **svp;
416 SV *layer;
417 PerlIO_funcs *tab = &PerlIO_stdio;
418 int len;
419 if (!PerlIO_layer_hv)
420 {
ac27b0f5 421 const char *s = PerlEnv_getenv("PERLIO");
b931b1d9
NIS
422 newXS("perlio::import",XS_perlio_import,__FILE__);
423 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
424#if 0
b13b2135 425 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
b931b1d9
NIS
426#endif
427 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
428 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
f3862f8b 429 PerlIO_define_layer(&PerlIO_unix);
f3862f8b
NIS
430 PerlIO_define_layer(&PerlIO_perlio);
431 PerlIO_define_layer(&PerlIO_stdio);
66ecd56b 432 PerlIO_define_layer(&PerlIO_crlf);
06da4f11
NIS
433#ifdef HAS_MMAP
434 PerlIO_define_layer(&PerlIO_mmap);
435#endif
f3862f8b
NIS
436 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
437 if (s)
438 {
439 while (*s)
440 {
00b02797 441 while (*s && isSPACE((unsigned char)*s))
f3862f8b
NIS
442 s++;
443 if (*s)
444 {
ac27b0f5 445 const char *e = s;
f3862f8b 446 SV *layer;
00b02797 447 while (*e && !isSPACE((unsigned char)*e))
f3862f8b 448 e++;
ac27b0f5
NIS
449 if (*s == ':')
450 s++;
f3862f8b
NIS
451 layer = PerlIO_find_layer(s,e-s);
452 if (layer)
453 {
454 PerlIO_debug("Pushing %.*s\n",(e-s),s);
455 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
456 }
457 else
ef0f9817 458 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
f3862f8b
NIS
459 s = e;
460 }
461 }
462 }
463 }
464 len = av_len(PerlIO_layer_av);
465 if (len < 1)
466 {
f5b9d040 467 if (O_BINARY != O_TEXT)
f3862f8b 468 {
f5b9d040 469 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
f3862f8b
NIS
470 }
471 else
a4d3c1d3 472 {
f5b9d040
NIS
473 if (PerlIO_stdio.Set_ptrcnt)
474 {
475 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
476 }
a4d3c1d3 477 else
f5b9d040
NIS
478 {
479 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
480 }
a4d3c1d3 481 }
f3862f8b
NIS
482 len = av_len(PerlIO_layer_av);
483 }
484 if (n < 0)
485 n += len+1;
486 svp = av_fetch(PerlIO_layer_av,n,0);
487 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
488 {
e7778b43 489 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
f3862f8b
NIS
490 }
491 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
492 return tab;
493}
494
60382766
NIS
495#define PerlIO_default_top() PerlIO_default_layer(-1)
496#define PerlIO_default_btm() PerlIO_default_layer(0)
497
498void
499PerlIO_stdstreams()
500{
501 if (!_perlio)
502 {
503 PerlIO_allocate();
f5b9d040
NIS
504 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
505 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
506 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
60382766
NIS
507 }
508}
509
510PerlIO *
511PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
512{
513 PerlIOl *l = NULL;
514 Newc('L',l,tab->size,char,PerlIOl);
515 if (l)
516 {
517 Zero(l,tab->size,char);
518 l->next = *f;
519 l->tab = tab;
520 *f = l;
a4d3c1d3 521 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
60382766
NIS
522 if ((*l->tab->Pushed)(f,mode) != 0)
523 {
524 PerlIO_pop(f);
525 return NULL;
526 }
527 }
528 return f;
529}
530
ac27b0f5
NIS
531int
532PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
533{
534 if (names)
535 {
536 const char *s = names;
537 while (*s)
538 {
539 while (isSPACE(*s))
540 s++;
541 if (*s == ':')
542 s++;
543 if (*s)
544 {
545 const char *e = s;
546 while (*e && *e != ':' && !isSPACE(*e))
547 e++;
548 if (e > s)
549 {
60382766 550 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
ac27b0f5 551 {
60382766
NIS
552 /* Pop back to bottom layer */
553 if (PerlIONext(f))
ac27b0f5 554 {
60382766
NIS
555 PerlIO_flush(f);
556 while (PerlIONext(f))
557 {
558 PerlIO_pop(f);
559 }
ac27b0f5
NIS
560 }
561 }
562 else
60382766
NIS
563 {
564 SV *layer = PerlIO_find_layer(s,e-s);
565 if (layer)
566 {
567 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
568 if (tab)
569 {
570 PerlIO *new = PerlIO_push(f,tab,mode);
571 if (!new)
572 return -1;
573 }
574 }
575 else
576 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
577 }
ac27b0f5
NIS
578 }
579 s = e;
580 }
581 }
582 }
583 return 0;
584}
585
f3862f8b 586
9e353e3b 587
60382766
NIS
588/*--------------------------------------------------------------------------------------*/
589/* Given the abstraction above the public API functions */
590
591int
f5b9d040 592PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 593{
86295796 594 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
a4d3c1d3 595 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
60382766 596 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
76ced9ad 597 {
f5b9d040 598 PerlIO *top = f;
60382766
NIS
599 PerlIOl *l;
600 while (l = *top)
76ced9ad 601 {
60382766
NIS
602 if (PerlIOBase(top)->tab == &PerlIO_crlf)
603 {
604 PerlIO_flush(top);
a4d3c1d3 605 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
60382766
NIS
606 break;
607 }
608 top = PerlIONext(top);
76ced9ad
NIS
609 }
610 }
f5b9d040
NIS
611 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
612}
613
614#undef PerlIO__close
615int
616PerlIO__close(PerlIO *f)
617{
618 return (*PerlIOBase(f)->tab->Close)(f);
76ced9ad
NIS
619}
620
f5b9d040 621
b931b1d9
NIS
622#undef PerlIO_close
623int
624PerlIO_close(PerlIO *f)
625{
626 int code = (*PerlIOBase(f)->tab->Close)(f);
627 while (*f)
628 {
629 PerlIO_pop(f);
630 }
631 return code;
632}
633
634#undef PerlIO_fileno
635int
636PerlIO_fileno(PerlIO *f)
637{
638 return (*PerlIOBase(f)->tab->Fileno)(f);
639}
640
641
642
9e353e3b
NIS
643#undef PerlIO_fdopen
644PerlIO *
645PerlIO_fdopen(int fd, const char *mode)
646{
647 PerlIO_funcs *tab = PerlIO_default_top();
f3862f8b
NIS
648 if (!_perlio)
649 PerlIO_stdstreams();
06da4f11 650 return (*tab->Fdopen)(tab,fd,mode);
9e353e3b
NIS
651}
652
6f9d8c32
NIS
653#undef PerlIO_open
654PerlIO *
655PerlIO_open(const char *path, const char *mode)
656{
9e353e3b 657 PerlIO_funcs *tab = PerlIO_default_top();
f3862f8b
NIS
658 if (!_perlio)
659 PerlIO_stdstreams();
06da4f11 660 return (*tab->Open)(tab,path,mode);
6f9d8c32
NIS
661}
662
9e353e3b
NIS
663#undef PerlIO_reopen
664PerlIO *
665PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
6f9d8c32 666{
9e353e3b 667 if (f)
6f9d8c32 668 {
9e353e3b
NIS
669 PerlIO_flush(f);
670 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
671 {
06da4f11
NIS
672 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
673 return f;
9e353e3b
NIS
674 }
675 return NULL;
6f9d8c32 676 }
9e353e3b
NIS
677 else
678 return PerlIO_open(path,mode);
760ac839
LW
679}
680
9e353e3b
NIS
681#undef PerlIO_read
682SSize_t
683PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 684{
9e353e3b 685 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
760ac839
LW
686}
687
313ca112
NIS
688#undef PerlIO_unread
689SSize_t
690PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 691{
313ca112 692 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
760ac839
LW
693}
694
9e353e3b
NIS
695#undef PerlIO_write
696SSize_t
697PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 698{
9e353e3b 699 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
760ac839
LW
700}
701
9e353e3b 702#undef PerlIO_seek
6f9d8c32 703int
9e353e3b 704PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 705{
9e353e3b 706 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
760ac839
LW
707}
708
9e353e3b
NIS
709#undef PerlIO_tell
710Off_t
711PerlIO_tell(PerlIO *f)
760ac839 712{
9e353e3b 713 return (*PerlIOBase(f)->tab->Tell)(f);
760ac839
LW
714}
715
9e353e3b 716#undef PerlIO_flush
6f9d8c32 717int
9e353e3b 718PerlIO_flush(PerlIO *f)
760ac839 719{
6f9d8c32
NIS
720 if (f)
721 {
9e353e3b 722 return (*PerlIOBase(f)->tab->Flush)(f);
6f9d8c32 723 }
9e353e3b 724 else
6f9d8c32 725 {
05d1247b 726 PerlIO **table = &_perlio;
9e353e3b 727 int code = 0;
05d1247b 728 while ((f = *table))
6f9d8c32 729 {
05d1247b
NIS
730 int i;
731 table = (PerlIO **)(f++);
732 for (i=1; i < PERLIO_TABLE_SIZE; i++)
9e353e3b
NIS
733 {
734 if (*f && PerlIO_flush(f) != 0)
735 code = -1;
05d1247b 736 f++;
9e353e3b 737 }
6f9d8c32 738 }
9e353e3b 739 return code;
6f9d8c32 740 }
760ac839
LW
741}
742
06da4f11
NIS
743#undef PerlIO_fill
744int
745PerlIO_fill(PerlIO *f)
746{
747 return (*PerlIOBase(f)->tab->Fill)(f);
748}
749
f3862f8b
NIS
750#undef PerlIO_isutf8
751int
752PerlIO_isutf8(PerlIO *f)
753{
754 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
755}
756
9e353e3b 757#undef PerlIO_eof
6f9d8c32 758int
9e353e3b 759PerlIO_eof(PerlIO *f)
760ac839 760{
9e353e3b
NIS
761 return (*PerlIOBase(f)->tab->Eof)(f);
762}
763
764#undef PerlIO_error
765int
766PerlIO_error(PerlIO *f)
767{
768 return (*PerlIOBase(f)->tab->Error)(f);
769}
770
771#undef PerlIO_clearerr
772void
773PerlIO_clearerr(PerlIO *f)
774{
f5b9d040
NIS
775 if (f && *f)
776 (*PerlIOBase(f)->tab->Clearerr)(f);
9e353e3b
NIS
777}
778
779#undef PerlIO_setlinebuf
780void
781PerlIO_setlinebuf(PerlIO *f)
782{
783 (*PerlIOBase(f)->tab->Setlinebuf)(f);
784}
785
786#undef PerlIO_has_base
787int
788PerlIO_has_base(PerlIO *f)
789{
790 if (f && *f)
6f9d8c32 791 {
9e353e3b 792 return (PerlIOBase(f)->tab->Get_base != NULL);
6f9d8c32 793 }
9e353e3b 794 return 0;
760ac839
LW
795}
796
9e353e3b
NIS
797#undef PerlIO_fast_gets
798int
799PerlIO_fast_gets(PerlIO *f)
760ac839 800{
5e2ab84b 801 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
6f9d8c32 802 {
5e2ab84b
NIS
803 PerlIO_funcs *tab = PerlIOBase(f)->tab;
804 return (tab->Set_ptrcnt != NULL);
6f9d8c32 805 }
9e353e3b
NIS
806 return 0;
807}
808
809#undef PerlIO_has_cntptr
810int
811PerlIO_has_cntptr(PerlIO *f)
812{
813 if (f && *f)
814 {
815 PerlIO_funcs *tab = PerlIOBase(f)->tab;
816 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
817 }
818 return 0;
819}
820
821#undef PerlIO_canset_cnt
822int
823PerlIO_canset_cnt(PerlIO *f)
824{
825 if (f && *f)
826 {
c7fc522f
NIS
827 PerlIOl *l = PerlIOBase(f);
828 return (l->tab->Set_ptrcnt != NULL);
9e353e3b 829 }
c7fc522f 830 return 0;
760ac839
LW
831}
832
833#undef PerlIO_get_base
888911fc 834STDCHAR *
a20bf0c3 835PerlIO_get_base(PerlIO *f)
760ac839 836{
9e353e3b
NIS
837 return (*PerlIOBase(f)->tab->Get_base)(f);
838}
839
840#undef PerlIO_get_bufsiz
841int
842PerlIO_get_bufsiz(PerlIO *f)
843{
844 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
845}
846
847#undef PerlIO_get_ptr
848STDCHAR *
849PerlIO_get_ptr(PerlIO *f)
850{
5e2ab84b
NIS
851 PerlIO_funcs *tab = PerlIOBase(f)->tab;
852 if (tab->Get_ptr == NULL)
853 return NULL;
854 return (*tab->Get_ptr)(f);
9e353e3b
NIS
855}
856
857#undef PerlIO_get_cnt
05d1247b 858int
9e353e3b
NIS
859PerlIO_get_cnt(PerlIO *f)
860{
5e2ab84b
NIS
861 PerlIO_funcs *tab = PerlIOBase(f)->tab;
862 if (tab->Get_cnt == NULL)
863 return 0;
864 return (*tab->Get_cnt)(f);
9e353e3b
NIS
865}
866
867#undef PerlIO_set_cnt
868void
05d1247b 869PerlIO_set_cnt(PerlIO *f,int cnt)
9e353e3b 870{
f3862f8b 871 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
9e353e3b
NIS
872}
873
874#undef PerlIO_set_ptrcnt
875void
05d1247b 876PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
9e353e3b 877{
5e2ab84b
NIS
878 PerlIO_funcs *tab = PerlIOBase(f)->tab;
879 if (tab->Set_ptrcnt == NULL)
880 {
881 dTHX;
882 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
883 }
f3862f8b 884 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
9e353e3b
NIS
885}
886
887/*--------------------------------------------------------------------------------------*/
888/* "Methods" of the "base class" */
889
890IV
891PerlIOBase_fileno(PerlIO *f)
892{
893 return PerlIO_fileno(PerlIONext(f));
894}
895
f5b9d040
NIS
896char *
897PerlIO_modestr(PerlIO *f,char *buf)
898{
899 char *s = buf;
900 IV flags = PerlIOBase(f)->flags;
901 if (flags & PERLIO_F_CANREAD)
a4d3c1d3 902 *s++ = 'r';
f5b9d040 903 if (flags & PERLIO_F_CANWRITE)
a4d3c1d3 904 *s++ = 'w';
f5b9d040 905 if (flags & PERLIO_F_CRLF)
a4d3c1d3 906 *s++ = 't';
f5b9d040 907 else
a4d3c1d3 908 *s++ = 'b';
f5b9d040
NIS
909 *s = '\0';
910 return buf;
911}
912
76ced9ad
NIS
913IV
914PerlIOBase_pushed(PerlIO *f, const char *mode)
9e353e3b 915{
76ced9ad 916 PerlIOl *l = PerlIOBase(f);
f5b9d040
NIS
917 const char *omode = mode;
918 char temp[8];
5e2ab84b 919 PerlIO_funcs *tab = PerlIOBase(f)->tab;
76ced9ad 920 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
f5b9d040 921 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
5e2ab84b
NIS
922 if (tab->Set_ptrcnt != NULL)
923 l->flags |= PERLIO_F_FASTGETS;
76ced9ad 924 if (mode)
6f9d8c32 925 {
76ced9ad 926 switch (*mode++)
06da4f11 927 {
76ced9ad 928 case 'r':
f5b9d040 929 l->flags |= PERLIO_F_CANREAD;
76ced9ad
NIS
930 break;
931 case 'a':
f5b9d040 932 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
76ced9ad
NIS
933 break;
934 case 'w':
f5b9d040 935 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
76ced9ad
NIS
936 break;
937 default:
938 errno = EINVAL;
939 return -1;
940 }
941 while (*mode)
942 {
943 switch (*mode++)
944 {
945 case '+':
946 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
947 break;
948 case 'b':
f5b9d040
NIS
949 l->flags &= ~PERLIO_F_CRLF;
950 break;
951 case 't':
952 l->flags |= PERLIO_F_CRLF;
76ced9ad
NIS
953 break;
954 default:
955 errno = EINVAL;
956 return -1;
957 }
06da4f11 958 }
6f9d8c32 959 }
76ced9ad
NIS
960 else
961 {
962 if (l->next)
963 {
964 l->flags |= l->next->flags &
f5b9d040 965 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
76ced9ad
NIS
966 }
967 }
5e2ab84b 968#if 0
86295796 969 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08x (%s)\n",
f5b9d040 970 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
a4d3c1d3 971 l->flags,PerlIO_modestr(f,temp));
5e2ab84b 972#endif
76ced9ad
NIS
973 return 0;
974}
975
976IV
977PerlIOBase_popped(PerlIO *f)
978{
979 return 0;
760ac839
LW
980}
981
5e2ab84b
NIS
982extern PerlIO_funcs PerlIO_pending;
983
9e353e3b
NIS
984SSize_t
985PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
986{
5e2ab84b 987#if 0
9e353e3b 988 Off_t old = PerlIO_tell(f);
5e2ab84b 989 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
9e353e3b
NIS
990 {
991 Off_t new = PerlIO_tell(f);
992 return old - new;
993 }
5e2ab84b
NIS
994 else
995 {
996 return 0;
997 }
998#else
999 PerlIO_push(f,&PerlIO_pending,"r");
1000 return PerlIOBuf_unread(f,vbuf,count);
1001#endif
9e353e3b
NIS
1002}
1003
1004IV
06da4f11 1005PerlIOBase_noop_ok(PerlIO *f)
9e353e3b
NIS
1006{
1007 return 0;
1008}
1009
1010IV
06da4f11
NIS
1011PerlIOBase_noop_fail(PerlIO *f)
1012{
1013 return -1;
1014}
1015
1016IV
9e353e3b
NIS
1017PerlIOBase_close(PerlIO *f)
1018{
1019 IV code = 0;
f5b9d040 1020 PerlIO *n = PerlIONext(f);
9e353e3b
NIS
1021 if (PerlIO_flush(f) != 0)
1022 code = -1;
f5b9d040 1023 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
9e353e3b
NIS
1024 code = -1;
1025 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1026 return code;
1027}
1028
1029IV
1030PerlIOBase_eof(PerlIO *f)
1031{
1032 if (f && *f)
1033 {
1034 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1035 }
1036 return 1;
1037}
1038
1039IV
1040PerlIOBase_error(PerlIO *f)
1041{
1042 if (f && *f)
1043 {
1044 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1045 }
1046 return 1;
1047}
1048
1049void
1050PerlIOBase_clearerr(PerlIO *f)
1051{
1052 if (f && *f)
1053 {
f5b9d040
NIS
1054 PerlIO *n = PerlIONext(f);
1055 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1056 if (n)
1057 PerlIO_clearerr(n);
9e353e3b
NIS
1058 }
1059}
1060
1061void
1062PerlIOBase_setlinebuf(PerlIO *f)
1063{
1064
1065}
1066
9e353e3b
NIS
1067/*--------------------------------------------------------------------------------------*/
1068/* Bottom-most level for UNIX-like case */
1069
1070typedef struct
1071{
1072 struct _PerlIO base; /* The generic part */
1073 int fd; /* UNIX like file descriptor */
1074 int oflags; /* open/fcntl flags */
1075} PerlIOUnix;
1076
6f9d8c32 1077int
9e353e3b 1078PerlIOUnix_oflags(const char *mode)
760ac839 1079{
9e353e3b
NIS
1080 int oflags = -1;
1081 switch(*mode)
1082 {
1083 case 'r':
1084 oflags = O_RDONLY;
1085 if (*++mode == '+')
1086 {
1087 oflags = O_RDWR;
1088 mode++;
1089 }
1090 break;
1091
1092 case 'w':
1093 oflags = O_CREAT|O_TRUNC;
1094 if (*++mode == '+')
1095 {
1096 oflags |= O_RDWR;
1097 mode++;
1098 }
1099 else
1100 oflags |= O_WRONLY;
1101 break;
1102
1103 case 'a':
1104 oflags = O_CREAT|O_APPEND;
1105 if (*++mode == '+')
1106 {
1107 oflags |= O_RDWR;
1108 mode++;
1109 }
1110 else
1111 oflags |= O_WRONLY;
1112 break;
1113 }
83b075c3
NIS
1114 if (*mode == 'b')
1115 {
f5b9d040
NIS
1116 oflags |= O_BINARY;
1117 oflags &= ~O_TEXT;
1118 mode++;
1119 }
1120 else if (*mode == 't')
1121 {
1122 oflags |= O_TEXT;
1123 oflags &= ~O_BINARY;
60382766
NIS
1124 mode++;
1125 }
99efab12
NIS
1126 /* Always open in binary mode */
1127 oflags |= O_BINARY;
9e353e3b 1128 if (*mode || oflags == -1)
6f9d8c32 1129 {
9e353e3b
NIS
1130 errno = EINVAL;
1131 oflags = -1;
6f9d8c32 1132 }
9e353e3b
NIS
1133 return oflags;
1134}
1135
1136IV
1137PerlIOUnix_fileno(PerlIO *f)
1138{
1139 return PerlIOSelf(f,PerlIOUnix)->fd;
1140}
1141
1142PerlIO *
06da4f11 1143PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
1144{
1145 PerlIO *f = NULL;
c7fc522f
NIS
1146 if (*mode == 'I')
1147 mode++;
9e353e3b
NIS
1148 if (fd >= 0)
1149 {
1150 int oflags = PerlIOUnix_oflags(mode);
1151 if (oflags != -1)
1152 {
06da4f11 1153 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
9e353e3b
NIS
1154 s->fd = fd;
1155 s->oflags = oflags;
1156 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1157 }
1158 }
1159 return f;
1160}
1161
1162PerlIO *
06da4f11 1163PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
1164{
1165 PerlIO *f = NULL;
1166 int oflags = PerlIOUnix_oflags(mode);
1167 if (oflags != -1)
1168 {
00b02797 1169 int fd = PerlLIO_open3(path,oflags,0666);
9e353e3b
NIS
1170 if (fd >= 0)
1171 {
06da4f11 1172 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
9e353e3b
NIS
1173 s->fd = fd;
1174 s->oflags = oflags;
1175 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1176 }
1177 }
1178 return f;
760ac839
LW
1179}
1180
760ac839 1181int
9e353e3b 1182PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
760ac839 1183{
9e353e3b
NIS
1184 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1185 int oflags = PerlIOUnix_oflags(mode);
1186 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1187 (*PerlIOBase(f)->tab->Close)(f);
1188 if (oflags != -1)
1189 {
00b02797 1190 int fd = PerlLIO_open3(path,oflags,0666);
9e353e3b
NIS
1191 if (fd >= 0)
1192 {
1193 s->fd = fd;
1194 s->oflags = oflags;
1195 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1196 return 0;
1197 }
1198 }
1199 return -1;
1200}
1201
1202SSize_t
1203PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1204{
1205 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
8f24bd79
NIS
1206 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1207 return 0;
9e353e3b
NIS
1208 while (1)
1209 {
00b02797 1210 SSize_t len = PerlLIO_read(fd,vbuf,count);
9e353e3b 1211 if (len >= 0 || errno != EINTR)
06da4f11
NIS
1212 {
1213 if (len < 0)
1214 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1215 else if (len == 0 && count != 0)
1216 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1217 return len;
1218 }
9e353e3b
NIS
1219 }
1220}
1221
1222SSize_t
1223PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1224{
1225 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1226 while (1)
1227 {
00b02797 1228 SSize_t len = PerlLIO_write(fd,vbuf,count);
9e353e3b 1229 if (len >= 0 || errno != EINTR)
06da4f11
NIS
1230 {
1231 if (len < 0)
1232 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1233 return len;
1234 }
9e353e3b
NIS
1235 }
1236}
1237
1238IV
1239PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1240{
00b02797 1241 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
06da4f11 1242 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
9e353e3b
NIS
1243 return (new == (Off_t) -1) ? -1 : 0;
1244}
1245
1246Off_t
1247PerlIOUnix_tell(PerlIO *f)
1248{
00b02797 1249 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
9e353e3b
NIS
1250}
1251
1252IV
1253PerlIOUnix_close(PerlIO *f)
1254{
1255 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1256 int code = 0;
00b02797 1257 while (PerlLIO_close(fd) != 0)
9e353e3b
NIS
1258 {
1259 if (errno != EINTR)
1260 {
1261 code = -1;
1262 break;
1263 }
1264 }
1265 if (code == 0)
1266 {
1267 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1268 }
1269 return code;
1270}
1271
1272PerlIO_funcs PerlIO_unix = {
1273 "unix",
1274 sizeof(PerlIOUnix),
f5b9d040 1275 PERLIO_K_RAW,
9e353e3b
NIS
1276 PerlIOUnix_fileno,
1277 PerlIOUnix_fdopen,
1278 PerlIOUnix_open,
1279 PerlIOUnix_reopen,
06da4f11
NIS
1280 PerlIOBase_pushed,
1281 PerlIOBase_noop_ok,
9e353e3b
NIS
1282 PerlIOUnix_read,
1283 PerlIOBase_unread,
1284 PerlIOUnix_write,
1285 PerlIOUnix_seek,
1286 PerlIOUnix_tell,
1287 PerlIOUnix_close,
76ced9ad
NIS
1288 PerlIOBase_noop_ok, /* flush */
1289 PerlIOBase_noop_fail, /* fill */
9e353e3b
NIS
1290 PerlIOBase_eof,
1291 PerlIOBase_error,
1292 PerlIOBase_clearerr,
1293 PerlIOBase_setlinebuf,
1294 NULL, /* get_base */
1295 NULL, /* get_bufsiz */
1296 NULL, /* get_ptr */
1297 NULL, /* get_cnt */
1298 NULL, /* set_ptrcnt */
1299};
1300
1301/*--------------------------------------------------------------------------------------*/
1302/* stdio as a layer */
1303
1304typedef struct
1305{
1306 struct _PerlIO base;
1307 FILE * stdio; /* The stream */
1308} PerlIOStdio;
1309
1310IV
1311PerlIOStdio_fileno(PerlIO *f)
1312{
1313 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1314}
1315
f5b9d040
NIS
1316const char *
1317PerlIOStdio_mode(const char *mode,char *tmode)
1318{
1319 const char *ret = mode;
1320 if (O_BINARY != O_TEXT)
1321 {
1322 ret = (const char *) tmode;
1323 while (*mode)
1324 {
1325 *tmode++ = *mode++;
1326 }
1327 *tmode++ = 'b';
a4d3c1d3 1328 *tmode = '\0';
f5b9d040
NIS
1329 }
1330 return ret;
1331}
9e353e3b
NIS
1332
1333PerlIO *
06da4f11 1334PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
1335{
1336 PerlIO *f = NULL;
c7fc522f 1337 int init = 0;
f5b9d040 1338 char tmode[8];
c7fc522f
NIS
1339 if (*mode == 'I')
1340 {
1341 init = 1;
1342 mode++;
1343 }
9e353e3b
NIS
1344 if (fd >= 0)
1345 {
c7fc522f
NIS
1346 FILE *stdio = NULL;
1347 if (init)
1348 {
1349 switch(fd)
1350 {
1351 case 0:
1352 stdio = stdin;
1353 break;
1354 case 1:
1355 stdio = stdout;
1356 break;
1357 case 2:
1358 stdio = stderr;
1359 break;
1360 }
1361 }
1362 else
f5b9d040
NIS
1363 {
1364 stdio = fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1365 }
9e353e3b
NIS
1366 if (stdio)
1367 {
06da4f11 1368 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1369 s->stdio = stdio;
1370 }
1371 }
1372 return f;
1373}
1374
1375#undef PerlIO_importFILE
1376PerlIO *
1377PerlIO_importFILE(FILE *stdio, int fl)
1378{
1379 PerlIO *f = NULL;
1380 if (stdio)
1381 {
1382 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1383 s->stdio = stdio;
1384 }
1385 return f;
1386}
1387
1388PerlIO *
06da4f11 1389PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
1390{
1391 PerlIO *f = NULL;
1392 FILE *stdio = fopen(path,mode);
1393 if (stdio)
1394 {
f5b9d040 1395 char tmode[8];
a4d3c1d3 1396 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
f5b9d040
NIS
1397 (mode = PerlIOStdio_mode(mode,tmode))),
1398 PerlIOStdio);
9e353e3b
NIS
1399 s->stdio = stdio;
1400 }
1401 return f;
760ac839
LW
1402}
1403
6f9d8c32 1404int
9e353e3b
NIS
1405PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1406{
1407 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
f5b9d040
NIS
1408 char tmode[8];
1409 FILE *stdio = freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
9e353e3b
NIS
1410 if (!s->stdio)
1411 return -1;
1412 s->stdio = stdio;
1413 return 0;
1414}
1415
1416SSize_t
1417PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1418{
1419 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 1420 SSize_t got = 0;
9e353e3b
NIS
1421 if (count == 1)
1422 {
1423 STDCHAR *buf = (STDCHAR *) vbuf;
1424 /* Perl is expecting PerlIO_getc() to fill the buffer
1425 * Linux's stdio does not do that for fread()
1426 */
1427 int ch = fgetc(s);
1428 if (ch != EOF)
1429 {
1430 *buf = ch;
c7fc522f 1431 got = 1;
9e353e3b 1432 }
9e353e3b 1433 }
c7fc522f
NIS
1434 else
1435 got = fread(vbuf,1,count,s);
1436 return got;
9e353e3b
NIS
1437}
1438
1439SSize_t
1440PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1441{
1442 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1443 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1444 SSize_t unread = 0;
1445 while (count > 0)
1446 {
1447 int ch = *buf-- & 0xff;
1448 if (ungetc(ch,s) != ch)
1449 break;
1450 unread++;
1451 count--;
1452 }
1453 return unread;
1454}
1455
1456SSize_t
1457PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1458{
1459 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1460}
1461
1462IV
1463PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1464{
c7fc522f
NIS
1465 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1466 return fseek(stdio,offset,whence);
9e353e3b
NIS
1467}
1468
1469Off_t
1470PerlIOStdio_tell(PerlIO *f)
1471{
c7fc522f
NIS
1472 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1473 return ftell(stdio);
9e353e3b
NIS
1474}
1475
1476IV
1477PerlIOStdio_close(PerlIO *f)
1478{
cf829ab0 1479 int optval, optlen = sizeof(int);
3789aae2 1480 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
cf829ab0 1481 return(
a4d3c1d3 1482 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
cf829ab0
JH
1483 fclose(stdio) :
1484 close(PerlIO_fileno(f)));
9e353e3b
NIS
1485}
1486
1487IV
1488PerlIOStdio_flush(PerlIO *f)
1489{
1490 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
88b61e10
NIS
1491 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1492 {
1493 return fflush(stdio);
1494 }
1495 else
1496 {
1497#if 0
1498 /* FIXME: This discards ungetc() and pre-read stuff which is
1499 not right if this is just a "sync" from a layer above
1500 Suspect right design is to do _this_ but not have layer above
1501 flush this layer read-to-read
1502 */
1503 /* Not writeable - sync by attempting a seek */
1504 int err = errno;
1505 if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1506 errno = err;
1507#endif
1508 }
1509 return 0;
9e353e3b
NIS
1510}
1511
1512IV
06da4f11
NIS
1513PerlIOStdio_fill(PerlIO *f)
1514{
1515 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1516 int c;
3789aae2
NIS
1517 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1518 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1519 {
1520 if (fflush(stdio) != 0)
1521 return EOF;
1522 }
06da4f11
NIS
1523 c = fgetc(stdio);
1524 if (c == EOF || ungetc(c,stdio) != c)
1525 return EOF;
1526 return 0;
1527}
1528
1529IV
9e353e3b
NIS
1530PerlIOStdio_eof(PerlIO *f)
1531{
1532 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1533}
1534
1535IV
1536PerlIOStdio_error(PerlIO *f)
1537{
1538 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1539}
1540
1541void
1542PerlIOStdio_clearerr(PerlIO *f)
1543{
1544 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1545}
1546
1547void
1548PerlIOStdio_setlinebuf(PerlIO *f)
1549{
1550#ifdef HAS_SETLINEBUF
1551 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1552#else
1553 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1554#endif
1555}
1556
1557#ifdef FILE_base
1558STDCHAR *
1559PerlIOStdio_get_base(PerlIO *f)
1560{
1561 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1562 return FILE_base(stdio);
1563}
1564
1565Size_t
1566PerlIOStdio_get_bufsiz(PerlIO *f)
1567{
1568 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1569 return FILE_bufsiz(stdio);
1570}
1571#endif
1572
1573#ifdef USE_STDIO_PTR
1574STDCHAR *
1575PerlIOStdio_get_ptr(PerlIO *f)
1576{
1577 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1578 return FILE_ptr(stdio);
1579}
1580
1581SSize_t
1582PerlIOStdio_get_cnt(PerlIO *f)
1583{
1584 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1585 return FILE_cnt(stdio);
1586}
1587
1588void
1589PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1590{
1591 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1592 if (ptr != NULL)
1593 {
1594#ifdef STDIO_PTR_LVALUE
1595 FILE_ptr(stdio) = ptr;
1596#ifdef STDIO_PTR_LVAL_SETS_CNT
1597 if (FILE_cnt(stdio) != (cnt))
1598 {
1599 dTHX;
1600 assert(FILE_cnt(stdio) == (cnt));
1601 }
1602#endif
1603#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1604 /* Setting ptr _does_ change cnt - we are done */
1605 return;
1606#endif
1607#else /* STDIO_PTR_LVALUE */
1608 abort();
1609#endif /* STDIO_PTR_LVALUE */
1610 }
1611/* Now (or only) set cnt */
1612#ifdef STDIO_CNT_LVALUE
1613 FILE_cnt(stdio) = cnt;
1614#else /* STDIO_CNT_LVALUE */
1615#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1616 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1617#else /* STDIO_PTR_LVAL_SETS_CNT */
1618 abort();
1619#endif /* STDIO_PTR_LVAL_SETS_CNT */
1620#endif /* STDIO_CNT_LVALUE */
1621}
1622
1623#endif
1624
1625PerlIO_funcs PerlIO_stdio = {
1626 "stdio",
1627 sizeof(PerlIOStdio),
f5b9d040 1628 PERLIO_K_BUFFERED,
9e353e3b
NIS
1629 PerlIOStdio_fileno,
1630 PerlIOStdio_fdopen,
1631 PerlIOStdio_open,
1632 PerlIOStdio_reopen,
06da4f11
NIS
1633 PerlIOBase_pushed,
1634 PerlIOBase_noop_ok,
9e353e3b
NIS
1635 PerlIOStdio_read,
1636 PerlIOStdio_unread,
1637 PerlIOStdio_write,
1638 PerlIOStdio_seek,
1639 PerlIOStdio_tell,
1640 PerlIOStdio_close,
1641 PerlIOStdio_flush,
06da4f11 1642 PerlIOStdio_fill,
9e353e3b
NIS
1643 PerlIOStdio_eof,
1644 PerlIOStdio_error,
1645 PerlIOStdio_clearerr,
1646 PerlIOStdio_setlinebuf,
1647#ifdef FILE_base
1648 PerlIOStdio_get_base,
1649 PerlIOStdio_get_bufsiz,
1650#else
1651 NULL,
1652 NULL,
1653#endif
1654#ifdef USE_STDIO_PTR
1655 PerlIOStdio_get_ptr,
1656 PerlIOStdio_get_cnt,
0eb1d8a4 1657#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
9e353e3b
NIS
1658 PerlIOStdio_set_ptrcnt
1659#else /* STDIO_PTR_LVALUE */
1660 NULL
1661#endif /* STDIO_PTR_LVALUE */
1662#else /* USE_STDIO_PTR */
1663 NULL,
1664 NULL,
1665 NULL
1666#endif /* USE_STDIO_PTR */
1667};
1668
1669#undef PerlIO_exportFILE
1670FILE *
1671PerlIO_exportFILE(PerlIO *f, int fl)
1672{
1673 PerlIO_flush(f);
1674 /* Should really push stdio discipline when we have them */
1675 return fdopen(PerlIO_fileno(f),"r+");
1676}
1677
1678#undef PerlIO_findFILE
1679FILE *
1680PerlIO_findFILE(PerlIO *f)
1681{
1682 return PerlIO_exportFILE(f,0);
1683}
1684
1685#undef PerlIO_releaseFILE
1686void
1687PerlIO_releaseFILE(PerlIO *p, FILE *f)
1688{
1689}
1690
1691/*--------------------------------------------------------------------------------------*/
1692/* perlio buffer layer */
1693
5e2ab84b
NIS
1694IV
1695PerlIOBuf_pushed(PerlIO *f, const char *mode)
1696{
1697 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1698 b->posn = PerlIO_tell(PerlIONext(f));
1699 return PerlIOBase_pushed(f,mode);
1700}
1701
9e353e3b 1702PerlIO *
06da4f11 1703PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
9e353e3b
NIS
1704{
1705 PerlIO_funcs *tab = PerlIO_default_btm();
c7fc522f
NIS
1706 int init = 0;
1707 PerlIO *f;
1708 if (*mode == 'I')
1709 {
1710 init = 1;
1711 mode++;
a77df51f 1712 }
10cbe18a 1713#if O_BINARY != O_TEXT
a4d3c1d3
NIS
1714 /* do something about failing setmode()? --jhi */
1715 PerlLIO_setmode(fd, O_BINARY);
10cbe18a 1716#endif
06da4f11 1717 f = (*tab->Fdopen)(tab,fd,mode);
6f9d8c32
NIS
1718 if (f)
1719 {
f5b9d040 1720 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
f5b9d040 1721 if (init && fd == 2)
c7fc522f 1722 {
f5b9d040
NIS
1723 /* Initial stderr is unbuffered */
1724 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
a4d3c1d3 1725 }
5e2ab84b 1726#if 0
86295796 1727 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08x\n",
f5b9d040 1728 self->name,f,fd,mode,PerlIOBase(f)->flags);
5e2ab84b 1729#endif
6f9d8c32 1730 }
9e353e3b 1731 return f;
760ac839
LW
1732}
1733
9e353e3b 1734PerlIO *
06da4f11 1735PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
8c86a920 1736{
9e353e3b 1737 PerlIO_funcs *tab = PerlIO_default_btm();
06da4f11 1738 PerlIO *f = (*tab->Open)(tab,path,mode);
9e353e3b
NIS
1739 if (f)
1740 {
5e2ab84b 1741 PerlIO_push(f,self,mode);
9e353e3b
NIS
1742 }
1743 return f;
1744}
1745
1746int
c3d7c7c9 1747PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
9e353e3b 1748{
c3d7c7c9
NIS
1749 PerlIO *next = PerlIONext(f);
1750 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1751 if (code = 0)
1752 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
c3d7c7c9 1753 return code;
9e353e3b
NIS
1754}
1755
9e353e3b
NIS
1756/* This "flush" is akin to sfio's sync in that it handles files in either
1757 read or write state
1758*/
1759IV
1760PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1761{
9e353e3b
NIS
1762 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1763 int code = 0;
1764 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1765 {
1766 /* write() the buffer */
1767 STDCHAR *p = b->buf;
1768 int count;
3789aae2 1769 PerlIO *n = PerlIONext(f);
9e353e3b
NIS
1770 while (p < b->ptr)
1771 {
3789aae2 1772 count = PerlIO_write(n,p,b->ptr - p);
9e353e3b
NIS
1773 if (count > 0)
1774 {
1775 p += count;
1776 }
3789aae2 1777 else if (count < 0 || PerlIO_error(n))
9e353e3b
NIS
1778 {
1779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1780 code = -1;
1781 break;
1782 }
1783 }
1784 b->posn += (p - b->buf);
1785 }
1786 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1787 {
9e353e3b
NIS
1788 /* Note position change */
1789 b->posn += (b->ptr - b->buf);
1790 if (b->ptr < b->end)
1791 {
1792 /* We did not consume all of it */
1793 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1794 {
1795 b->posn = PerlIO_tell(PerlIONext(f));
1796 }
1797 }
6f9d8c32 1798 }
9e353e3b
NIS
1799 b->ptr = b->end = b->buf;
1800 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
88b61e10 1801 /* FIXME: Is this right for read case ? */
9e353e3b
NIS
1802 if (PerlIO_flush(PerlIONext(f)) != 0)
1803 code = -1;
1804 return code;
6f9d8c32
NIS
1805}
1806
06da4f11
NIS
1807IV
1808PerlIOBuf_fill(PerlIO *f)
1809{
1810 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
88b61e10 1811 PerlIO *n = PerlIONext(f);
06da4f11 1812 SSize_t avail;
88b61e10
NIS
1813 /* FIXME: doing the down-stream flush is a bad idea if it causes
1814 pre-read data in stdio buffer to be discarded
1815 but this is too simplistic - as it skips _our_ hosekeeping
1816 and breaks tell tests.
1817 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1818 {
1819 }
1820 */
06da4f11
NIS
1821 if (PerlIO_flush(f) != 0)
1822 return -1;
88b61e10 1823
06da4f11 1824 b->ptr = b->end = b->buf;
88b61e10
NIS
1825 if (PerlIO_fast_gets(n))
1826 {
1827 /* Layer below is also buffered
1828 * We do _NOT_ want to call its ->Read() because that will loop
1829 * till it gets what we asked for which may hang on a pipe etc.
1830 * Instead take anything it has to hand, or ask it to fill _once_.
1831 */
1832 avail = PerlIO_get_cnt(n);
1833 if (avail <= 0)
1834 {
1835 avail = PerlIO_fill(n);
1836 if (avail == 0)
1837 avail = PerlIO_get_cnt(n);
1838 else
1839 {
1840 if (!PerlIO_error(n) && PerlIO_eof(n))
1841 avail = 0;
1842 }
1843 }
1844 if (avail > 0)
1845 {
1846 STDCHAR *ptr = PerlIO_get_ptr(n);
1847 SSize_t cnt = avail;
1848 if (avail > b->bufsiz)
1849 avail = b->bufsiz;
1850 Copy(ptr,b->buf,avail,STDCHAR);
1851 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1852 }
1853 }
1854 else
1855 {
1856 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1857 }
06da4f11
NIS
1858 if (avail <= 0)
1859 {
1860 if (avail == 0)
1861 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1862 else
1863 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1864 return -1;
1865 }
1866 b->end = b->buf+avail;
1867 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1868 return 0;
1869}
1870
6f9d8c32 1871SSize_t
9e353e3b 1872PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1873{
99efab12
NIS
1874 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1875 STDCHAR *buf = (STDCHAR *) vbuf;
6f9d8c32
NIS
1876 if (f)
1877 {
9e353e3b 1878 if (!b->ptr)
06da4f11 1879 PerlIO_get_base(f);
9e353e3b 1880 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1881 return 0;
6f9d8c32
NIS
1882 while (count > 0)
1883 {
99efab12 1884 SSize_t avail = PerlIO_get_cnt(f);
60382766 1885 SSize_t take = (count < avail) ? count : avail;
99efab12 1886 if (take > 0)
6f9d8c32 1887 {
99efab12
NIS
1888 STDCHAR *ptr = PerlIO_get_ptr(f);
1889 Copy(ptr,buf,take,STDCHAR);
1890 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1891 count -= take;
1892 buf += take;
6f9d8c32 1893 }
99efab12 1894 if (count > 0 && avail <= 0)
6f9d8c32 1895 {
06da4f11
NIS
1896 if (PerlIO_fill(f) != 0)
1897 break;
6f9d8c32
NIS
1898 }
1899 }
99efab12 1900 return (buf - (STDCHAR *) vbuf);
6f9d8c32
NIS
1901 }
1902 return 0;
1903}
1904
9e353e3b
NIS
1905SSize_t
1906PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1907{
9e353e3b
NIS
1908 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1909 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1910 SSize_t unread = 0;
1911 SSize_t avail;
9e353e3b
NIS
1912 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1913 PerlIO_flush(f);
06da4f11
NIS
1914 if (!b->buf)
1915 PerlIO_get_base(f);
9e353e3b
NIS
1916 if (b->buf)
1917 {
1918 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1919 {
1920 avail = (b->ptr - b->buf);
9e353e3b
NIS
1921 }
1922 else
1923 {
1924 avail = b->bufsiz;
5e2ab84b
NIS
1925 b->end = b->buf + avail;
1926 b->ptr = b->end;
1927 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1928 b->posn -= b->bufsiz;
9e353e3b 1929 }
5e2ab84b
NIS
1930 if (avail > (SSize_t) count)
1931 avail = count;
9e353e3b
NIS
1932 if (avail > 0)
1933 {
5e2ab84b 1934 b->ptr -= avail;
9e353e3b
NIS
1935 buf -= avail;
1936 if (buf != b->ptr)
1937 {
88b61e10 1938 Copy(buf,b->ptr,avail,STDCHAR);
9e353e3b
NIS
1939 }
1940 count -= avail;
1941 unread += avail;
1942 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1943 }
1944 }
1945 return unread;
760ac839
LW
1946}
1947
9e353e3b
NIS
1948SSize_t
1949PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1950{
9e353e3b
NIS
1951 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1952 const STDCHAR *buf = (const STDCHAR *) vbuf;
1953 Size_t written = 0;
1954 if (!b->buf)
06da4f11 1955 PerlIO_get_base(f);
9e353e3b
NIS
1956 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1957 return 0;
1958 while (count > 0)
1959 {
1960 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1961 if ((SSize_t) count < avail)
1962 avail = count;
1963 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1964 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1965 {
1966 while (avail > 0)
1967 {
1968 int ch = *buf++;
1969 *(b->ptr)++ = ch;
1970 count--;
1971 avail--;
1972 written++;
1973 if (ch == '\n')
1974 {
1975 PerlIO_flush(f);
1976 break;
1977 }
1978 }
1979 }
1980 else
1981 {
1982 if (avail)
1983 {
88b61e10 1984 Copy(buf,b->ptr,avail,STDCHAR);
9e353e3b
NIS
1985 count -= avail;
1986 buf += avail;
1987 written += avail;
1988 b->ptr += avail;
1989 }
1990 }
1991 if (b->ptr >= (b->buf + b->bufsiz))
1992 PerlIO_flush(f);
1993 }
f5b9d040
NIS
1994 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1995 PerlIO_flush(f);
9e353e3b
NIS
1996 return written;
1997}
1998
1999IV
2000PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2001{
5e2ab84b
NIS
2002 IV code;
2003 if ((code = PerlIO_flush(f)) == 0)
9e353e3b 2004 {
5e2ab84b 2005 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
9e353e3b
NIS
2006 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2007 code = PerlIO_seek(PerlIONext(f),offset,whence);
2008 if (code == 0)
2009 {
2010 b->posn = PerlIO_tell(PerlIONext(f));
2011 }
2012 }
2013 return code;
2014}
2015
2016Off_t
2017PerlIOBuf_tell(PerlIO *f)
2018{
2019 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2020 Off_t posn = b->posn;
2021 if (b->buf)
2022 posn += (b->ptr - b->buf);
2023 return posn;
2024}
2025
2026IV
2027PerlIOBuf_close(PerlIO *f)
2028{
2029 IV code = PerlIOBase_close(f);
2030 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2031 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 2032 {
9e353e3b 2033 Safefree(b->buf);
6f9d8c32 2034 }
9e353e3b
NIS
2035 b->buf = NULL;
2036 b->ptr = b->end = b->buf;
2037 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2038 return code;
760ac839
LW
2039}
2040
760ac839 2041void
9e353e3b 2042PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 2043{
6f9d8c32
NIS
2044 if (f)
2045 {
9e353e3b 2046 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 2047 }
760ac839
LW
2048}
2049
9e353e3b
NIS
2050STDCHAR *
2051PerlIOBuf_get_ptr(PerlIO *f)
2052{
2053 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2054 if (!b->buf)
06da4f11 2055 PerlIO_get_base(f);
9e353e3b
NIS
2056 return b->ptr;
2057}
2058
05d1247b 2059SSize_t
9e353e3b
NIS
2060PerlIOBuf_get_cnt(PerlIO *f)
2061{
2062 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2063 if (!b->buf)
06da4f11 2064 PerlIO_get_base(f);
9e353e3b
NIS
2065 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2066 return (b->end - b->ptr);
2067 return 0;
2068}
2069
2070STDCHAR *
2071PerlIOBuf_get_base(PerlIO *f)
2072{
2073 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2074 if (!b->buf)
06da4f11
NIS
2075 {
2076 if (!b->bufsiz)
2077 b->bufsiz = 4096;
2078 New('B',b->buf,b->bufsiz,STDCHAR);
2079 if (!b->buf)
2080 {
2081 b->buf = (STDCHAR *)&b->oneword;
2082 b->bufsiz = sizeof(b->oneword);
2083 }
2084 b->ptr = b->buf;
2085 b->end = b->ptr;
2086 }
9e353e3b
NIS
2087 return b->buf;
2088}
2089
2090Size_t
2091PerlIOBuf_bufsiz(PerlIO *f)
2092{
2093 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2094 if (!b->buf)
06da4f11 2095 PerlIO_get_base(f);
9e353e3b
NIS
2096 return (b->end - b->buf);
2097}
2098
2099void
05d1247b 2100PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS
2101{
2102 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2103 if (!b->buf)
06da4f11 2104 PerlIO_get_base(f);
9e353e3b
NIS
2105 b->ptr = ptr;
2106 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 2107 {
9e353e3b
NIS
2108 dTHX;
2109 assert(PerlIO_get_cnt(f) == cnt);
2110 assert(b->ptr >= b->buf);
6f9d8c32 2111 }
9e353e3b 2112 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
2113}
2114
9e353e3b
NIS
2115PerlIO_funcs PerlIO_perlio = {
2116 "perlio",
2117 sizeof(PerlIOBuf),
f5b9d040 2118 PERLIO_K_BUFFERED,
9e353e3b
NIS
2119 PerlIOBase_fileno,
2120 PerlIOBuf_fdopen,
2121 PerlIOBuf_open,
c3d7c7c9 2122 PerlIOBuf_reopen,
5e2ab84b 2123 PerlIOBuf_pushed,
06da4f11 2124 PerlIOBase_noop_ok,
9e353e3b
NIS
2125 PerlIOBuf_read,
2126 PerlIOBuf_unread,
2127 PerlIOBuf_write,
2128 PerlIOBuf_seek,
2129 PerlIOBuf_tell,
2130 PerlIOBuf_close,
2131 PerlIOBuf_flush,
06da4f11 2132 PerlIOBuf_fill,
9e353e3b
NIS
2133 PerlIOBase_eof,
2134 PerlIOBase_error,
2135 PerlIOBase_clearerr,
2136 PerlIOBuf_setlinebuf,
2137 PerlIOBuf_get_base,
2138 PerlIOBuf_bufsiz,
2139 PerlIOBuf_get_ptr,
2140 PerlIOBuf_get_cnt,
2141 PerlIOBuf_set_ptrcnt,
2142};
2143
66ecd56b 2144/*--------------------------------------------------------------------------------------*/
5e2ab84b
NIS
2145/* Temp layer to hold unread chars when cannot do it any other way */
2146
2147IV
2148PerlIOPending_fill(PerlIO *f)
2149{
2150 /* Should never happen */
2151 PerlIO_flush(f);
2152 return 0;
2153}
2154
2155IV
2156PerlIOPending_close(PerlIO *f)
2157{
2158 /* A tad tricky - flush pops us, then we close new top */
2159 PerlIO_flush(f);
2160 return PerlIO_close(f);
2161}
2162
2163IV
2164PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2165{
2166 /* A tad tricky - flush pops us, then we seek new top */
2167 PerlIO_flush(f);
2168 return PerlIO_seek(f,offset,whence);
2169}
2170
2171
2172IV
2173PerlIOPending_flush(PerlIO *f)
2174{
2175 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2176 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2177 {
2178 Safefree(b->buf);
2179 b->buf = NULL;
2180 }
2181 PerlIO_pop(f);
2182 return 0;
2183}
2184
2185void
2186PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2187{
2188 if (cnt <= 0)
2189 {
2190 PerlIO_flush(f);
2191 }
2192 else
2193 {
2194 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2195 }
2196}
2197
2198IV
2199PerlIOPending_pushed(PerlIO *f,const char *mode)
2200{
2201 IV code = PerlIOBuf_pushed(f,mode);
2202 PerlIOl *l = PerlIOBase(f);
2203 /* Our PerlIO_fast_gets must match what we are pushed on,
2204 or sv_gets() etc. get muddled when it changes mid-string
2205 when we auto-pop.
2206 */
2207 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2208 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2209 return code;
2210}
2211
2212SSize_t
2213PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2214{
2215 SSize_t avail = PerlIO_get_cnt(f);
2216 SSize_t got = 0;
2217 if (count < avail)
2218 avail = count;
2219 if (avail > 0)
2220 got = PerlIOBuf_read(f,vbuf,avail);
2221 if (got < count)
2222 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2223 return got;
2224}
2225
2226
2227PerlIO_funcs PerlIO_pending = {
2228 "pending",
2229 sizeof(PerlIOBuf),
2230 PERLIO_K_BUFFERED,
2231 PerlIOBase_fileno,
2232 NULL,
2233 NULL,
2234 NULL,
2235 PerlIOPending_pushed,
2236 PerlIOBase_noop_ok,
2237 PerlIOPending_read,
2238 PerlIOBuf_unread,
2239 PerlIOBuf_write,
2240 PerlIOPending_seek,
2241 PerlIOBuf_tell,
2242 PerlIOPending_close,
2243 PerlIOPending_flush,
2244 PerlIOPending_fill,
2245 PerlIOBase_eof,
2246 PerlIOBase_error,
2247 PerlIOBase_clearerr,
2248 PerlIOBuf_setlinebuf,
2249 PerlIOBuf_get_base,
2250 PerlIOBuf_bufsiz,
2251 PerlIOBuf_get_ptr,
2252 PerlIOBuf_get_cnt,
2253 PerlIOPending_set_ptrcnt,
2254};
2255
2256
2257
2258/*--------------------------------------------------------------------------------------*/
99efab12
NIS
2259/* crlf - translation
2260 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
60382766 2261 to hand back a line at a time and keeping a record of which nl we "lied" about.
99efab12 2262 On write translate "\n" to CR,LF
66ecd56b
NIS
2263 */
2264
99efab12
NIS
2265typedef struct
2266{
2267 PerlIOBuf base; /* PerlIOBuf stuff */
60382766 2268 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
99efab12
NIS
2269} PerlIOCrlf;
2270
f5b9d040
NIS
2271IV
2272PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2273{
2274 IV code;
2275 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
5e2ab84b
NIS
2276 code = PerlIOBuf_pushed(f,mode);
2277#if 0
86295796 2278 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08x\n",
f5b9d040 2279 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
a4d3c1d3 2280 PerlIOBase(f)->flags);
5e2ab84b 2281#endif
f5b9d040
NIS
2282 return code;
2283}
2284
2285
99efab12
NIS
2286SSize_t
2287PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2288{
60382766 2289 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
60382766
NIS
2290 if (c->nl)
2291 {
2292 *(c->nl) = 0xd;
2293 c->nl = NULL;
2294 }
f5b9d040
NIS
2295 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2296 return PerlIOBuf_unread(f,vbuf,count);
2297 else
99efab12 2298 {
a4d3c1d3 2299 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
f5b9d040
NIS
2300 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2301 SSize_t unread = 0;
2302 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2303 PerlIO_flush(f);
2304 if (!b->buf)
2305 PerlIO_get_base(f);
2306 if (b->buf)
99efab12 2307 {
f5b9d040 2308 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
99efab12 2309 {
f5b9d040
NIS
2310 b->end = b->ptr = b->buf + b->bufsiz;
2311 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
5e2ab84b 2312 b->posn -= b->bufsiz;
f5b9d040
NIS
2313 }
2314 while (count > 0 && b->ptr > b->buf)
2315 {
2316 int ch = *--buf;
2317 if (ch == '\n')
99efab12 2318 {
f5b9d040
NIS
2319 if (b->ptr - 2 >= b->buf)
2320 {
2321 *--(b->ptr) = 0xa;
2322 *--(b->ptr) = 0xd;
2323 unread++;
2324 count--;
2325 }
2326 else
2327 {
2328 buf++;
2329 break;
2330 }
99efab12
NIS
2331 }
2332 else
2333 {
f5b9d040
NIS
2334 *--(b->ptr) = ch;
2335 unread++;
2336 count--;
99efab12
NIS
2337 }
2338 }
99efab12 2339 }
f5b9d040 2340 return unread;
99efab12 2341 }
99efab12
NIS
2342}
2343
2344SSize_t
2345PerlIOCrlf_get_cnt(PerlIO *f)
2346{
2347 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2348 if (!b->buf)
2349 PerlIO_get_base(f);
2350 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2351 {
2352 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
f5b9d040 2353 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
99efab12
NIS
2354 {
2355 STDCHAR *nl = b->ptr;
60382766 2356 scan:
99efab12
NIS
2357 while (nl < b->end && *nl != 0xd)
2358 nl++;
2359 if (nl < b->end && *nl == 0xd)
2360 {
60382766 2361 test:
99efab12
NIS
2362 if (nl+1 < b->end)
2363 {
2364 if (nl[1] == 0xa)
2365 {
2366 *nl = '\n';
60382766 2367 c->nl = nl;
99efab12 2368 }
60382766 2369 else
99efab12
NIS
2370 {
2371 /* Not CR,LF but just CR */
2372 nl++;
60382766 2373 goto scan;
99efab12
NIS
2374 }
2375 }
2376 else
2377 {
60382766 2378 /* Blast - found CR as last char in buffer */
99efab12
NIS
2379 if (b->ptr < nl)
2380 {
2381 /* They may not care, defer work as long as possible */
60382766 2382 return (nl - b->ptr);
99efab12
NIS
2383 }
2384 else
2385 {
2386 int code;
2387 dTHX;
99efab12
NIS
2388 b->ptr++; /* say we have read it as far as flush() is concerned */
2389 b->buf++; /* Leave space an front of buffer */
2390 b->bufsiz--; /* Buffer is thus smaller */
2391 code = PerlIO_fill(f); /* Fetch some more */
2392 b->bufsiz++; /* Restore size for next time */
2393 b->buf--; /* Point at space */
2394 b->ptr = nl = b->buf; /* Which is what we hand off */
2395 b->posn--; /* Buffer starts here */
2396 *nl = 0xd; /* Fill in the CR */
60382766 2397 if (code == 0)
99efab12
NIS
2398 goto test; /* fill() call worked */
2399 /* CR at EOF - just fall through */
2400 }
2401 }
60382766
NIS
2402 }
2403 }
99efab12
NIS
2404 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2405 }
2406 return 0;
2407}
2408
2409void
2410PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2411{
2412 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2413 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
f5b9d040 2414 IV flags = PerlIOBase(f)->flags;
99efab12
NIS
2415 if (!b->buf)
2416 PerlIO_get_base(f);
2417 if (!ptr)
60382766 2418 {
63dbdb06
NIS
2419 if (c->nl)
2420 ptr = c->nl+1;
2421 else
2422 {
2423 ptr = b->end;
f5b9d040 2424 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
63dbdb06
NIS
2425 ptr--;
2426 }
2427 ptr -= cnt;
60382766
NIS
2428 }
2429 else
2430 {
63dbdb06
NIS
2431 /* Test code - delete when it works ... */
2432 STDCHAR *chk;
2433 if (c->nl)
2434 chk = c->nl+1;
2435 else
2436 {
2437 chk = b->end;
f5b9d040 2438 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
63dbdb06
NIS
2439 chk--;
2440 }
2441 chk -= cnt;
a4d3c1d3 2442
63dbdb06
NIS
2443 if (ptr != chk)
2444 {
2445 dTHX;
f5b9d040 2446 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08x nl=%p e=%p for %d",
a4d3c1d3 2447 ptr, chk, flags, c->nl, b->end, cnt);
63dbdb06 2448 }
60382766 2449 }
99efab12
NIS
2450 if (c->nl)
2451 {
2452 if (ptr > c->nl)
2453 {
2454 /* They have taken what we lied about */
2455 *(c->nl) = 0xd;
2456 c->nl = NULL;
2457 ptr++;
60382766 2458 }
99efab12
NIS
2459 }
2460 b->ptr = ptr;
2461 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2462}
2463
2464SSize_t
2465PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2466{
f5b9d040
NIS
2467 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2468 return PerlIOBuf_write(f,vbuf,count);
2469 else
99efab12 2470 {
a4d3c1d3 2471 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
f5b9d040
NIS
2472 const STDCHAR *buf = (const STDCHAR *) vbuf;
2473 const STDCHAR *ebuf = buf+count;
2474 if (!b->buf)
2475 PerlIO_get_base(f);
2476 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2477 return 0;
2478 while (buf < ebuf)
99efab12 2479 {
f5b9d040
NIS
2480 STDCHAR *eptr = b->buf+b->bufsiz;
2481 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2482 while (buf < ebuf && b->ptr < eptr)
99efab12 2483 {
f5b9d040 2484 if (*buf == '\n')
60382766 2485 {
f5b9d040 2486 if ((b->ptr + 2) > eptr)
60382766 2487 {
f5b9d040 2488 /* Not room for both */
60382766
NIS
2489 PerlIO_flush(f);
2490 break;
2491 }
f5b9d040
NIS
2492 else
2493 {
2494 *(b->ptr)++ = 0xd; /* CR */
2495 *(b->ptr)++ = 0xa; /* LF */
2496 buf++;
2497 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2498 {
2499 PerlIO_flush(f);
2500 break;
2501 }
2502 }
2503 }
2504 else
2505 {
2506 int ch = *buf++;
2507 *(b->ptr)++ = ch;
2508 }
2509 if (b->ptr >= eptr)
2510 {
2511 PerlIO_flush(f);
2512 break;
99efab12 2513 }
99efab12
NIS
2514 }
2515 }
f5b9d040
NIS
2516 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2517 PerlIO_flush(f);
2518 return (buf - (STDCHAR *) vbuf);
99efab12 2519 }
99efab12
NIS
2520}
2521
2522IV
2523PerlIOCrlf_flush(PerlIO *f)
2524{
2525 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2526 if (c->nl)
2527 {
99efab12 2528 *(c->nl) = 0xd;
60382766 2529 c->nl = NULL;
99efab12
NIS
2530 }
2531 return PerlIOBuf_flush(f);
2532}
2533
66ecd56b
NIS
2534PerlIO_funcs PerlIO_crlf = {
2535 "crlf",
99efab12 2536 sizeof(PerlIOCrlf),
f5b9d040 2537 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
66ecd56b
NIS
2538 PerlIOBase_fileno,
2539 PerlIOBuf_fdopen,
2540 PerlIOBuf_open,
2541 PerlIOBuf_reopen,
f5b9d040 2542 PerlIOCrlf_pushed,
99efab12
NIS
2543 PerlIOBase_noop_ok, /* popped */
2544 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2545 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2546 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
66ecd56b
NIS
2547 PerlIOBuf_seek,
2548 PerlIOBuf_tell,
2549 PerlIOBuf_close,
99efab12 2550 PerlIOCrlf_flush,
66ecd56b
NIS
2551 PerlIOBuf_fill,
2552 PerlIOBase_eof,
2553 PerlIOBase_error,
2554 PerlIOBase_clearerr,
2555 PerlIOBuf_setlinebuf,
2556 PerlIOBuf_get_base,
2557 PerlIOBuf_bufsiz,
2558 PerlIOBuf_get_ptr,
99efab12
NIS
2559 PerlIOCrlf_get_cnt,
2560 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS
2561};
2562
06da4f11
NIS
2563#ifdef HAS_MMAP
2564/*--------------------------------------------------------------------------------------*/
2565/* mmap as "buffer" layer */
2566
2567typedef struct
2568{
2569 PerlIOBuf base; /* PerlIOBuf stuff */
c3d7c7c9 2570 Mmap_t mptr; /* Mapped address */
06da4f11
NIS
2571 Size_t len; /* mapped length */
2572 STDCHAR *bbuf; /* malloced buffer if map fails */
2573} PerlIOMmap;
2574
c3d7c7c9
NIS
2575static size_t page_size = 0;
2576
06da4f11
NIS
2577IV
2578PerlIOMmap_map(PerlIO *f)
2579{
68d873c6 2580 dTHX;
06da4f11
NIS
2581 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2582 PerlIOBuf *b = &m->base;
2583 IV flags = PerlIOBase(f)->flags;
2584 IV code = 0;
2585 if (m->len)
2586 abort();
2587 if (flags & PERLIO_F_CANREAD)
2588 {
2589 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2590 int fd = PerlIO_fileno(f);
2591 struct stat st;
2592 code = fstat(fd,&st);
2593 if (code == 0 && S_ISREG(st.st_mode))
2594 {
2595 SSize_t len = st.st_size - b->posn;
2596 if (len > 0)
2597 {
c3d7c7c9 2598 Off_t posn;
68d873c6
JH
2599 if (!page_size) {
2600#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2601 {
2602 SETERRNO(0,SS$_NORMAL);
2603# ifdef _SC_PAGESIZE
2604 page_size = sysconf(_SC_PAGESIZE);
2605# else
2606 page_size = sysconf(_SC_PAGE_SIZE);
14aaf8e8 2607# endif
68d873c6
JH
2608 if ((long)page_size < 0) {
2609 if (errno) {
2610 SV *error = ERRSV;
2611 char *msg;
2612 STRLEN n_a;
2613 (void)SvUPGRADE(error, SVt_PV);
2614 msg = SvPVx(error, n_a);
14aaf8e8 2615 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
68d873c6
JH
2616 }
2617 else
14aaf8e8 2618 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
68d873c6
JH
2619 }
2620 }
2621#else
2622# ifdef HAS_GETPAGESIZE
c3d7c7c9 2623 page_size = getpagesize();
68d873c6
JH
2624# else
2625# if defined(I_SYS_PARAM) && defined(PAGESIZE)
2626 page_size = PAGESIZE; /* compiletime, bad */
2627# endif
2628# endif
2629#endif
2630 if ((IV)page_size <= 0)
14aaf8e8 2631 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
68d873c6 2632 }
c3d7c7c9
NIS
2633 if (b->posn < 0)
2634 {
2635 /* This is a hack - should never happen - open should have set it ! */
2636 b->posn = PerlIO_tell(PerlIONext(f));
2637 }
2638 posn = (b->posn / page_size) * page_size;
2639 len = st.st_size - posn;
2640 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2641 if (m->mptr && m->mptr != (Mmap_t) -1)
06da4f11
NIS
2642 {
2643#if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
c3d7c7c9 2644 madvise(m->mptr, len, MADV_SEQUENTIAL);
06da4f11 2645#endif
c3d7c7c9
NIS
2646 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2647 b->end = ((STDCHAR *)m->mptr) + len;
2648 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2649 b->ptr = b->buf;
2650 m->len = len;
06da4f11
NIS
2651 }
2652 else
2653 {
2654 b->buf = NULL;
2655 }
2656 }
2657 else
2658 {
2659 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2660 b->buf = NULL;
2661 b->ptr = b->end = b->ptr;
2662 code = -1;
2663 }
2664 }
2665 }
2666 return code;
2667}
2668
2669IV
2670PerlIOMmap_unmap(PerlIO *f)
2671{
2672 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2673 PerlIOBuf *b = &m->base;
2674 IV code = 0;
2675 if (m->len)
2676 {
2677 if (b->buf)
2678 {
c3d7c7c9
NIS
2679 code = munmap(m->mptr, m->len);
2680 b->buf = NULL;
2681 m->len = 0;
2682 m->mptr = NULL;
06da4f11
NIS
2683 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2684 code = -1;
06da4f11
NIS
2685 }
2686 b->ptr = b->end = b->buf;
2687 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2688 }
2689 return code;
2690}
2691
2692STDCHAR *
2693PerlIOMmap_get_base(PerlIO *f)
2694{
2695 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2696 PerlIOBuf *b = &m->base;
2697 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2698 {
2699 /* Already have a readbuffer in progress */
2700 return b->buf;
2701 }
2702 if (b->buf)
2703 {
2704 /* We have a write buffer or flushed PerlIOBuf read buffer */
2705 m->bbuf = b->buf; /* save it in case we need it again */
2706 b->buf = NULL; /* Clear to trigger below */
2707 }
2708 if (!b->buf)
2709 {
2710 PerlIOMmap_map(f); /* Try and map it */
2711 if (!b->buf)
2712 {
2713 /* Map did not work - recover PerlIOBuf buffer if we have one */
2714 b->buf = m->bbuf;
2715 }
2716 }
2717 b->ptr = b->end = b->buf;
2718 if (b->buf)
2719 return b->buf;
2720 return PerlIOBuf_get_base(f);
2721}
2722
2723SSize_t
2724PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2725{
2726 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2727 PerlIOBuf *b = &m->base;
2728 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2729 PerlIO_flush(f);
2730 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2731 {
2732 b->ptr -= count;
2733 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2734 return count;
2735 }
2736 if (m->len)
2737 {
4a4a6116 2738 /* Loose the unwritable mapped buffer */
06da4f11 2739 PerlIO_flush(f);
c3d7c7c9
NIS
2740 /* If flush took the "buffer" see if we have one from before */
2741 if (!b->buf && m->bbuf)
2742 b->buf = m->bbuf;
2743 if (!b->buf)
2744 {
2745 PerlIOBuf_get_base(f);
2746 m->bbuf = b->buf;
2747 }
06da4f11 2748 }
5e2ab84b 2749return PerlIOBuf_unread(f,vbuf,count);
06da4f11
NIS
2750}
2751
2752SSize_t
2753PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2754{
2755 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2756 PerlIOBuf *b = &m->base;
2757 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2758 {
2759 /* No, or wrong sort of, buffer */
2760 if (m->len)
2761 {
2762 if (PerlIOMmap_unmap(f) != 0)
2763 return 0;
2764 }
2765 /* If unmap took the "buffer" see if we have one from before */
2766 if (!b->buf && m->bbuf)
2767 b->buf = m->bbuf;
2768 if (!b->buf)
2769 {
2770 PerlIOBuf_get_base(f);
2771 m->bbuf = b->buf;
2772 }
2773 }
2774 return PerlIOBuf_write(f,vbuf,count);
2775}
2776
2777IV
2778PerlIOMmap_flush(PerlIO *f)
2779{
2780 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2781 PerlIOBuf *b = &m->base;
2782 IV code = PerlIOBuf_flush(f);
2783 /* Now we are "synced" at PerlIOBuf level */
2784 if (b->buf)
2785 {
2786 if (m->len)
2787 {
2788 /* Unmap the buffer */
2789 if (PerlIOMmap_unmap(f) != 0)
2790 code = -1;
2791 }
2792 else
2793 {
2794 /* We seem to have a PerlIOBuf buffer which was not mapped
2795 * remember it in case we need one later
2796 */
2797 m->bbuf = b->buf;
2798 }
2799 }
06da4f11
NIS
2800 return code;
2801}
2802
2803IV
2804PerlIOMmap_fill(PerlIO *f)
2805{
2806 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2807 IV code = PerlIO_flush(f);
06da4f11
NIS
2808 if (code == 0 && !b->buf)
2809 {
2810 code = PerlIOMmap_map(f);
06da4f11
NIS
2811 }
2812 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2813 {
2814 code = PerlIOBuf_fill(f);
06da4f11
NIS
2815 }
2816 return code;
2817}
2818
2819IV
2820PerlIOMmap_close(PerlIO *f)
2821{
2822 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2823 PerlIOBuf *b = &m->base;
2824 IV code = PerlIO_flush(f);
2825 if (m->bbuf)
2826 {
2827 b->buf = m->bbuf;
2828 m->bbuf = NULL;
2829 b->ptr = b->end = b->buf;
2830 }
2831 if (PerlIOBuf_close(f) != 0)
2832 code = -1;
06da4f11
NIS
2833 return code;
2834}
2835
2836
2837PerlIO_funcs PerlIO_mmap = {
2838 "mmap",
2839 sizeof(PerlIOMmap),
f5b9d040 2840 PERLIO_K_BUFFERED,
06da4f11
NIS
2841 PerlIOBase_fileno,
2842 PerlIOBuf_fdopen,
2843 PerlIOBuf_open,
c3d7c7c9 2844 PerlIOBuf_reopen,
5e2ab84b 2845 PerlIOBuf_pushed,
06da4f11
NIS
2846 PerlIOBase_noop_ok,
2847 PerlIOBuf_read,
2848 PerlIOMmap_unread,
2849 PerlIOMmap_write,
2850 PerlIOBuf_seek,
2851 PerlIOBuf_tell,
2852 PerlIOBuf_close,
2853 PerlIOMmap_flush,
2854 PerlIOMmap_fill,
2855 PerlIOBase_eof,
2856 PerlIOBase_error,
2857 PerlIOBase_clearerr,
2858 PerlIOBuf_setlinebuf,
2859 PerlIOMmap_get_base,
2860 PerlIOBuf_bufsiz,
2861 PerlIOBuf_get_ptr,
2862 PerlIOBuf_get_cnt,
2863 PerlIOBuf_set_ptrcnt,
2864};
2865
2866#endif /* HAS_MMAP */
2867
9e353e3b
NIS
2868void
2869PerlIO_init(void)
760ac839 2870{
9e353e3b 2871 if (!_perlio)
6f9d8c32 2872 {
9e353e3b 2873 atexit(&PerlIO_cleanup);
6f9d8c32 2874 }
760ac839
LW
2875}
2876
9e353e3b
NIS
2877#undef PerlIO_stdin
2878PerlIO *
2879PerlIO_stdin(void)
2880{
2881 if (!_perlio)
f3862f8b 2882 PerlIO_stdstreams();
05d1247b 2883 return &_perlio[1];
9e353e3b
NIS
2884}
2885
2886#undef PerlIO_stdout
2887PerlIO *
2888PerlIO_stdout(void)
2889{
2890 if (!_perlio)
f3862f8b 2891 PerlIO_stdstreams();
05d1247b 2892 return &_perlio[2];
9e353e3b
NIS
2893}
2894
2895#undef PerlIO_stderr
2896PerlIO *
2897PerlIO_stderr(void)
2898{
2899 if (!_perlio)
f3862f8b 2900 PerlIO_stdstreams();
05d1247b 2901 return &_perlio[3];
9e353e3b
NIS
2902}
2903
2904/*--------------------------------------------------------------------------------------*/
2905
2906#undef PerlIO_getname
2907char *
2908PerlIO_getname(PerlIO *f, char *buf)
2909{
2910 dTHX;
2911 Perl_croak(aTHX_ "Don't know how to get file name");
2912 return NULL;
2913}
2914
2915
2916/*--------------------------------------------------------------------------------------*/
2917/* Functions which can be called on any kind of PerlIO implemented
2918 in terms of above
2919*/
2920
2921#undef PerlIO_getc
6f9d8c32 2922int
9e353e3b 2923PerlIO_getc(PerlIO *f)
760ac839 2924{
313ca112
NIS
2925 STDCHAR buf[1];
2926 SSize_t count = PerlIO_read(f,buf,1);
9e353e3b 2927 if (count == 1)
313ca112
NIS
2928 {
2929 return (unsigned char) buf[0];
2930 }
2931 return EOF;
2932}
2933
2934#undef PerlIO_ungetc
2935int
2936PerlIO_ungetc(PerlIO *f, int ch)
2937{
2938 if (ch != EOF)
2939 {
2940 STDCHAR buf = ch;
2941 if (PerlIO_unread(f,&buf,1) == 1)
2942 return ch;
2943 }
2944 return EOF;
760ac839
LW
2945}
2946
9e353e3b
NIS
2947#undef PerlIO_putc
2948int
2949PerlIO_putc(PerlIO *f, int ch)
760ac839 2950{
9e353e3b
NIS
2951 STDCHAR buf = ch;
2952 return PerlIO_write(f,&buf,1);
760ac839
LW
2953}
2954
9e353e3b 2955#undef PerlIO_puts
760ac839 2956int
9e353e3b 2957PerlIO_puts(PerlIO *f, const char *s)
760ac839 2958{
9e353e3b
NIS
2959 STRLEN len = strlen(s);
2960 return PerlIO_write(f,s,len);
760ac839
LW
2961}
2962
2963#undef PerlIO_rewind
2964void
c78749f2 2965PerlIO_rewind(PerlIO *f)
760ac839 2966{
6f9d8c32 2967 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 2968 PerlIO_clearerr(f);
6f9d8c32
NIS
2969}
2970
2971#undef PerlIO_vprintf
2972int
2973PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2974{
2975 dTHX;
bb9950b7 2976 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
2977 char *s;
2978 STRLEN len;
2cc61e15
DD
2979#ifdef NEED_VA_COPY
2980 va_list apc;
2981 Perl_va_copy(ap, apc);
2982 sv_vcatpvf(sv, fmt, &apc);
2983#else
6f9d8c32 2984 sv_vcatpvf(sv, fmt, &ap);
2cc61e15 2985#endif
6f9d8c32 2986 s = SvPV(sv,len);
bb9950b7 2987 return PerlIO_write(f,s,len);
760ac839
LW
2988}
2989
2990#undef PerlIO_printf
6f9d8c32 2991int
760ac839 2992PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
2993{
2994 va_list ap;
2995 int result;
760ac839 2996 va_start(ap,fmt);
6f9d8c32 2997 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
2998 va_end(ap);
2999 return result;
3000}
3001
3002#undef PerlIO_stdoutf
6f9d8c32 3003int
760ac839 3004PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
3005{
3006 va_list ap;
3007 int result;
760ac839 3008 va_start(ap,fmt);
760ac839
LW
3009 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3010 va_end(ap);
3011 return result;
3012}
3013
3014#undef PerlIO_tmpfile
3015PerlIO *
c78749f2 3016PerlIO_tmpfile(void)
760ac839 3017{
b1ef6e3b 3018 /* I have no idea how portable mkstemp() is ... */
83b075c3
NIS
3019#if defined(WIN32) || !defined(HAVE_MKSTEMP)
3020 PerlIO *f = NULL;
3021 FILE *stdio = tmpfile();
3022 if (stdio)
3023 {
3024 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
3025 s->stdio = stdio;
3026 }
3027 return f;
3028#else
3029 dTHX;
6f9d8c32
NIS
3030 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3031 int fd = mkstemp(SvPVX(sv));
3032 PerlIO *f = NULL;
3033 if (fd >= 0)
3034 {
b1ef6e3b 3035 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
3036 if (f)
3037 {
9e353e3b 3038 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32 3039 }
00b02797 3040 PerlLIO_unlink(SvPVX(sv));
6f9d8c32
NIS
3041 SvREFCNT_dec(sv);
3042 }
3043 return f;
83b075c3 3044#endif
760ac839
LW
3045}
3046
6f9d8c32
NIS
3047#undef HAS_FSETPOS
3048#undef HAS_FGETPOS
3049
760ac839
LW
3050#endif /* USE_SFIO */
3051#endif /* PERLIO_IS_STDIO */
3052
9e353e3b
NIS
3053/*======================================================================================*/
3054/* Now some functions in terms of above which may be needed even if
3055 we are not in true PerlIO mode
3056 */
3057
760ac839
LW
3058#ifndef HAS_FSETPOS
3059#undef PerlIO_setpos
3060int
c78749f2 3061PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 3062{
6f9d8c32 3063 return PerlIO_seek(f,*pos,0);
760ac839 3064}
c411622e
PP
3065#else
3066#ifndef PERLIO_IS_STDIO
3067#undef PerlIO_setpos
3068int
c78749f2 3069PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 3070{
2d4389e4 3071#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
3072 return fsetpos64(f, pos);
3073#else
c411622e 3074 return fsetpos(f, pos);
d9b3e12d 3075#endif
c411622e
PP
3076}
3077#endif
760ac839
LW
3078#endif
3079
3080#ifndef HAS_FGETPOS
3081#undef PerlIO_getpos
3082int
c78749f2 3083PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
3084{
3085 *pos = PerlIO_tell(f);
a17c7222 3086 return *pos == -1 ? -1 : 0;
760ac839 3087}
c411622e
PP
3088#else
3089#ifndef PERLIO_IS_STDIO
3090#undef PerlIO_getpos
3091int
c78749f2 3092PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 3093{
2d4389e4 3094#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
3095 return fgetpos64(f, pos);
3096#else
c411622e 3097 return fgetpos(f, pos);
d9b3e12d 3098#endif
c411622e
PP
3099}
3100#endif
760ac839
LW
3101#endif
3102
3103#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3104
3105int
c78749f2 3106vprintf(char *pat, char *args)
662a7e3f
CS
3107{
3108 _doprnt(pat, args, stdout);
3109 return 0; /* wrong, but perl doesn't use the return value */
3110}
3111
3112int
c78749f2 3113vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
3114{
3115 _doprnt(pat, args, fd);
3116 return 0; /* wrong, but perl doesn't use the return value */
3117}
3118
3119#endif
3120
3121#ifndef PerlIO_vsprintf
6f9d8c32 3122int
8ac85365 3123PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
3124{
3125 int val = vsprintf(s, fmt, ap);
3126 if (n >= 0)
3127 {
8c86a920 3128 if (strlen(s) >= (STRLEN)n)
760ac839 3129 {
bf49b057 3130 dTHX;
fb4a9925
JH
3131 (void)PerlIO_puts(Perl_error_log,
3132 "panic: sprintf overflow - memory corrupted!\n");
bf49b057 3133 my_exit(1);
760ac839
LW
3134 }
3135 }
3136 return val;
3137}
3138#endif
3139
3140#ifndef PerlIO_sprintf
6f9d8c32 3141int
760ac839 3142PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
3143{
3144 va_list ap;
3145 int result;
760ac839 3146 va_start(ap,fmt);
760ac839
LW
3147 result = PerlIO_vsprintf(s, n, fmt, ap);
3148 va_end(ap);
3149 return result;
3150}
3151#endif
3152
c5be433b
GS
3153#endif /* !PERL_IMPLICIT_SYS */
3154