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