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