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