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