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