Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

perlio.c@ 3277

Visit:

Last change on this file since 3277 was 3181, checked in by bird, 18 years ago
perl 5.8.8
File size: 113.8 KB

Line
1	/*
2	* perlio.c Copyright (c) 1996-2006, Nick Ing-Simmons You may distribute
3	* under the terms of either the GNU General Public License or the
4	* Artistic License, as specified in the README file.
5	*/
6
7	/*
8	* Hour after hour for nearly three weary days he had jogged up and down,
9	* over passes, and through long dales, and across many streams.
10	*/
11
12	/* This file contains the functions needed to implement PerlIO, which
13	* is Perl's private replacement for the C stdio library. This is used
14	* by default unless you compile with -Uuseperlio or run with
15	* PERLIO=:stdio (but don't do this unless you know what you're doing)
16	*/
17
18	/*
19	* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
20	* at the dispatch tables, even when we do not need it for other reasons.
21	* Invent a dSYS macro to abstract this out
22	*/
23	#ifdef PERL_IMPLICIT_SYS
24	#define dSYS dTHX
25	#else
26	#define dSYS dNOOP
27	#endif
28
29	#define VOIDUSED 1
30	#ifdef PERL_MICRO
31	# include "uconfig.h"
32	#else
33	# include "config.h"
34	#endif
35
36	#define PERLIO_NOT_STDIO 0
37	#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
38	/*
39	* #define PerlIO FILE
40	*/
41	#endif
42	/*
43	* This file provides those parts of PerlIO abstraction
44	* which are not #defined in perlio.h.
45	* Which these are depends on various Configure #ifdef's
46	*/
47
48	#include "EXTERN.h"
49	#define PERL_IN_PERLIO_C
50	#include "perl.h"
51
52	#ifdef PERL_IMPLICIT_CONTEXT
53	#undef dSYS
54	#define dSYS dTHX
55	#endif
56
57	#include "XSUB.h"
58
59	#define PERLIO_MAX_REFCOUNTABLE_FD 2048
60
61	#ifdef __Lynx__
62	/* Missing proto on LynxOS */
63	int mkstemp(char*);
64	#endif
65
66	/* Call the callback or PerlIOBase, and return failure. */
67	#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
68	if (PerlIOValid(f)) { \
69	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
70	if (tab && tab->callback) \
71	return (*tab->callback) args; \
72	else \
73	return PerlIOBase_ ## base args; \
74	} \
75	else \
76	SETERRNO(EBADF, SS_IVCHAN); \
77	return failure
78
79	/* Call the callback or fail, and return failure. */
80	#define Perl_PerlIO_or_fail(f, callback, failure, args) \
81	if (PerlIOValid(f)) { \
82	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
83	if (tab && tab->callback) \
84	return (*tab->callback) args; \
85	SETERRNO(EINVAL, LIB_INVARG); \
86	} \
87	else \
88	SETERRNO(EBADF, SS_IVCHAN); \
89	return failure
90
91	/* Call the callback or PerlIOBase, and be void. */
92	#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
93	if (PerlIOValid(f)) { \
94	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
95	if (tab && tab->callback) \
96	(*tab->callback) args; \
97	else \
98	PerlIOBase_ ## base args; \
99	} \
100	else \
101	SETERRNO(EBADF, SS_IVCHAN)
102
103	/* Call the callback or fail, and be void. */
104	#define Perl_PerlIO_or_fail_void(f, callback, args) \
105	if (PerlIOValid(f)) { \
106	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
107	if (tab && tab->callback) \
108	(*tab->callback) args; \
109	else \
110	SETERRNO(EINVAL, LIB_INVARG); \
111	} \
112	else \
113	SETERRNO(EBADF, SS_IVCHAN)
114
115	#ifndef USE_SFIO
116	int
117	perlsio_binmode(FILE *fp, int iotype, int mode)
118	{
119	/*
120	* This used to be contents of do_binmode in doio.c
121	*/
122	#ifdef DOSISH
123	# if defined(atarist) \|\| defined(__MINT__)
124	if (!fflush(fp)) {
125	if (mode & O_BINARY)
126	((FILE *) fp)->_flag \|= _IOBIN;
127	else
128	((FILE *) fp)->_flag &= ~_IOBIN;
129	return 1;
130	}
131	return 0;
132	# else
133	dTHX;
134	#ifdef NETWARE
135	if (PerlLIO_setmode(fp, mode) != -1) {
136	#else
137	if (PerlLIO_setmode(fileno(fp), mode) != -1) {
138	#endif
139	# if defined(WIN32) && defined(__BORLANDC__)
140	/*
141	* The translation mode of the stream is maintained independent of
142	* the translation mode of the fd in the Borland RTL (heavy
143	* digging through their runtime sources reveal). User has to set
144	* the mode explicitly for the stream (though they don't document
145	* this anywhere). GSAR 97-5-24
146	*/
147	fseek(fp, 0L, 0);
148	if (mode & O_BINARY)
149	fp->flags \|= _F_BIN;
150	else
151	fp->flags &= ~_F_BIN;
152	# endif
153	return 1;
154	}
155	else
156	return 0;
157	# endif
158	#else
159	# if defined(USEMYBINMODE)
160	dTHX;
161	if (my_binmode(fp, iotype, mode) != FALSE)
162	return 1;
163	else
164	return 0;
165	# else
166	PERL_UNUSED_ARG(fp);
167	PERL_UNUSED_ARG(iotype);
168	PERL_UNUSED_ARG(mode);
169	return 1;
170	# endif
171	#endif
172	}
173	#endif /* sfio */
174
175	#ifndef O_ACCMODE
176	#define O_ACCMODE 3 /* Assume traditional implementation */
177	#endif
178
179	int
180	PerlIO_intmode2str(int rawmode, char mode, int writing)
181	{
182	const int result = rawmode & O_ACCMODE;
183	int ix = 0;
184	int ptype;
185	switch (result) {
186	case O_RDONLY:
187	ptype = IoTYPE_RDONLY;
188	break;
189	case O_WRONLY:
190	ptype = IoTYPE_WRONLY;
191	break;
192	case O_RDWR:
193	default:
194	ptype = IoTYPE_RDWR;
195	break;
196	}
197	if (writing)
198	*writing = (result != O_RDONLY);
199
200	if (result == O_RDONLY) {
201	mode[ix++] = 'r';
202	}
203	#ifdef O_APPEND
204	else if (rawmode & O_APPEND) {
205	mode[ix++] = 'a';
206	if (result != O_WRONLY)
207	mode[ix++] = '+';
208	}
209	#endif
210	else {
211	if (result == O_WRONLY)
212	mode[ix++] = 'w';
213	else {
214	mode[ix++] = 'r';
215	mode[ix++] = '+';
216	}
217	}
218	if (rawmode & O_BINARY)
219	mode[ix++] = 'b';
220	mode[ix] = '\0';
221	return ptype;
222	}
223
224	#ifndef PERLIO_LAYERS
225	int
226	PerlIO_apply_layers(pTHX_ PerlIO f, const char mode, const char *names)
227	{
228	if (!names \|\| !*names
229	\|\| strEQ(names, ":crlf")
230	\|\| strEQ(names, ":raw")
231	\|\| strEQ(names, ":bytes")
232	) {
233	return 0;
234	}
235	Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
236	/*
237	* NOTREACHED
238	*/
239	return -1;
240	}
241
242	void
243	PerlIO_destruct(pTHX)
244	{
245	}
246
247	int
248	PerlIO_binmode(pTHX_ PerlIO fp, int iotype, int mode, const char names)
249	{
250	#ifdef USE_SFIO
251	PERL_UNUSED_ARG(iotype);
252	PERL_UNUSED_ARG(mode);
253	PERL_UNUSED_ARG(names);
254	return 1;
255	#else
256	return perlsio_binmode(fp, iotype, mode);
257	#endif
258	}
259
260	PerlIO *
261	PerlIO_fdupopen(pTHX_ PerlIO f, CLONE_PARAMS param, int flags)
262	{
263	#if defined(PERL_MICRO) \|\| defined(SYMBIAN)
264	return NULL;
265	#else
266	#ifdef PERL_IMPLICIT_SYS
267	return PerlSIO_fdupopen(f);
268	#else
269	#ifdef WIN32
270	return win32_fdupopen(f);
271	#else
272	if (f) {
273	const int fd = PerlLIO_dup(PerlIO_fileno(f));
274	if (fd >= 0) {
275	char mode[8];
276	int omode = fcntl(fd, F_GETFL);
277	#ifdef DJGPP
278	omode = djgpp_get_stream_mode(f);
279	#endif
280	PerlIO_intmode2str(omode,mode,NULL);
281	/* the r+ is a hack */
282	return PerlIO_fdopen(fd, mode);
283	}
284	return NULL;
285	}
286	else {
287	SETERRNO(EBADF, SS_IVCHAN);
288	}
289	#endif
290	return NULL;
291	#endif
292	#endif
293	}
294
295
296	/*
297	* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
298	*/
299
300	PerlIO *
301	PerlIO_openn(pTHX_ const char layers, const char mode, int fd,
302	int imode, int perm, PerlIO old, int narg, SV *args)
303	{
304	if (narg) {
305	if (narg > 1) {
306	Perl_croak(aTHX_ "More than one argument to open");
307	}
308	if (*args == &PL_sv_undef)
309	return PerlIO_tmpfile();
310	else {
311	const char name = SvPV_nolen_const(args);
312	if (*mode == IoTYPE_NUMERIC) {
313	fd = PerlLIO_open3(name, imode, perm);
314	if (fd >= 0)
315	return PerlIO_fdopen(fd, mode + 1);
316	}
317	else if (old) {
318	return PerlIO_reopen(name, mode, old);
319	}
320	else {
321	return PerlIO_open(name, mode);
322	}
323	}
324	}
325	else {
326	return PerlIO_fdopen(fd, (char *) mode);
327	}
328	return NULL;
329	}
330
331	XS(XS_PerlIO__Layer__find)
332	{
333	dXSARGS;
334	if (items < 2)
335	Perl_croak(aTHX_ "Usage class->find(name[,load])");
336	else {
337	const char *name = SvPV_nolen_const(ST(1));
338	ST(0) = (strEQ(name, "crlf")
339	\|\| strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
340	XSRETURN(1);
341	}
342	}
343
344
345	void
346	Perl_boot_core_PerlIO(pTHX)
347	{
348	newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
349	}
350
351	#endif
352
353
354	#ifdef PERLIO_IS_STDIO
355
356	void
357	PerlIO_init(pTHX)
358	{
359	/*
360	* Does nothing (yet) except force this file to be included in perl
361	* binary. That allows this file to force inclusion of other functions
362	* that may be required by loadable extensions e.g. for
363	* FileHandle::tmpfile
364	*/
365	}
366
367	#undef PerlIO_tmpfile
368	PerlIO *
369	PerlIO_tmpfile(void)
370	{
371	return tmpfile();
372	}
373
374	#else /* PERLIO_IS_STDIO */
375
376	#ifdef USE_SFIO
377
378	#undef HAS_FSETPOS
379	#undef HAS_FGETPOS
380
381	/*
382	* This section is just to make sure these functions get pulled in from
383	* libsfio.a
384	*/
385
386	#undef PerlIO_tmpfile
387	PerlIO *
388	PerlIO_tmpfile(void)
389	{
390	return sftmp(0);
391	}
392
393	void
394	PerlIO_init(pTHX)
395	{
396	/*
397	* Force this file to be included in perl binary. Which allows this
398	* file to force inclusion of other functions that may be required by
399	* loadable extensions e.g. for FileHandle::tmpfile
400	*/
401
402	/*
403	* Hack sfio does its own 'autoflush' on stdout in common cases. Flush
404	* results in a lot of lseek()s to regular files and lot of small
405	* writes to pipes.
406	*/
407	sfset(sfstdout, SF_SHARE, 0);
408	}
409
410	/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
411	PerlIO *
412	PerlIO_importFILE(FILE stdio, const char mode)
413	{
414	const int fd = fileno(stdio);
415	if (!mode \|\| !*mode) {
416	mode = "r+";
417	}
418	return PerlIO_fdopen(fd, mode);
419	}
420
421	FILE *
422	PerlIO_findFILE(PerlIO *pio)
423	{
424	const int fd = PerlIO_fileno(pio);
425	FILE * const f = fdopen(fd, "r+");
426	PerlIO_flush(pio);
427	if (!f && errno == EINVAL)
428	f = fdopen(fd, "w");
429	if (!f && errno == EINVAL)
430	f = fdopen(fd, "r");
431	return f;
432	}
433
434
435	#else /* USE_SFIO */
436	/======================================================================================/
437	/*
438	* Implement all the PerlIO interface ourselves.
439	*/
440
441	#include "perliol.h"
442
443	/*
444	* We _MUST_ have <unistd.h> if we are using lseek() and may have large
445	* files
446	*/
447	#ifdef I_UNISTD
448	#include <unistd.h>
449	#endif
450	#ifdef HAS_MMAP
451	#include <sys/mman.h>
452	#endif
453
454	void
455	PerlIO_debug(const char *fmt, ...)
456	{
457	static int dbg = 0;
458	va_list ap;
459	dSYS;
460	va_start(ap, fmt);
461	if (!dbg && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
462	const char *s = PerlEnv_getenv("PERLIO_DEBUG");
463	if (s && *s)
464	dbg = PerlLIO_open3(s, O_WRONLY \| O_CREAT \| O_APPEND, 0666);
465	else
466	dbg = -1;
467	}
468	if (dbg > 0) {
469	dTHX;
470	const char *s = CopFILE(PL_curcop);
471	STRLEN len;
472	#ifdef USE_ITHREADS
473	/* Use fixed buffer as sv_catpvf etc. needs SVs */
474	char buffer[1024];
475	if (!s)
476	s = "(none)";
477	len = sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
478	vsprintf(buffer+len, fmt, ap);
479	PerlLIO_write(dbg, buffer, strlen(buffer));
480	#else
481	SV *sv = newSVpvn("", 0);
482	if (!s)
483	s = "(none)";
484	Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
485	(IV) CopLINE(PL_curcop));
486	Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
487
488	s = SvPV_const(sv, len);
489	PerlLIO_write(dbg, s, len);
490	SvREFCNT_dec(sv);
491	#endif
492	}
493	va_end(ap);
494	}
495
496	/--------------------------------------------------------------------------------------/
497
498	/*
499	* Inner level routines
500	*/
501
502	/*
503	* Table of pointers to the PerlIO structs (malloc'ed)
504	*/
505	#define PERLIO_TABLE_SIZE 64
506
507	PerlIO *
508	PerlIO_allocate(pTHX)
509	{
510	/*
511	* Find a free slot in the table, allocating new table as necessary
512	*/
513	PerlIO **last;
514	PerlIO *f;
515	last = &PL_perlio;
516	while ((f = *last)) {
517	int i;
518	last = (PerlIO **) (f);
519	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
520	if (!*++f) {
521	return f;
522	}
523	}
524	}
525	Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
526	if (!f) {
527	return NULL;
528	}
529	*last = f;
530	return f + 1;
531	}
532
533	#undef PerlIO_fdupopen
534	PerlIO *
535	PerlIO_fdupopen(pTHX_ PerlIO f, CLONE_PARAMS param, int flags)
536	{
537	if (PerlIOValid(f)) {
538	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
539	PerlIO_debug("fdupopen f=%p param=%p\n",(void)f,(void)param);
540	if (tab && tab->Dup)
541	return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
542	else {
543	return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
544	}
545	}
546	else
547	SETERRNO(EBADF, SS_IVCHAN);
548
549	return NULL;
550	}
551
552	void
553	PerlIO_cleantable(pTHX_ PerlIO **tablep)
554	{
555	PerlIO table = tablep;
556	if (table) {
557	int i;
558	PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
559	for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
560	PerlIO *f = table + i;
561	if (*f) {
562	PerlIO_close(f);
563	}
564	}
565	Safefree(table);
566	*tablep = NULL;
567	}
568	}
569
570
571	PerlIO_list_t *
572	PerlIO_list_alloc(pTHX)
573	{
574	PerlIO_list_t *list;
575	Newxz(list, 1, PerlIO_list_t);
576	list->refcnt = 1;
577	return list;
578	}
579
580	void
581	PerlIO_list_free(pTHX_ PerlIO_list_t *list)
582	{
583	if (list) {
584	if (--list->refcnt == 0) {
585	if (list->array) {
586	IV i;
587	for (i = 0; i < list->cur; i++) {
588	if (list->array[i].arg)
589	SvREFCNT_dec(list->array[i].arg);
590	}
591	Safefree(list->array);
592	}
593	Safefree(list);
594	}
595	}
596	}
597
598	void
599	PerlIO_list_push(pTHX_ PerlIO_list_t list, PerlIO_funcs funcs, SV *arg)
600	{
601	PerlIO_pair_t *p;
602	if (list->cur >= list->len) {
603	list->len += 8;
604	if (list->array)
605	Renew(list->array, list->len, PerlIO_pair_t);
606	else
607	Newx(list->array, list->len, PerlIO_pair_t);
608	}
609	p = &(list->array[list->cur++]);
610	p->funcs = funcs;
611	if ((p->arg = arg)) {
612	(void)SvREFCNT_inc(arg);
613	}
614	}
615
616	PerlIO_list_t *
617	PerlIO_clone_list(pTHX_ PerlIO_list_t proto, CLONE_PARAMS param)
618	{
619	PerlIO_list_t list = (PerlIO_list_t ) NULL;
620	if (proto) {
621	int i;
622	list = PerlIO_list_alloc(aTHX);
623	for (i=0; i < proto->cur; i++) {
624	SV *arg = Nullsv;
625	if (proto->array[i].arg)
626	arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
627	PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
628	}
629	}
630	return list;
631	}
632
633	void
634	PerlIO_clone(pTHX_ PerlInterpreter proto, CLONE_PARAMS param)
635	{
636	#ifdef USE_ITHREADS
637	PerlIO **table = &proto->Iperlio;
638	PerlIO *f;
639	PL_perlio = NULL;
640	PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
641	PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
642	PerlIO_allocate(aTHX); /* root slot is never used */
643	PerlIO_debug("Clone %p from %p\n",aTHX,proto);
644	while ((f = *table)) {
645	int i;
646	table = (PerlIO **) (f++);
647	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
648	if (*f) {
649	(void) fp_dup(f, 0, param);
650	}
651	f++;
652	}
653	}
654	#else
655	PERL_UNUSED_ARG(proto);
656	PERL_UNUSED_ARG(param);
657	#endif
658	}
659
660	void
661	PerlIO_destruct(pTHX)
662	{
663	PerlIO **table = &PL_perlio;
664	PerlIO *f;
665	#ifdef USE_ITHREADS
666	PerlIO_debug("Destruct %p\n",aTHX);
667	#endif
668	while ((f = *table)) {
669	int i;
670	table = (PerlIO **) (f++);
671	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
672	PerlIO *x = f;
673	PerlIOl *l;
674	while ((l = *x)) {
675	if (l->tab->kind & PERLIO_K_DESTRUCT) {
676	PerlIO_debug("Destruct popping %s\n", l->tab->name);
677	PerlIO_flush(x);
678	PerlIO_pop(aTHX_ x);
679	}
680	else {
681	x = PerlIONext(x);
682	}
683	}
684	f++;
685	}
686	}
687	}
688
689	void
690	PerlIO_pop(pTHX_ PerlIO *f)
691	{
692	PerlIOl l = f;
693	if (l) {
694	PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
695	if (l->tab->Popped) {
696	/*
697	* If popped returns non-zero do not free its layer structure
698	* it has either done so itself, or it is shared and still in
699	* use
700	*/
701	if ((*l->tab->Popped) (aTHX_ f) != 0)
702	return;
703	}
704	*f = l->next;
705	Safefree(l);
706	}
707	}
708
709	/* Return as an array the stack of layers on a filehandle. Note that
710	* the stack is returned top-first in the array, and there are three
711	* times as many array elements as there are layers in the stack: the
712	* first element of a layer triplet is the name, the second one is the
713	* arguments, and the third one is the flags. */
714
715	AV *
716	PerlIO_get_layers(pTHX_ PerlIO *f)
717	{
718	AV *av = newAV();
719
720	if (PerlIOValid(f)) {
721	PerlIOl *l = PerlIOBase(f);
722
723	while (l) {
724	SV *name = l->tab && l->tab->name ?
725	newSVpv(l->tab->name, 0) : &PL_sv_undef;
726	SV *arg = l->tab && l->tab->Getarg ?
727	(*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
728	av_push(av, name);
729	av_push(av, arg);
730	av_push(av, newSViv((IV)l->flags));
731	l = l->next;
732	}
733	}
734
735	return av;
736	}
737
738	/--------------------------------------------------------------------------------------/
739	/*
740	* XS Interface for perl code
741	*/
742
743	PerlIO_funcs *
744	PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
745	{
746	IV i;
747	if ((SSize_t) len <= 0)
748	len = strlen(name);
749	for (i = 0; i < PL_known_layers->cur; i++) {
750	PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
751	if (memEQ(f->name, name, len) && f->name[len] == 0) {
752	PerlIO_debug("%.s => %p\n", (int) len, name, (void)f);
753	return f;
754	}
755	}
756	if (load && PL_subname && PL_def_layerlist
757	&& PL_def_layerlist->cur >= 2) {
758	if (PL_in_load_module) {
759	Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
760	return NULL;
761	} else {
762	SV * const pkgsv = newSVpvn("PerlIO", 6);
763	SV * const layer = newSVpvn(name, len);
764	CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
765	ENTER;
766	SAVEINT(PL_in_load_module);
767	if (cv) {
768	SAVEGENERICSV(PL_warnhook);
769	(void)SvREFCNT_inc(cv);
770	PL_warnhook = (SV *) cv;
771	}
772	PL_in_load_module++;
773	/*
774	* The two SVs are magically freed by load_module
775	*/
776	Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
777	PL_in_load_module--;
778	LEAVE;
779	return PerlIO_find_layer(aTHX_ name, len, 0);
780	}
781	}
782	PerlIO_debug("Cannot find %.*s\n", (int) len, name);
783	return NULL;
784	}
785
786	#ifdef USE_ATTRIBUTES_FOR_PERLIO
787
788	static int
789	perlio_mg_set(pTHX_ SV sv, MAGIC mg)
790	{
791	if (SvROK(sv)) {
792	IO io = GvIOn((GV ) SvRV(sv));
793	PerlIO *ifp = IoIFP(io);
794	PerlIO *ofp = IoOFP(io);
795	Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
796	}
797	return 0;
798	}
799
800	static int
801	perlio_mg_get(pTHX_ SV sv, MAGIC mg)
802	{
803	if (SvROK(sv)) {
804	IO io = GvIOn((GV ) SvRV(sv));
805	PerlIO *ifp = IoIFP(io);
806	PerlIO *ofp = IoOFP(io);
807	Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
808	}
809	return 0;
810	}
811
812	static int
813	perlio_mg_clear(pTHX_ SV sv, MAGIC mg)
814	{
815	Perl_warn(aTHX_ "clear %" SVf, sv);
816	return 0;
817	}
818
819	static int
820	perlio_mg_free(pTHX_ SV sv, MAGIC mg)
821	{
822	Perl_warn(aTHX_ "free %" SVf, sv);
823	return 0;
824	}
825
826	MGVTBL perlio_vtab = {
827	perlio_mg_get,
828	perlio_mg_set,
829	NULL, /* len */
830	perlio_mg_clear,
831	perlio_mg_free
832	};
833
834	XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
835	{
836	dXSARGS;
837	SV *sv = SvRV(ST(1));
838	AV *av = newAV();
839	MAGIC *mg;
840	int count = 0;
841	int i;
842	sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
843	SvRMAGICAL_off(sv);
844	mg = mg_find(sv, PERL_MAGIC_ext);
845	mg->mg_virtual = &perlio_vtab;
846	mg_magical(sv);
847	Perl_warn(aTHX_ "attrib %" SVf, sv);
848	for (i = 2; i < items; i++) {
849	STRLEN len;
850	const char *name = SvPV_const(ST(i), len);
851	SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
852	if (layer) {
853	av_push(av, SvREFCNT_inc(layer));
854	}
855	else {
856	ST(count) = ST(i);
857	count++;
858	}
859	}
860	SvREFCNT_dec(av);
861	XSRETURN(count);
862	}
863
864	#endif /* USE_ATTIBUTES_FOR_PERLIO */
865
866	SV *
867	PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
868	{
869	HV * const stash = gv_stashpv("PerlIO::Layer", TRUE);
870	SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
871	return sv;
872	}
873
874	XS(XS_PerlIO__Layer__NoWarnings)
875	{
876	/* This is used as a %SIG{__WARN__} handler to supress warnings
877	during loading of layers.
878	*/
879	dXSARGS;
880	if (items)
881	PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
882	XSRETURN(0);
883	}
884
885	XS(XS_PerlIO__Layer__find)
886	{
887	dXSARGS;
888	if (items < 2)
889	Perl_croak(aTHX_ "Usage class->find(name[,load])");
890	else {
891	STRLEN len;
892	const char * const name = SvPV_const(ST(1), len);
893	const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
894	PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
895	ST(0) =
896	(layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
897	&PL_sv_undef;
898	XSRETURN(1);
899	}
900	}
901
902	void
903	PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
904	{
905	if (!PL_known_layers)
906	PL_known_layers = PerlIO_list_alloc(aTHX);
907	PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
908	PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
909	}
910
911	int
912	PerlIO_parse_layers(pTHX_ PerlIO_list_t av, const char names)
913	{
914	if (names) {
915	const char *s = names;
916	while (*s) {
917	while (isSPACE(s) \|\| s == ':')
918	s++;
919	if (*s) {
920	STRLEN llen = 0;
921	const char *e = s;
922	const char *as = Nullch;
923	STRLEN alen = 0;
924	if (!isIDFIRST(*s)) {
925	/*
926	* Message is consistent with how attribute lists are
927	* passed. Even though this means "foo : : bar" is
928	* seen as an invalid separator character.
929	*/
930	const char q = ((*s == '\'') ? '"' : '\'');
931	if (ckWARN(WARN_LAYER))
932	Perl_warner(aTHX_ packWARN(WARN_LAYER),
933	"Invalid separator character %c%c%c in PerlIO layer specification %s",
934	q, *s, q, s);
935	SETERRNO(EINVAL, LIB_INVARG);
936	return -1;
937	}
938	do {
939	e++;
940	} while (isALNUM(*e));
941	llen = e - s;
942	if (*e == '(') {
943	int nesting = 1;
944	as = ++e;
945	while (nesting) {
946	switch (*e++) {
947	case ')':
948	if (--nesting == 0)
949	alen = (e - 1) - as;
950	break;
951	case '(':
952	++nesting;
953	break;
954	case '\\':
955	/*
956	* It's a nul terminated string, not allowed
957	* to \ the terminating null. Anything other
958	* character is passed over.
959	*/
960	if (*e++) {
961	break;
962	}
963	/*
964	* Drop through
965	*/
966	case '\0':
967	e--;
968	if (ckWARN(WARN_LAYER))
969	Perl_warner(aTHX_ packWARN(WARN_LAYER),
970	"Argument list not closed for PerlIO layer \"%.*s\"",
971	(int) (e - s), s);
972	return -1;
973	default:
974	/*
975	* boring.
976	*/
977	break;
978	}
979	}
980	}
981	if (e > s) {
982	PerlIO_funcs * const layer =
983	PerlIO_find_layer(aTHX_ s, llen, 1);
984	if (layer) {
985	PerlIO_list_push(aTHX_ av, layer,
986	(as) ? newSVpvn(as,
987	alen) :
988	&PL_sv_undef);
989	}
990	else {
991	if (ckWARN(WARN_LAYER))
992	Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
993	(int) llen, s);
994	return -1;
995	}
996	}
997	s = e;
998	}
999	}
1000	}
1001	return 0;
1002	}
1003
1004	void
1005	PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1006	{
1007	PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1008	#ifdef PERLIO_USING_CRLF
1009	tab = &PerlIO_crlf;
1010	#else
1011	if (PerlIO_stdio.Set_ptrcnt)
1012	tab = &PerlIO_stdio;
1013	#endif
1014	PerlIO_debug("Pushing %s\n", tab->name);
1015	PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1016	&PL_sv_undef);
1017	}
1018
1019	SV *
1020	PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1021	{
1022	return av->array[n].arg;
1023	}
1024
1025	PerlIO_funcs *
1026	PerlIO_layer_fetch(pTHX_ PerlIO_list_t av, IV n, PerlIO_funcs def)
1027	{
1028	if (n >= 0 && n < av->cur) {
1029	PerlIO_debug("Layer %" IVdf " is %s\n", n,
1030	av->array[n].funcs->name);
1031	return av->array[n].funcs;
1032	}
1033	if (!def)
1034	Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1035	return def;
1036	}
1037
1038	IV
1039	PerlIOPop_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
1040	{
1041	PERL_UNUSED_ARG(mode);
1042	PERL_UNUSED_ARG(arg);
1043	PERL_UNUSED_ARG(tab);
1044	if (PerlIOValid(f)) {
1045	PerlIO_flush(f);
1046	PerlIO_pop(aTHX_ f);
1047	return 0;
1048	}
1049	return -1;
1050	}
1051
1052	PERLIO_FUNCS_DECL(PerlIO_remove) = {
1053	sizeof(PerlIO_funcs),
1054	"pop",
1055	0,
1056	PERLIO_K_DUMMY \| PERLIO_K_UTF8,
1057	PerlIOPop_pushed,
1058	NULL,
1059	NULL,
1060	NULL,
1061	NULL,
1062	NULL,
1063	NULL,
1064	NULL,
1065	NULL,
1066	NULL,
1067	NULL,
1068	NULL,
1069	NULL,
1070	NULL, /* flush */
1071	NULL, /* fill */
1072	NULL,
1073	NULL,
1074	NULL,
1075	NULL,
1076	NULL, /* get_base */
1077	NULL, /* get_bufsiz */
1078	NULL, /* get_ptr */
1079	NULL, /* get_cnt */
1080	NULL, /* set_ptrcnt */
1081	};
1082
1083	PerlIO_list_t *
1084	PerlIO_default_layers(pTHX)
1085	{
1086	if (!PL_def_layerlist) {
1087	const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
1088	PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1089	PL_def_layerlist = PerlIO_list_alloc(aTHX);
1090	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1091	#if defined(WIN32)
1092	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1093	#if 0
1094	osLayer = &PerlIO_win32;
1095	#endif
1096	#endif
1097	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1098	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1099	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1100	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1101	#ifdef HAS_MMAP
1102	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1103	#endif
1104	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1105	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1106	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1107	PerlIO_list_push(aTHX_ PL_def_layerlist,
1108	PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1109	&PL_sv_undef);
1110	if (s) {
1111	PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1112	}
1113	else {
1114	PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1115	}
1116	}
1117	if (PL_def_layerlist->cur < 2) {
1118	PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1119	}
1120	return PL_def_layerlist;
1121	}
1122
1123	void
1124	Perl_boot_core_PerlIO(pTHX)
1125	{
1126	#ifdef USE_ATTRIBUTES_FOR_PERLIO
1127	newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1128	__FILE__);
1129	#endif
1130	newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1131	newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1132	}
1133
1134	PerlIO_funcs *
1135	PerlIO_default_layer(pTHX_ I32 n)
1136	{
1137	PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1138	if (n < 0)
1139	n += av->cur;
1140	return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1141	}
1142
1143	#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1144	#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1145
1146	void
1147	PerlIO_stdstreams(pTHX)
1148	{
1149	if (!PL_perlio) {
1150	PerlIO_allocate(aTHX);
1151	PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1152	PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1153	PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1154	}
1155	}
1156
1157	PerlIO *
1158	PerlIO_push(pTHX_ PerlIO f, PERLIO_FUNCS_DECL(tab), const char mode, SV arg)
1159	{
1160	if (tab->fsize != sizeof(PerlIO_funcs)) {
1161	mismatch:
1162	Perl_croak(aTHX_ "Layer does not match this perl");
1163	}
1164	if (tab->size) {
1165	PerlIOl *l;
1166	if (tab->size < sizeof(PerlIOl)) {
1167	goto mismatch;
1168	}
1169	/* Real layer with a data area */
1170	Newxc(l,tab->size,char,PerlIOl);
1171	if (l && f) {
1172	Zero(l, tab->size, char);
1173	l->next = *f;
1174	l->tab = (PerlIO_funcs*) tab;
1175	*f = l;
1176	PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1177	(mode) ? mode : "(Null)", (void*)arg);
1178	if (*l->tab->Pushed &&
1179	(l->tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs) tab) != 0) {
1180	PerlIO_pop(aTHX_ f);
1181	return NULL;
1182	}
1183	}
1184	}
1185	else if (f) {
1186	/* Pseudo-layer where push does its own stack adjust */
1187	PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1188	(mode) ? mode : "(Null)", (void*)arg);
1189	if (tab->Pushed &&
1190	(tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs) tab) != 0) {
1191	return NULL;
1192	}
1193	}
1194	return f;
1195	}
1196
1197	IV
1198	PerlIOBase_binmode(pTHX_ PerlIO *f)
1199	{
1200	if (PerlIOValid(f)) {
1201	/* Is layer suitable for raw stream ? */
1202	if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1203	/* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1204	PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1205	}
1206	else {
1207	/* Not suitable - pop it */
1208	PerlIO_pop(aTHX_ f);
1209	}
1210	return 0;
1211	}
1212	return -1;
1213	}
1214
1215	IV
1216	PerlIORaw_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
1217	{
1218	PERL_UNUSED_ARG(mode);
1219	PERL_UNUSED_ARG(arg);
1220	PERL_UNUSED_ARG(tab);
1221
1222	if (PerlIOValid(f)) {
1223	PerlIO *t;
1224	const PerlIOl *l;
1225	PerlIO_flush(f);
1226	/*
1227	* Strip all layers that are not suitable for a raw stream
1228	*/
1229	t = f;
1230	while (t && (l = *t)) {
1231	if (l->tab->Binmode) {
1232	/* Has a handler - normal case */
1233	if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1234	if (*t == l) {
1235	/* Layer still there - move down a layer */
1236	t = PerlIONext(t);
1237	}
1238	}
1239	else {
1240	return -1;
1241	}
1242	}
1243	else {
1244	/* No handler - pop it */
1245	PerlIO_pop(aTHX_ t);
1246	}
1247	}
1248	if (PerlIOValid(f)) {
1249	PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1250	return 0;
1251	}
1252	}
1253	return -1;
1254	}
1255
1256	int
1257	PerlIO_apply_layera(pTHX_ PerlIO f, const char mode,
1258	PerlIO_list_t *layers, IV n, IV max)
1259	{
1260	int code = 0;
1261	while (n < max) {
1262	PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1263	if (tab) {
1264	if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1265	code = -1;
1266	break;
1267	}
1268	}
1269	n++;
1270	}
1271	return code;
1272	}
1273
1274	int
1275	PerlIO_apply_layers(pTHX_ PerlIO f, const char mode, const char *names)
1276	{
1277	int code = 0;
1278	if (f && names) {
1279	PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1280	code = PerlIO_parse_layers(aTHX_ layers, names);
1281	if (code == 0) {
1282	code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1283	}
1284	PerlIO_list_free(aTHX_ layers);
1285	}
1286	return code;
1287	}
1288
1289
1290	/--------------------------------------------------------------------------------------/
1291	/*
1292	* Given the abstraction above the public API functions
1293	*/
1294
1295	int
1296	PerlIO_binmode(pTHX_ PerlIO f, int iotype, int mode, const char names)
1297	{
1298	PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1299	(PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1300	iotype, mode, (names) ? names : "(Null)");
1301
1302	if (names) {
1303	/* Do not flush etc. if (e.g.) switching encodings.
1304	if a pushed layer knows it needs to flush lower layers
1305	(for example :unix which is never going to call them)
1306	it can do the flush when it is pushed.
1307	*/
1308	return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1309	}
1310	else {
1311	/* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1312	#ifdef PERLIO_USING_CRLF
1313	/* Legacy binmode only has meaning if O_TEXT has a value distinct from
1314	O_BINARY so we can look for it in mode.
1315	*/
1316	if (!(mode & O_BINARY)) {
1317	/* Text mode */
1318	/* FIXME?: Looking down the layer stack seems wrong,
1319	but is a way of reaching past (say) an encoding layer
1320	to flip CRLF-ness of the layer(s) below
1321	*/
1322	while (*f) {
1323	/* Perhaps we should turn on bottom-most aware layer
1324	e.g. Ilya's idea that UNIX TTY could serve
1325	*/
1326	if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1327	if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1328	/* Not in text mode - flush any pending stuff and flip it */
1329	PerlIO_flush(f);
1330	PerlIOBase(f)->flags \|= PERLIO_F_CRLF;
1331	}
1332	/* Only need to turn it on in one layer so we are done */
1333	return TRUE;
1334	}
1335	f = PerlIONext(f);
1336	}
1337	/* Not finding a CRLF aware layer presumably means we are binary
1338	which is not what was requested - so we failed
1339	We _could_ push :crlf layer but so could caller
1340	*/
1341	return FALSE;
1342	}
1343	#endif
1344	/* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1345	So code that used to be here is now in PerlIORaw_pushed().
1346	*/
1347	return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), Nullch, Nullsv) ? TRUE : FALSE;
1348	}
1349	}
1350
1351	int
1352	PerlIO__close(pTHX_ PerlIO *f)
1353	{
1354	if (PerlIOValid(f)) {
1355	PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1356	if (tab && tab->Close)
1357	return (*tab->Close)(aTHX_ f);
1358	else
1359	return PerlIOBase_close(aTHX_ f);
1360	}
1361	else {
1362	SETERRNO(EBADF, SS_IVCHAN);
1363	return -1;
1364	}
1365	}
1366
1367	int
1368	Perl_PerlIO_close(pTHX_ PerlIO *f)
1369	{
1370	const int code = PerlIO__close(aTHX_ f);
1371	while (PerlIOValid(f)) {
1372	PerlIO_pop(aTHX_ f);
1373	}
1374	return code;
1375	}
1376
1377	int
1378	Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1379	{
1380	Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1381	}
1382
1383	static const char *
1384	PerlIO_context_layers(pTHX_ const char *mode)
1385	{
1386	const char *type = NULL;
1387	/*
1388	* Need to supply default layer info from open.pm
1389	*/
1390	if (PL_curcop) {
1391	SV *layers = PL_curcop->cop_io;
1392	if (layers) {
1393	STRLEN len;
1394	type = SvPV_const(layers, len);
1395	if (type && mode[0] != 'r') {
1396	/*
1397	* Skip to write part
1398	*/
1399	const char *s = strchr(type, 0);
1400	if (s && (STRLEN)(s - type) < len) {
1401	type = s + 1;
1402	}
1403	}
1404	}
1405	}
1406	return type;
1407	}
1408
1409	static PerlIO_funcs *
1410	PerlIO_layer_from_ref(pTHX_ SV *sv)
1411	{
1412	/*
1413	* For any scalar type load the handler which is bundled with perl
1414	*/
1415	if (SvTYPE(sv) < SVt_PVAV)
1416	return PerlIO_find_layer(aTHX_ "scalar", 6, 1);
1417
1418	/*
1419	* For other types allow if layer is known but don't try and load it
1420	*/
1421	switch (SvTYPE(sv)) {
1422	case SVt_PVAV:
1423	return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1424	case SVt_PVHV:
1425	return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1426	case SVt_PVCV:
1427	return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1428	case SVt_PVGV:
1429	return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1430	}
1431	return NULL;
1432	}
1433
1434	PerlIO_list_t *
1435	PerlIO_resolve_layers(pTHX_ const char *layers,
1436	const char mode, int narg, SV *args)
1437	{
1438	PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1439	int incdef = 1;
1440	if (!PL_perlio)
1441	PerlIO_stdstreams(aTHX);
1442	if (narg) {
1443	SV arg = args;
1444	/*
1445	* If it is a reference but not an object see if we have a handler
1446	* for it
1447	*/
1448	if (SvROK(arg) && !sv_isobject(arg)) {
1449	PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1450	if (handler) {
1451	def = PerlIO_list_alloc(aTHX);
1452	PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1453	incdef = 0;
1454	}
1455	/*
1456	* Don't fail if handler cannot be found :via(...) etc. may do
1457	* something sensible else we will just stringfy and open
1458	* resulting string.
1459	*/
1460	}
1461	}
1462	if (!layers \|\| !*layers)
1463	layers = PerlIO_context_layers(aTHX_ mode);
1464	if (layers && *layers) {
1465	PerlIO_list_t *av;
1466	if (incdef) {
1467	IV i;
1468	av = PerlIO_list_alloc(aTHX);
1469	for (i = 0; i < def->cur; i++) {
1470	PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1471	def->array[i].arg);
1472	}
1473	}
1474	else {
1475	av = def;
1476	}
1477	if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1478	return av;
1479	}
1480	else {
1481	PerlIO_list_free(aTHX_ av);
1482	return (PerlIO_list_t *) NULL;
1483	}
1484	}
1485	else {
1486	if (incdef)
1487	def->refcnt++;
1488	return def;
1489	}
1490	}
1491
1492	PerlIO *
1493	PerlIO_openn(pTHX_ const char layers, const char mode, int fd,
1494	int imode, int perm, PerlIO f, int narg, SV *args)
1495	{
1496	if (!f && narg == 1 && *args == &PL_sv_undef) {
1497	if ((f = PerlIO_tmpfile())) {
1498	if (!layers \|\| !*layers)
1499	layers = PerlIO_context_layers(aTHX_ mode);
1500	if (layers && *layers)
1501	PerlIO_apply_layers(aTHX_ f, mode, layers);
1502	}
1503	}
1504	else {
1505	PerlIO_list_t *layera;
1506	IV n;
1507	PerlIO_funcs *tab = NULL;
1508	if (PerlIOValid(f)) {
1509	/*
1510	* This is "reopen" - it is not tested as perl does not use it
1511	* yet
1512	*/
1513	PerlIOl l = f;
1514	layera = PerlIO_list_alloc(aTHX);
1515	while (l) {
1516	SV * const arg = (l->tab->Getarg)
1517	? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1518	: &PL_sv_undef;
1519	PerlIO_list_push(aTHX_ layera, l->tab, arg);
1520	l = *PerlIONext(&l);
1521	}
1522	}
1523	else {
1524	layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1525	if (!layera) {
1526	return NULL;
1527	}
1528	}
1529	/*
1530	* Start at "top" of layer stack
1531	*/
1532	n = layera->cur - 1;
1533	while (n >= 0) {
1534	PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1535	if (t && t->Open) {
1536	tab = t;
1537	break;
1538	}
1539	n--;
1540	}
1541	if (tab) {
1542	/*
1543	* Found that layer 'n' can do opens - call it
1544	*/
1545	if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1546	Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1547	}
1548	PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1549	tab->name, layers ? layers : "(Null)", mode, fd,
1550	imode, perm, (void)f, narg, (void)args);
1551	if (tab->Open)
1552	f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1553	f, narg, args);
1554	else {
1555	SETERRNO(EINVAL, LIB_INVARG);
1556	f = NULL;
1557	}
1558	if (f) {
1559	if (n + 1 < layera->cur) {
1560	/*
1561	* More layers above the one that we used to open -
1562	* apply them now
1563	*/
1564	if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1565	/* If pushing layers fails close the file */
1566	PerlIO_close(f);
1567	f = NULL;
1568	}
1569	}
1570	}
1571	}
1572	PerlIO_list_free(aTHX_ layera);
1573	}
1574	return f;
1575	}
1576
1577
1578	SSize_t
1579	Perl_PerlIO_read(pTHX_ PerlIO f, void vbuf, Size_t count)
1580	{
1581	Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1582	}
1583
1584	SSize_t
1585	Perl_PerlIO_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
1586	{
1587	Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1588	}
1589
1590	SSize_t
1591	Perl_PerlIO_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
1592	{
1593	Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1594	}
1595
1596	int
1597	Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1598	{
1599	Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1600	}
1601
1602	Off_t
1603	Perl_PerlIO_tell(pTHX_ PerlIO *f)
1604	{
1605	Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1606	}
1607
1608	int
1609	Perl_PerlIO_flush(pTHX_ PerlIO *f)
1610	{
1611	if (f) {
1612	if (*f) {
1613	const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1614
1615	if (tab && tab->Flush)
1616	return (*tab->Flush) (aTHX_ f);
1617	else
1618	return 0; /* If no Flush defined, silently succeed. */
1619	}
1620	else {
1621	PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1622	SETERRNO(EBADF, SS_IVCHAN);
1623	return -1;
1624	}
1625	}
1626	else {
1627	/*
1628	* Is it good API design to do flush-all on NULL, a potentially
1629	* errorneous input? Maybe some magical value (PerlIO*
1630	* PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1631	* things on fflush(NULL), but should we be bound by their design
1632	* decisions? --jhi
1633	*/
1634	PerlIO **table = &PL_perlio;
1635	int code = 0;
1636	while ((f = *table)) {
1637	int i;
1638	table = (PerlIO **) (f++);
1639	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1640	if (*f && PerlIO_flush(f) != 0)
1641	code = -1;
1642	f++;
1643	}
1644	}
1645	return code;
1646	}
1647	}
1648
1649	void
1650	PerlIOBase_flush_linebuf(pTHX)
1651	{
1652	PerlIO **table = &PL_perlio;
1653	PerlIO *f;
1654	while ((f = *table)) {
1655	int i;
1656	table = (PerlIO **) (f++);
1657	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1658	if (*f
1659	&& (PerlIOBase(f)->
1660	flags & (PERLIO_F_LINEBUF \| PERLIO_F_CANWRITE))
1661	== (PERLIO_F_LINEBUF \| PERLIO_F_CANWRITE))
1662	PerlIO_flush(f);
1663	f++;
1664	}
1665	}
1666	}
1667
1668	int
1669	Perl_PerlIO_fill(pTHX_ PerlIO *f)
1670	{
1671	Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1672	}
1673
1674	int
1675	PerlIO_isutf8(PerlIO *f)
1676	{
1677	if (PerlIOValid(f))
1678	return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1679	else
1680	SETERRNO(EBADF, SS_IVCHAN);
1681
1682	return -1;
1683	}
1684
1685	int
1686	Perl_PerlIO_eof(pTHX_ PerlIO *f)
1687	{
1688	Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1689	}
1690
1691	int
1692	Perl_PerlIO_error(pTHX_ PerlIO *f)
1693	{
1694	Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1695	}
1696
1697	void
1698	Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1699	{
1700	Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1701	}
1702
1703	void
1704	Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1705	{
1706	Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1707	}
1708
1709	int
1710	PerlIO_has_base(PerlIO *f)
1711	{
1712	if (PerlIOValid(f)) {
1713	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1714
1715	if (tab)
1716	return (tab->Get_base != NULL);
1717	SETERRNO(EINVAL, LIB_INVARG);
1718	}
1719	else
1720	SETERRNO(EBADF, SS_IVCHAN);
1721
1722	return 0;
1723	}
1724
1725	int
1726	PerlIO_fast_gets(PerlIO *f)
1727	{
1728	if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1729	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1730
1731	if (tab)
1732	return (tab->Set_ptrcnt != NULL);
1733	SETERRNO(EINVAL, LIB_INVARG);
1734	}
1735	else
1736	SETERRNO(EBADF, SS_IVCHAN);
1737
1738	return 0;
1739	}
1740
1741	int
1742	PerlIO_has_cntptr(PerlIO *f)
1743	{
1744	if (PerlIOValid(f)) {
1745	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1746
1747	if (tab)
1748	return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1749	SETERRNO(EINVAL, LIB_INVARG);
1750	}
1751	else
1752	SETERRNO(EBADF, SS_IVCHAN);
1753
1754	return 0;
1755	}
1756
1757	int
1758	PerlIO_canset_cnt(PerlIO *f)
1759	{
1760	if (PerlIOValid(f)) {
1761	const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1762
1763	if (tab)
1764	return (tab->Set_ptrcnt != NULL);
1765	SETERRNO(EINVAL, LIB_INVARG);
1766	}
1767	else
1768	SETERRNO(EBADF, SS_IVCHAN);
1769
1770	return 0;
1771	}
1772
1773	STDCHAR *
1774	Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1775	{
1776	Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1777	}
1778
1779	int
1780	Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1781	{
1782	Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1783	}
1784
1785	STDCHAR *
1786	Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1787	{
1788	Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1789	}
1790
1791	int
1792	Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1793	{
1794	Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1795	}
1796
1797	void
1798	Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1799	{
1800	Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1801	}
1802
1803	void
1804	Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO f, STDCHAR ptr, int cnt)
1805	{
1806	Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1807	}
1808
1809
1810	/--------------------------------------------------------------------------------------/
1811	/*
1812	* utf8 and raw dummy layers
1813	*/
1814
1815	IV
1816	PerlIOUtf8_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
1817	{
1818	PERL_UNUSED_ARG(mode);
1819	PERL_UNUSED_ARG(arg);
1820	if (PerlIOValid(f)) {
1821	if (tab->kind & PERLIO_K_UTF8)
1822	PerlIOBase(f)->flags \|= PERLIO_F_UTF8;
1823	else
1824	PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1825	return 0;
1826	}
1827	return -1;
1828	}
1829
1830	PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1831	sizeof(PerlIO_funcs),
1832	"utf8",
1833	0,
1834	PERLIO_K_DUMMY \| PERLIO_K_UTF8,
1835	PerlIOUtf8_pushed,
1836	NULL,
1837	NULL,
1838	NULL,
1839	NULL,
1840	NULL,
1841	NULL,
1842	NULL,
1843	NULL,
1844	NULL,
1845	NULL,
1846	NULL,
1847	NULL,
1848	NULL, /* flush */
1849	NULL, /* fill */
1850	NULL,
1851	NULL,
1852	NULL,
1853	NULL,
1854	NULL, /* get_base */
1855	NULL, /* get_bufsiz */
1856	NULL, /* get_ptr */
1857	NULL, /* get_cnt */
1858	NULL, /* set_ptrcnt */
1859	};
1860
1861	PERLIO_FUNCS_DECL(PerlIO_byte) = {
1862	sizeof(PerlIO_funcs),
1863	"bytes",
1864	0,
1865	PERLIO_K_DUMMY,
1866	PerlIOUtf8_pushed,
1867	NULL,
1868	NULL,
1869	NULL,
1870	NULL,
1871	NULL,
1872	NULL,
1873	NULL,
1874	NULL,
1875	NULL,
1876	NULL,
1877	NULL,
1878	NULL,
1879	NULL, /* flush */
1880	NULL, /* fill */
1881	NULL,
1882	NULL,
1883	NULL,
1884	NULL,
1885	NULL, /* get_base */
1886	NULL, /* get_bufsiz */
1887	NULL, /* get_ptr */
1888	NULL, /* get_cnt */
1889	NULL, /* set_ptrcnt */
1890	};
1891
1892	PerlIO *
1893	PerlIORaw_open(pTHX_ PerlIO_funcs self, PerlIO_list_t layers,
1894	IV n, const char *mode, int fd, int imode, int perm,
1895	PerlIO old, int narg, SV *args)
1896	{
1897	PerlIO_funcs * const tab = PerlIO_default_btm();
1898	PERL_UNUSED_ARG(self);
1899	if (tab && tab->Open)
1900	return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1901	old, narg, args);
1902	SETERRNO(EINVAL, LIB_INVARG);
1903	return NULL;
1904	}
1905
1906	PERLIO_FUNCS_DECL(PerlIO_raw) = {
1907	sizeof(PerlIO_funcs),
1908	"raw",
1909	0,
1910	PERLIO_K_DUMMY,
1911	PerlIORaw_pushed,
1912	PerlIOBase_popped,
1913	PerlIORaw_open,
1914	NULL,
1915	NULL,
1916	NULL,
1917	NULL,
1918	NULL,
1919	NULL,
1920	NULL,
1921	NULL,
1922	NULL,
1923	NULL,
1924	NULL, /* flush */
1925	NULL, /* fill */
1926	NULL,
1927	NULL,
1928	NULL,
1929	NULL,
1930	NULL, /* get_base */
1931	NULL, /* get_bufsiz */
1932	NULL, /* get_ptr */
1933	NULL, /* get_cnt */
1934	NULL, /* set_ptrcnt */
1935	};
1936	/--------------------------------------------------------------------------------------/
1937	/--------------------------------------------------------------------------------------/
1938	/*
1939	* "Methods" of the "base class"
1940	*/
1941
1942	IV
1943	PerlIOBase_fileno(pTHX_ PerlIO *f)
1944	{
1945	return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1946	}
1947
1948	char *
1949	PerlIO_modestr(PerlIO * f, char *buf)
1950	{
1951	char *s = buf;
1952	if (PerlIOValid(f)) {
1953	const IV flags = PerlIOBase(f)->flags;
1954	if (flags & PERLIO_F_APPEND) {
1955	*s++ = 'a';
1956	if (flags & PERLIO_F_CANREAD) {
1957	*s++ = '+';
1958	}
1959	}
1960	else if (flags & PERLIO_F_CANREAD) {
1961	*s++ = 'r';
1962	if (flags & PERLIO_F_CANWRITE)
1963	*s++ = '+';
1964	}
1965	else if (flags & PERLIO_F_CANWRITE) {
1966	*s++ = 'w';
1967	if (flags & PERLIO_F_CANREAD) {
1968	*s++ = '+';
1969	}
1970	}
1971	#ifdef PERLIO_USING_CRLF
1972	if (!(flags & PERLIO_F_CRLF))
1973	*s++ = 'b';
1974	#endif
1975	}
1976	*s = '\0';
1977	return buf;
1978	}
1979
1980
1981	IV
1982	PerlIOBase_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
1983	{
1984	PerlIOl * const l = PerlIOBase(f);
1985	PERL_UNUSED_ARG(arg);
1986
1987	l->flags &= ~(PERLIO_F_CANREAD \| PERLIO_F_CANWRITE \|
1988	PERLIO_F_TRUNCATE \| PERLIO_F_APPEND);
1989	if (tab->Set_ptrcnt != NULL)
1990	l->flags \|= PERLIO_F_FASTGETS;
1991	if (mode) {
1992	if (mode == IoTYPE_NUMERIC \|\| mode == IoTYPE_IMPLICIT)
1993	mode++;
1994	switch (*mode++) {
1995	case 'r':
1996	l->flags \|= PERLIO_F_CANREAD;
1997	break;
1998	case 'a':
1999	l->flags \|= PERLIO_F_APPEND \| PERLIO_F_CANWRITE;
2000	break;
2001	case 'w':
2002	l->flags \|= PERLIO_F_TRUNCATE \| PERLIO_F_CANWRITE;
2003	break;
2004	default:
2005	SETERRNO(EINVAL, LIB_INVARG);
2006	return -1;
2007	}
2008	while (*mode) {
2009	switch (*mode++) {
2010	case '+':
2011	l->flags \|= PERLIO_F_CANREAD \| PERLIO_F_CANWRITE;
2012	break;
2013	case 'b':
2014	l->flags &= ~PERLIO_F_CRLF;
2015	break;
2016	case 't':
2017	l->flags \|= PERLIO_F_CRLF;
2018	break;
2019	default:
2020	SETERRNO(EINVAL, LIB_INVARG);
2021	return -1;
2022	}
2023	}
2024	}
2025	else {
2026	if (l->next) {
2027	l->flags \|= l->next->flags &
2028	(PERLIO_F_CANREAD \| PERLIO_F_CANWRITE \| PERLIO_F_TRUNCATE \|
2029	PERLIO_F_APPEND);
2030	}
2031	}
2032	#if 0
2033	PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2034	f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2035	l->flags, PerlIO_modestr(f, temp));
2036	#endif
2037	return 0;
2038	}
2039
2040	IV
2041	PerlIOBase_popped(pTHX_ PerlIO *f)
2042	{
2043	PERL_UNUSED_ARG(f);
2044	return 0;
2045	}
2046
2047	SSize_t
2048	PerlIOBase_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
2049	{
2050	/*
2051	* Save the position as current head considers it
2052	*/
2053	const Off_t old = PerlIO_tell(f);
2054	PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", Nullsv);
2055	PerlIOSelf(f, PerlIOBuf)->posn = old;
2056	return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2057	}
2058
2059	SSize_t
2060	PerlIOBase_read(pTHX_ PerlIO f, void vbuf, Size_t count)
2061	{
2062	STDCHAR buf = (STDCHAR ) vbuf;
2063	if (f) {
2064	if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2065	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
2066	SETERRNO(EBADF, SS_IVCHAN);
2067	return 0;
2068	}
2069	while (count > 0) {
2070	get_cnt:
2071	{
2072	SSize_t avail = PerlIO_get_cnt(f);
2073	SSize_t take = 0;
2074	if (avail > 0)
2075	take = ((SSize_t)count < avail) ? count : avail;
2076	if (take > 0) {
2077	STDCHAR *ptr = PerlIO_get_ptr(f);
2078	Copy(ptr, buf, take, STDCHAR);
2079	PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2080	count -= take;
2081	buf += take;
2082	if (avail == 0) /* set_ptrcnt could have reset avail */
2083	goto get_cnt;
2084	}
2085	if (count > 0 && avail <= 0) {
2086	if (PerlIO_fill(f) != 0)
2087	break;
2088	}
2089	}
2090	}
2091	return (buf - (STDCHAR *) vbuf);
2092	}
2093	return 0;
2094	}
2095
2096	IV
2097	PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2098	{
2099	PERL_UNUSED_ARG(f);
2100	return 0;
2101	}
2102
2103	IV
2104	PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2105	{
2106	PERL_UNUSED_ARG(f);
2107	return -1;
2108	}
2109
2110	IV
2111	PerlIOBase_close(pTHX_ PerlIO *f)
2112	{
2113	IV code = -1;
2114	if (PerlIOValid(f)) {
2115	PerlIO *n = PerlIONext(f);
2116	code = PerlIO_flush(f);
2117	PerlIOBase(f)->flags &=
2118	~(PERLIO_F_CANREAD \| PERLIO_F_CANWRITE \| PERLIO_F_OPEN);
2119	while (PerlIOValid(n)) {
2120	const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2121	if (tab && tab->Close) {
2122	if ((*tab->Close)(aTHX_ n) != 0)
2123	code = -1;
2124	break;
2125	}
2126	else {
2127	PerlIOBase(n)->flags &=
2128	~(PERLIO_F_CANREAD \| PERLIO_F_CANWRITE \| PERLIO_F_OPEN);
2129	}
2130	n = PerlIONext(n);
2131	}
2132	}
2133	else {
2134	SETERRNO(EBADF, SS_IVCHAN);
2135	}
2136	return code;
2137	}
2138
2139	IV
2140	PerlIOBase_eof(pTHX_ PerlIO *f)
2141	{
2142	if (PerlIOValid(f)) {
2143	return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2144	}
2145	return 1;
2146	}
2147
2148	IV
2149	PerlIOBase_error(pTHX_ PerlIO *f)
2150	{
2151	if (PerlIOValid(f)) {
2152	return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2153	}
2154	return 1;
2155	}
2156
2157	void
2158	PerlIOBase_clearerr(pTHX_ PerlIO *f)
2159	{
2160	if (PerlIOValid(f)) {
2161	PerlIO *n = PerlIONext(f);
2162	PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR \| PERLIO_F_EOF);
2163	if (PerlIOValid(n))
2164	PerlIO_clearerr(n);
2165	}
2166	}
2167
2168	void
2169	PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2170	{
2171	if (PerlIOValid(f)) {
2172	PerlIOBase(f)->flags \|= PERLIO_F_LINEBUF;
2173	}
2174	}
2175
2176	SV *
2177	PerlIO_sv_dup(pTHX_ SV arg, CLONE_PARAMS param)
2178	{
2179	if (!arg)
2180	return Nullsv;
2181	#ifdef sv_dup
2182	if (param) {
2183	return sv_dup(arg, param);
2184	}
2185	else {
2186	return newSVsv(arg);
2187	}
2188	#else
2189	PERL_UNUSED_ARG(param);
2190	return newSVsv(arg);
2191	#endif
2192	}
2193
2194	PerlIO *
2195	PerlIOBase_dup(pTHX_ PerlIO f, PerlIO o, CLONE_PARAMS *param, int flags)
2196	{
2197	PerlIO * const nexto = PerlIONext(o);
2198	if (PerlIOValid(nexto)) {
2199	const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2200	if (tab && tab->Dup)
2201	f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2202	else
2203	f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2204	}
2205	if (f) {
2206	PerlIO_funcs *self = PerlIOBase(o)->tab;
2207	SV *arg;
2208	char buf[8];
2209	PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2210	self->name, (void)f, (void)o, (void*)param);
2211	if (self->Getarg)
2212	arg = (*self->Getarg)(aTHX_ o, param, flags);
2213	else {
2214	arg = Nullsv;
2215	}
2216	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2217	if (arg) {
2218	SvREFCNT_dec(arg);
2219	}
2220	}
2221	return f;
2222	}
2223
2224	#ifdef USE_THREADS
2225	perl_mutex PerlIO_mutex;
2226	#endif
2227	int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2228
2229	void
2230	PerlIO_init(pTHX)
2231	{
2232	/* Place holder for stdstreams call ??? */
2233	#ifdef USE_THREADS
2234	MUTEX_INIT(&PerlIO_mutex);
2235	#endif
2236	}
2237
2238	void
2239	PerlIOUnix_refcnt_inc(int fd)
2240	{
2241	if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2242	#ifdef USE_THREADS
2243	MUTEX_LOCK(&PerlIO_mutex);
2244	#endif
2245	PerlIO_fd_refcnt[fd]++;
2246	PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2247	#ifdef USE_THREADS
2248	MUTEX_UNLOCK(&PerlIO_mutex);
2249	#endif
2250	}
2251	}
2252
2253	int
2254	PerlIOUnix_refcnt_dec(int fd)
2255	{
2256	int cnt = 0;
2257	if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2258	#ifdef USE_THREADS
2259	MUTEX_LOCK(&PerlIO_mutex);
2260	#endif
2261	cnt = --PerlIO_fd_refcnt[fd];
2262	PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2263	#ifdef USE_THREADS
2264	MUTEX_UNLOCK(&PerlIO_mutex);
2265	#endif
2266	}
2267	return cnt;
2268	}
2269
2270	void
2271	PerlIO_cleanup(pTHX)
2272	{
2273	int i;
2274	#ifdef USE_ITHREADS
2275	PerlIO_debug("Cleanup layers for %p\n",aTHX);
2276	#else
2277	PerlIO_debug("Cleanup layers\n");
2278	#endif
2279	/* Raise STDIN..STDERR refcount so we don't close them */
2280	for (i=0; i < 3; i++)
2281	PerlIOUnix_refcnt_inc(i);
2282	PerlIO_cleantable(aTHX_ &PL_perlio);
2283	/* Restore STDIN..STDERR refcount */
2284	for (i=0; i < 3; i++)
2285	PerlIOUnix_refcnt_dec(i);
2286
2287	if (PL_known_layers) {
2288	PerlIO_list_free(aTHX_ PL_known_layers);
2289	PL_known_layers = NULL;
2290	}
2291	if (PL_def_layerlist) {
2292	PerlIO_list_free(aTHX_ PL_def_layerlist);
2293	PL_def_layerlist = NULL;
2294	}
2295	}
2296
2297
2298
2299	/--------------------------------------------------------------------------------------/
2300	/*
2301	* Bottom-most level for UNIX-like case
2302	*/
2303
2304	typedef struct {
2305	struct _PerlIO base; /* The generic part */
2306	int fd; /* UNIX like file descriptor */
2307	int oflags; /* open/fcntl flags */
2308	} PerlIOUnix;
2309
2310	int
2311	PerlIOUnix_oflags(const char *mode)
2312	{
2313	int oflags = -1;
2314	if (mode == IoTYPE_IMPLICIT \|\| mode == IoTYPE_NUMERIC)
2315	mode++;
2316	switch (*mode) {
2317	case 'r':
2318	oflags = O_RDONLY;
2319	if (*++mode == '+') {
2320	oflags = O_RDWR;
2321	mode++;
2322	}
2323	break;
2324
2325	case 'w':
2326	oflags = O_CREAT \| O_TRUNC;
2327	if (*++mode == '+') {
2328	oflags \|= O_RDWR;
2329	mode++;
2330	}
2331	else
2332	oflags \|= O_WRONLY;
2333	break;
2334
2335	case 'a':
2336	oflags = O_CREAT \| O_APPEND;
2337	if (*++mode == '+') {
2338	oflags \|= O_RDWR;
2339	mode++;
2340	}
2341	else
2342	oflags \|= O_WRONLY;
2343	break;
2344	}
2345	if (*mode == 'b') {
2346	oflags \|= O_BINARY;
2347	oflags &= ~O_TEXT;
2348	mode++;
2349	}
2350	else if (*mode == 't') {
2351	oflags \|= O_TEXT;
2352	oflags &= ~O_BINARY;
2353	mode++;
2354	}
2355	/*
2356	* Always open in binary mode
2357	*/
2358	oflags \|= O_BINARY;
2359	if (*mode \|\| oflags == -1) {
2360	SETERRNO(EINVAL, LIB_INVARG);
2361	oflags = -1;
2362	}
2363	return oflags;
2364	}
2365
2366	IV
2367	PerlIOUnix_fileno(pTHX_ PerlIO *f)
2368	{
2369	return PerlIOSelf(f, PerlIOUnix)->fd;
2370	}
2371
2372	static void
2373	PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2374	{
2375	PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2376	#if defined(WIN32)
2377	Stat_t st;
2378	if (PerlLIO_fstat(fd, &st) == 0) {
2379	if (!S_ISREG(st.st_mode)) {
2380	PerlIO_debug("%d is not regular file\n",fd);
2381	PerlIOBase(f)->flags \|= PERLIO_F_NOTREG;
2382	}
2383	else {
2384	PerlIO_debug("%d _is_ a regular file\n",fd);
2385	}
2386	}
2387	#endif
2388	s->fd = fd;
2389	s->oflags = imode;
2390	PerlIOUnix_refcnt_inc(fd);
2391	}
2392
2393	IV
2394	PerlIOUnix_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
2395	{
2396	IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2397	if (*PerlIONext(f)) {
2398	/* We never call down so do any pending stuff now */
2399	PerlIO_flush(PerlIONext(f));
2400	/*
2401	* XXX could (or should) we retrieve the oflags from the open file
2402	* handle rather than believing the "mode" we are passed in? XXX
2403	* Should the value on NULL mode be 0 or -1?
2404	*/
2405	PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2406	mode ? PerlIOUnix_oflags(mode) : -1);
2407	}
2408	PerlIOBase(f)->flags \|= PERLIO_F_OPEN;
2409
2410	return code;
2411	}
2412
2413	IV
2414	PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2415	{
2416	const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2417	Off_t new_loc;
2418	if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2419	#ifdef ESPIPE
2420	SETERRNO(ESPIPE, LIB_INVARG);
2421	#else
2422	SETERRNO(EINVAL, LIB_INVARG);
2423	#endif
2424	return -1;
2425	}
2426	new_loc = PerlLIO_lseek(fd, offset, whence);
2427	if (new_loc == (Off_t) - 1)
2428	{
2429	return -1;
2430	}
2431	PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2432	return 0;
2433	}
2434
2435	PerlIO *
2436	PerlIOUnix_open(pTHX_ PerlIO_funcs self, PerlIO_list_t layers,
2437	IV n, const char *mode, int fd, int imode,
2438	int perm, PerlIO f, int narg, SV *args)
2439	{
2440	if (PerlIOValid(f)) {
2441	if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2442	(*PerlIOBase(f)->tab->Close)(aTHX_ f);
2443	}
2444	if (narg > 0) {
2445	if (*mode == IoTYPE_NUMERIC)
2446	mode++;
2447	else {
2448	imode = PerlIOUnix_oflags(mode);
2449	perm = 0666;
2450	}
2451	if (imode != -1) {
2452	const char path = SvPV_nolen_const(args);
2453	fd = PerlLIO_open3(path, imode, perm);
2454	}
2455	}
2456	if (fd >= 0) {
2457	if (*mode == IoTYPE_IMPLICIT)
2458	mode++;
2459	if (!f) {
2460	f = PerlIO_allocate(aTHX);
2461	}
2462	if (!PerlIOValid(f)) {
2463	if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2464	return NULL;
2465	}
2466	}
2467	PerlIOUnix_setfd(aTHX_ f, fd, imode);
2468	PerlIOBase(f)->flags \|= PERLIO_F_OPEN;
2469	if (*mode == IoTYPE_APPEND)
2470	PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2471	return f;
2472	}
2473	else {
2474	if (f) {
2475	/*
2476	* FIXME: pop layers ???
2477	*/
2478	}
2479	return NULL;
2480	}
2481	}
2482
2483	PerlIO *
2484	PerlIOUnix_dup(pTHX_ PerlIO f, PerlIO o, CLONE_PARAMS *param, int flags)
2485	{
2486	PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2487	int fd = os->fd;
2488	if (flags & PERLIO_DUP_FD) {
2489	fd = PerlLIO_dup(fd);
2490	}
2491	if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2492	f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2493	if (f) {
2494	/* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2495	PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2496	return f;
2497	}
2498	}
2499	return NULL;
2500	}
2501
2502
2503	SSize_t
2504	PerlIOUnix_read(pTHX_ PerlIO f, void vbuf, Size_t count)
2505	{
2506	const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2507	#ifdef PERLIO_STD_SPECIAL
2508	if (fd == 0)
2509	return PERLIO_STD_IN(fd, vbuf, count);
2510	#endif
2511	if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) \|\|
2512	PerlIOBase(f)->flags & (PERLIO_F_EOF\|PERLIO_F_ERROR)) {
2513	return 0;
2514	}
2515	while (1) {
2516	const SSize_t len = PerlLIO_read(fd, vbuf, count);
2517	if (len >= 0 \|\| errno != EINTR) {
2518	if (len < 0) {
2519	if (errno != EAGAIN) {
2520	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
2521	}
2522	}
2523	else if (len == 0 && count != 0) {
2524	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
2525	SETERRNO(0,0);
2526	}
2527	return len;
2528	}
2529	PERL_ASYNC_CHECK();
2530	}
2531	/NOTREACHED/
2532	}
2533
2534	SSize_t
2535	PerlIOUnix_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
2536	{
2537	const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2538	#ifdef PERLIO_STD_SPECIAL
2539	if (fd == 1 \|\| fd == 2)
2540	return PERLIO_STD_OUT(fd, vbuf, count);
2541	#endif
2542	while (1) {
2543	const SSize_t len = PerlLIO_write(fd, vbuf, count);
2544	if (len >= 0 \|\| errno != EINTR) {
2545	if (len < 0) {
2546	if (errno != EAGAIN) {
2547	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
2548	}
2549	}
2550	return len;
2551	}
2552	PERL_ASYNC_CHECK();
2553	}
2554	/NOTREACHED/
2555	}
2556
2557	Off_t
2558	PerlIOUnix_tell(pTHX_ PerlIO *f)
2559	{
2560	return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2561	}
2562
2563
2564	IV
2565	PerlIOUnix_close(pTHX_ PerlIO *f)
2566	{
2567	const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2568	int code = 0;
2569	if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2570	if (PerlIOUnix_refcnt_dec(fd) > 0) {
2571	PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2572	return 0;
2573	}
2574	}
2575	else {
2576	SETERRNO(EBADF,SS_IVCHAN);
2577	return -1;
2578	}
2579	while (PerlLIO_close(fd) != 0) {
2580	if (errno != EINTR) {
2581	code = -1;
2582	break;
2583	}
2584	PERL_ASYNC_CHECK();
2585	}
2586	if (code == 0) {
2587	PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2588	}
2589	return code;
2590	}
2591
2592	PERLIO_FUNCS_DECL(PerlIO_unix) = {
2593	sizeof(PerlIO_funcs),
2594	"unix",
2595	sizeof(PerlIOUnix),
2596	PERLIO_K_RAW,
2597	PerlIOUnix_pushed,
2598	PerlIOBase_popped,
2599	PerlIOUnix_open,
2600	PerlIOBase_binmode, /* binmode */
2601	NULL,
2602	PerlIOUnix_fileno,
2603	PerlIOUnix_dup,
2604	PerlIOUnix_read,
2605	PerlIOBase_unread,
2606	PerlIOUnix_write,
2607	PerlIOUnix_seek,
2608	PerlIOUnix_tell,
2609	PerlIOUnix_close,
2610	PerlIOBase_noop_ok, /* flush */
2611	PerlIOBase_noop_fail, /* fill */
2612	PerlIOBase_eof,
2613	PerlIOBase_error,
2614	PerlIOBase_clearerr,
2615	PerlIOBase_setlinebuf,
2616	NULL, /* get_base */
2617	NULL, /* get_bufsiz */
2618	NULL, /* get_ptr */
2619	NULL, /* get_cnt */
2620	NULL, /* set_ptrcnt */
2621	};
2622
2623	/--------------------------------------------------------------------------------------/
2624	/*
2625	* stdio as a layer
2626	*/
2627
2628	#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2629	/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2630	broken by the last second glibc 2.3 fix
2631	*/
2632	#define STDIO_BUFFER_WRITABLE
2633	#endif
2634
2635
2636	typedef struct {
2637	struct _PerlIO base;
2638	FILE stdio; / The stream */
2639	} PerlIOStdio;
2640
2641	IV
2642	PerlIOStdio_fileno(pTHX_ PerlIO *f)
2643	{
2644	FILE *s;
2645	if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) {
2646	return PerlSIO_fileno(s);
2647	}
2648	errno = EBADF;
2649	return -1;
2650	}
2651
2652	char *
2653	PerlIOStdio_mode(const char mode, char tmode)
2654	{
2655	char * const ret = tmode;
2656	if (mode) {
2657	while (*mode) {
2658	tmode++ = mode++;
2659	}
2660	}
2661	#if defined(PERLIO_USING_CRLF) \|\| defined(__CYGWIN__)
2662	*tmode++ = 'b';
2663	#endif
2664	*tmode = '\0';
2665	return ret;
2666	}
2667
2668	IV
2669	PerlIOStdio_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
2670	{
2671	PerlIO *n;
2672	if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2673	PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2674	if (toptab == tab) {
2675	/* Top is already stdio - pop self (duplicate) and use original */
2676	PerlIO_pop(aTHX_ f);
2677	return 0;
2678	} else {
2679	const int fd = PerlIO_fileno(n);
2680	char tmode[8];
2681	FILE *stdio;
2682	if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2683	mode = PerlIOStdio_mode(mode, tmode)))) {
2684	PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2685	/* We never call down so do any pending stuff now */
2686	PerlIO_flush(PerlIONext(f));
2687	}
2688	else {
2689	return -1;
2690	}
2691	}
2692	}
2693	return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2694	}
2695
2696
2697	PerlIO *
2698	PerlIO_importFILE(FILE stdio, const char mode)
2699	{
2700	dTHX;
2701	PerlIO *f = NULL;
2702	if (stdio) {
2703	PerlIOStdio *s;
2704	if (!mode \|\| !*mode) {
2705	/* We need to probe to see how we can open the stream
2706	so start with read/write and then try write and read
2707	we dup() so that we can fclose without loosing the fd.
2708
2709	Note that the errno value set by a failing fdopen
2710	varies between stdio implementations.
2711	*/
2712	const int fd = PerlLIO_dup(fileno(stdio));
2713	FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2714	if (!f2) {
2715	f2 = PerlSIO_fdopen(fd, (mode = "w"));
2716	}
2717	if (!f2) {
2718	f2 = PerlSIO_fdopen(fd, (mode = "r"));
2719	}
2720	if (!f2) {
2721	/* Don't seem to be able to open */
2722	PerlLIO_close(fd);
2723	return f;
2724	}
2725	fclose(f2);
2726	}
2727	if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, Nullsv))) {
2728	s = PerlIOSelf(f, PerlIOStdio);
2729	s->stdio = stdio;
2730	}
2731	}
2732	return f;
2733	}
2734
2735	PerlIO *
2736	PerlIOStdio_open(pTHX_ PerlIO_funcs self, PerlIO_list_t layers,
2737	IV n, const char *mode, int fd, int imode,
2738	int perm, PerlIO f, int narg, SV *args)
2739	{
2740	char tmode[8];
2741	if (PerlIOValid(f)) {
2742	const char path = SvPV_nolen_const(args);
2743	PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2744	FILE *stdio;
2745	PerlIOUnix_refcnt_dec(fileno(s->stdio));
2746	stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2747	s->stdio);
2748	if (!s->stdio)
2749	return NULL;
2750	s->stdio = stdio;
2751	PerlIOUnix_refcnt_inc(fileno(s->stdio));
2752	return f;
2753	}
2754	else {
2755	if (narg > 0) {
2756	const char path = SvPV_nolen_const(args);
2757	if (*mode == IoTYPE_NUMERIC) {
2758	mode++;
2759	fd = PerlLIO_open3(path, imode, perm);
2760	}
2761	else {
2762	FILE *stdio;
2763	bool appended = FALSE;
2764	#ifdef __CYGWIN__
2765	/* Cygwin wants its 'b' early. */
2766	appended = TRUE;
2767	mode = PerlIOStdio_mode(mode, tmode);
2768	#endif
2769	stdio = PerlSIO_fopen(path, mode);
2770	if (stdio) {
2771	PerlIOStdio *s;
2772	if (!f) {
2773	f = PerlIO_allocate(aTHX);
2774	}
2775	if (!appended)
2776	mode = PerlIOStdio_mode(mode, tmode);
2777	f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2778	if (f) {
2779	s = PerlIOSelf(f, PerlIOStdio);
2780	s->stdio = stdio;
2781	PerlIOUnix_refcnt_inc(fileno(s->stdio));
2782	}
2783	return f;
2784	}
2785	else {
2786	return NULL;
2787	}
2788	}
2789	}
2790	if (fd >= 0) {
2791	FILE *stdio = NULL;
2792	int init = 0;
2793	if (*mode == IoTYPE_IMPLICIT) {
2794	init = 1;
2795	mode++;
2796	}
2797	if (init) {
2798	switch (fd) {
2799	case 0:
2800	stdio = PerlSIO_stdin;
2801	break;
2802	case 1:
2803	stdio = PerlSIO_stdout;
2804	break;
2805	case 2:
2806	stdio = PerlSIO_stderr;
2807	break;
2808	}
2809	}
2810	else {
2811	stdio = PerlSIO_fdopen(fd, mode =
2812	PerlIOStdio_mode(mode, tmode));
2813	}
2814	if (stdio) {
2815	if (!f) {
2816	f = PerlIO_allocate(aTHX);
2817	}
2818	if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2819	PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2820	s->stdio = stdio;
2821	PerlIOUnix_refcnt_inc(fileno(s->stdio));
2822	}
2823	return f;
2824	}
2825	}
2826	}
2827	return NULL;
2828	}
2829
2830	PerlIO *
2831	PerlIOStdio_dup(pTHX_ PerlIO f, PerlIO o, CLONE_PARAMS *param, int flags)
2832	{
2833	/* This assumes no layers underneath - which is what
2834	happens, but is not how I remember it. NI-S 2001/10/16
2835	*/
2836	if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2837	FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2838	const int fd = fileno(stdio);
2839	char mode[8];
2840	if (flags & PERLIO_DUP_FD) {
2841	const int dfd = PerlLIO_dup(fileno(stdio));
2842	if (dfd >= 0) {
2843	stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
2844	goto set_this;
2845	}
2846	else {
2847	/* FIXME: To avoid messy error recovery if dup fails
2848	re-use the existing stdio as though flag was not set
2849	*/
2850	}
2851	}
2852	stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
2853	set_this:
2854	PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2855	PerlIOUnix_refcnt_inc(fileno(stdio));
2856	}
2857	return f;
2858	}
2859
2860	static int
2861	PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
2862	{
2863	/* XXX this could use PerlIO_canset_fileno() and
2864	* PerlIO_set_fileno() support from Configure
2865	*/
2866	# if defined(__UCLIBC__)
2867	/* uClibc must come before glibc because it defines __GLIBC__ as well. */
2868	f->__filedes = -1;
2869	return 1;
2870	# elif defined(__GLIBC__)
2871	/* There may be a better way for GLIBC:
2872	- libio.h defines a flag to not close() on cleanup
2873	*/
2874	f->_fileno = -1;
2875	return 1;
2876	# elif defined(__sun__)
2877	# if defined(_LP64)
2878	/* On solaris, if _LP64 is defined, the FILE structure is this:
2879	*
2880	* struct FILE {
2881	* long __pad[16];
2882	* };
2883	*
2884	* It turns out that the fd is stored in the top 32 bits of
2885	* file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears
2886	* to contain a pointer or offset into another structure. All the
2887	* remaining fields are zero.
2888	*
2889	* We set the top bits to -1 (0xFFFFFFFF).
2890	*/
2891	f->__pad[4] \|= 0xffffffff00000000L;
2892	assert(fileno(f) == 0xffffffff);
2893	# else /* !defined(_LP64) */
2894	/* _file is just a unsigned char :-(
2895	Not clear why we dup() rather than using -1
2896	even if that would be treated as 0xFF - so will
2897	a dup fail ...
2898	*/
2899	f->_file = PerlLIO_dup(fileno(f));
2900	# endif /* defined(_LP64) */
2901	return 1;
2902	# elif defined(__hpux)
2903	f->__fileH = 0xff;
2904	f->__fileL = 0xff;
2905	return 1;
2906	/* Next one ->_file seems to be a reasonable fallback, i.e. if
2907	your platform does not have special entry try this one.
2908	[For OSF only have confirmation for Tru64 (alpha)
2909	but assume other OSFs will be similar.]
2910	*/
2911	# elif defined(_AIX) \|\| defined(__osf__) \|\| defined(__irix__)
2912	f->_file = -1;
2913	return 1;
2914	# elif defined(__FreeBSD__)
2915	/* There may be a better way on FreeBSD:
2916	- we could insert a dummy func in the _close function entry
2917	f->_close = (int ()(void )) dummy_close;
2918	*/
2919	f->_file = -1;
2920	return 1;
2921	# elif defined(__OpenBSD__)
2922	/* There may be a better way on OpenBSD:
2923	- we could insert a dummy func in the _close function entry
2924	f->_close = (int ()(void )) dummy_close;
2925	*/
2926	f->_file = -1;
2927	return 1;
2928	# elif defined(__EMX__)
2929	/* f->_flags &= ~_IOOPEN; / / Will leak stream->_buffer */
2930	f->_handle = -1;
2931	return 1;
2932	# elif defined(__CYGWIN__)
2933	/* There may be a better way on CYGWIN:
2934	- we could insert a dummy func in the _close function entry
2935	f->_close = (int ()(void )) dummy_close;
2936	*/
2937	f->_file = -1;
2938	return 1;
2939	# elif defined(WIN32)
2940	# if defined(__BORLANDC__)
2941	f->fd = PerlLIO_dup(fileno(f));
2942	# elif defined(UNDER_CE)
2943	/* WIN_CE does not have access to FILE internals, it hardly has FILE
2944	structure at all
2945	*/
2946	# else
2947	f->_file = -1;
2948	# endif
2949	return 1;
2950	# else
2951	#if 0
2952	/* Sarathy's code did this - we fall back to a dup/dup2 hack
2953	(which isn't thread safe) instead
2954	*/
2955	# error "Don't know how to set FILE.fileno on your platform"
2956	#endif
2957	PERL_UNUSED_ARG(f);
2958	return 0;
2959	# endif
2960	}
2961
2962	IV
2963	PerlIOStdio_close(pTHX_ PerlIO *f)
2964	{
2965	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2966	if (!stdio) {
2967	errno = EBADF;
2968	return -1;
2969	}
2970	else {
2971	const int fd = fileno(stdio);
2972	int socksfd = 0;
2973	int invalidate = 0;
2974	IV result = 0;
2975	int saveerr = 0;
2976	int dupfd = 0;
2977	#ifdef SOCKS5_VERSION_NAME
2978	/* Socks lib overrides close() but stdio isn't linked to
2979	that library (though we are) - so we must call close()
2980	on sockets on stdio's behalf.
2981	*/
2982	int optval;
2983	Sock_size_t optlen = sizeof(int);
2984	if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) {
2985	socksfd = 1;
2986	invalidate = 1;
2987	}
2988	#endif
2989	if (PerlIOUnix_refcnt_dec(fd) > 0) {
2990	/* File descriptor still in use */
2991	invalidate = 1;
2992	socksfd = 0;
2993	}
2994	if (invalidate) {
2995	/* For STD* handles don't close the stdio at all
2996	this is because we have shared the FILE * too
2997	*/
2998	if (stdio == stdin) {
2999	/* Some stdios are buggy fflush-ing inputs */
3000	return 0;
3001	}
3002	else if (stdio == stdout \|\| stdio == stderr) {
3003	return PerlIO_flush(f);
3004	}
3005	/* Tricky - must fclose(stdio) to free memory but not close(fd)
3006	Use Sarathy's trick from maint-5.6 to invalidate the
3007	fileno slot of the FILE *
3008	*/
3009	result = PerlIO_flush(f);
3010	saveerr = errno;
3011	if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
3012	dupfd = PerlLIO_dup(fd);
3013	}
3014	}
3015	result = PerlSIO_fclose(stdio);
3016	/* We treat error from stdio as success if we invalidated
3017	errno may NOT be expected EBADF
3018	*/
3019	if (invalidate && result != 0) {
3020	errno = saveerr;
3021	result = 0;
3022	}
3023	if (socksfd) {
3024	/* in SOCKS case let close() determine return value */
3025	result = close(fd);
3026	}
3027	if (dupfd) {
3028	PerlLIO_dup2(dupfd,fd);
3029	PerlLIO_close(dupfd);
3030	}
3031	return result;
3032	}
3033	}
3034
3035	SSize_t
3036	PerlIOStdio_read(pTHX_ PerlIO f, void vbuf, Size_t count)
3037	{
3038	FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
3039	SSize_t got = 0;
3040	for (;;) {
3041	if (count == 1) {
3042	STDCHAR buf = (STDCHAR ) vbuf;
3043	/*
3044	* Perl is expecting PerlIO_getc() to fill the buffer Linux's
3045	* stdio does not do that for fread()
3046	*/
3047	const int ch = PerlSIO_fgetc(s);
3048	if (ch != EOF) {
3049	*buf = ch;
3050	got = 1;
3051	}
3052	}
3053	else
3054	got = PerlSIO_fread(vbuf, 1, count, s);
3055	if (got == 0 && PerlSIO_ferror(s))
3056	got = -1;
3057	if (got >= 0 \|\| errno != EINTR)
3058	break;
3059	PERL_ASYNC_CHECK();
3060	SETERRNO(0,0); /* just in case */
3061	}
3062	return got;
3063	}
3064
3065	SSize_t
3066	PerlIOStdio_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
3067	{
3068	SSize_t unread = 0;
3069	FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
3070
3071	#ifdef STDIO_BUFFER_WRITABLE
3072	if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3073	STDCHAR buf = ((STDCHAR ) vbuf) + count;
3074	STDCHAR *base = PerlIO_get_base(f);
3075	SSize_t cnt = PerlIO_get_cnt(f);
3076	STDCHAR *ptr = PerlIO_get_ptr(f);
3077	SSize_t avail = ptr - base;
3078	if (avail > 0) {
3079	if (avail > count) {
3080	avail = count;
3081	}
3082	ptr -= avail;
3083	Move(buf-avail,ptr,avail,STDCHAR);
3084	count -= avail;
3085	unread += avail;
3086	PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3087	if (PerlSIO_feof(s) && unread >= 0)
3088	PerlSIO_clearerr(s);
3089	}
3090	}
3091	else
3092	#endif
3093	if (PerlIO_has_cntptr(f)) {
3094	/* We can get pointer to buffer but not its base
3095	Do ungetc() but check chars are ending up in the
3096	buffer
3097	*/
3098	STDCHAR eptr = (STDCHAR)PerlSIO_get_ptr(s);
3099	STDCHAR buf = ((STDCHAR ) vbuf) + count;
3100	while (count > 0) {
3101	const int ch = *--buf & 0xFF;
3102	if (ungetc(ch,s) != ch) {
3103	/* ungetc did not work */
3104	break;
3105	}
3106	if ((STDCHAR)PerlSIO_get_ptr(s) != --eptr \|\| ((eptr & 0xFF) != ch)) {
3107	/* Did not change pointer as expected */
3108	fgetc(s); /* get char back again */
3109	break;
3110	}
3111	/* It worked ! */
3112	count--;
3113	unread++;
3114	}
3115	}
3116
3117	if (count > 0) {
3118	unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3119	}
3120	return unread;
3121	}
3122
3123	SSize_t
3124	PerlIOStdio_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
3125	{
3126	SSize_t got;
3127	for (;;) {
3128	got = PerlSIO_fwrite(vbuf, 1, count,
3129	PerlIOSelf(f, PerlIOStdio)->stdio);
3130	if (got >= 0 \|\| errno != EINTR)
3131	break;
3132	PERL_ASYNC_CHECK();
3133	SETERRNO(0,0); /* just in case */
3134	}
3135	return got;
3136	}
3137
3138	IV
3139	PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3140	{
3141	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3142	return PerlSIO_fseek(stdio, offset, whence);
3143	}
3144
3145	Off_t
3146	PerlIOStdio_tell(pTHX_ PerlIO *f)
3147	{
3148	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3149	return PerlSIO_ftell(stdio);
3150	}
3151
3152	IV
3153	PerlIOStdio_flush(pTHX_ PerlIO *f)
3154	{
3155	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3156	if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3157	return PerlSIO_fflush(stdio);
3158	}
3159	else {
3160	#if 0
3161	/*
3162	* FIXME: This discards ungetc() and pre-read stuff which is not
3163	* right if this is just a "sync" from a layer above Suspect right
3164	* design is to do _this_ but not have layer above flush this
3165	* layer read-to-read
3166	*/
3167	/*
3168	* Not writeable - sync by attempting a seek
3169	*/
3170	int err = errno;
3171	if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3172	errno = err;
3173	#endif
3174	}
3175	return 0;
3176	}
3177
3178	IV
3179	PerlIOStdio_eof(pTHX_ PerlIO *f)
3180	{
3181	return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3182	}
3183
3184	IV
3185	PerlIOStdio_error(pTHX_ PerlIO *f)
3186	{
3187	return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3188	}
3189
3190	void
3191	PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3192	{
3193	PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3194	}
3195
3196	void
3197	PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3198	{
3199	#ifdef HAS_SETLINEBUF
3200	PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3201	#else
3202	PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
3203	#endif
3204	}
3205
3206	#ifdef FILE_base
3207	STDCHAR *
3208	PerlIOStdio_get_base(pTHX_ PerlIO *f)
3209	{
3210	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3211	return (STDCHAR*)PerlSIO_get_base(stdio);
3212	}
3213
3214	Size_t
3215	PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3216	{
3217	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3218	return PerlSIO_get_bufsiz(stdio);
3219	}
3220	#endif
3221
3222	#ifdef USE_STDIO_PTR
3223	STDCHAR *
3224	PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3225	{
3226	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3227	return (STDCHAR*)PerlSIO_get_ptr(stdio);
3228	}
3229
3230	SSize_t
3231	PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3232	{
3233	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3234	return PerlSIO_get_cnt(stdio);
3235	}
3236
3237	void
3238	PerlIOStdio_set_ptrcnt(pTHX_ PerlIO f, STDCHAR ptr, SSize_t cnt)
3239	{
3240	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3241	if (ptr != NULL) {
3242	#ifdef STDIO_PTR_LVALUE
3243	PerlSIO_set_ptr(stdio, (void)ptr); / LHS STDCHAR* cast non-portable */
3244	#ifdef STDIO_PTR_LVAL_SETS_CNT
3245	if (PerlSIO_get_cnt(stdio) != (cnt)) {
3246	assert(PerlSIO_get_cnt(stdio) == (cnt));
3247	}
3248	#endif
3249	#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3250	/*
3251	* Setting ptr _does_ change cnt - we are done
3252	*/
3253	return;
3254	#endif
3255	#else /* STDIO_PTR_LVALUE */
3256	PerlProc_abort();
3257	#endif /* STDIO_PTR_LVALUE */
3258	}
3259	/*
3260	* Now (or only) set cnt
3261	*/
3262	#ifdef STDIO_CNT_LVALUE
3263	PerlSIO_set_cnt(stdio, cnt);
3264	#else /* STDIO_CNT_LVALUE */
3265	#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3266	PerlSIO_set_ptr(stdio,
3267	PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3268	cnt));
3269	#else /* STDIO_PTR_LVAL_SETS_CNT */
3270	PerlProc_abort();
3271	#endif /* STDIO_PTR_LVAL_SETS_CNT */
3272	#endif /* STDIO_CNT_LVALUE */
3273	}
3274
3275
3276	#endif
3277
3278	IV
3279	PerlIOStdio_fill(pTHX_ PerlIO *f)
3280	{
3281	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3282	int c;
3283	/*
3284	* fflush()ing read-only streams can cause trouble on some stdio-s
3285	*/
3286	if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3287	if (PerlSIO_fflush(stdio) != 0)
3288	return EOF;
3289	}
3290	c = PerlSIO_fgetc(stdio);
3291	if (c == EOF)
3292	return EOF;
3293
3294	#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) \|\| defined(STDIO_PTR_LVAL_SETS_CNT)))
3295
3296	#ifdef STDIO_BUFFER_WRITABLE
3297	if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3298	/* Fake ungetc() to the real buffer in case system's ungetc
3299	goes elsewhere
3300	*/
3301	STDCHAR base = (STDCHAR)PerlSIO_get_base(stdio);
3302	SSize_t cnt = PerlSIO_get_cnt(stdio);
3303	STDCHAR ptr = (STDCHAR)PerlSIO_get_ptr(stdio);
3304	if (ptr == base+1) {
3305	*--ptr = (STDCHAR) c;
3306	PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3307	if (PerlSIO_feof(stdio))
3308	PerlSIO_clearerr(stdio);
3309	return 0;
3310	}
3311	}
3312	else
3313	#endif
3314	if (PerlIO_has_cntptr(f)) {
3315	STDCHAR ch = c;
3316	if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3317	return 0;
3318	}
3319	}
3320	#endif
3321
3322	#if defined(VMS)
3323	/* An ungetc()d char is handled separately from the regular
3324	* buffer, so we stuff it in the buffer ourselves.
3325	* Should never get called as should hit code above
3326	*/
3327	(--((stdio)->_ptr)) = (unsigned char) c;
3328	(*stdio)->_cnt++;
3329	#else
3330	/* If buffer snoop scheme above fails fall back to
3331	using ungetc().
3332	*/
3333	if (PerlSIO_ungetc(c, stdio) != c)
3334	return EOF;
3335	#endif
3336	return 0;
3337	}
3338
3339
3340
3341	PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3342	sizeof(PerlIO_funcs),
3343	"stdio",
3344	sizeof(PerlIOStdio),
3345	PERLIO_K_BUFFERED\|PERLIO_K_RAW,
3346	PerlIOStdio_pushed,
3347	PerlIOBase_popped,
3348	PerlIOStdio_open,
3349	PerlIOBase_binmode, /* binmode */
3350	NULL,
3351	PerlIOStdio_fileno,
3352	PerlIOStdio_dup,
3353	PerlIOStdio_read,
3354	PerlIOStdio_unread,
3355	PerlIOStdio_write,
3356	PerlIOStdio_seek,
3357	PerlIOStdio_tell,
3358	PerlIOStdio_close,
3359	PerlIOStdio_flush,
3360	PerlIOStdio_fill,
3361	PerlIOStdio_eof,
3362	PerlIOStdio_error,
3363	PerlIOStdio_clearerr,
3364	PerlIOStdio_setlinebuf,
3365	#ifdef FILE_base
3366	PerlIOStdio_get_base,
3367	PerlIOStdio_get_bufsiz,
3368	#else
3369	NULL,
3370	NULL,
3371	#endif
3372	#ifdef USE_STDIO_PTR
3373	PerlIOStdio_get_ptr,
3374	PerlIOStdio_get_cnt,
3375	# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3376	PerlIOStdio_set_ptrcnt,
3377	# else
3378	NULL,
3379	# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3380	#else
3381	NULL,
3382	NULL,
3383	NULL,
3384	#endif /* USE_STDIO_PTR */
3385	};
3386
3387	/* Note that calls to PerlIO_exportFILE() are reversed using
3388	* PerlIO_releaseFILE(), not importFILE. */
3389	FILE *
3390	PerlIO_exportFILE(PerlIO * f, const char *mode)
3391	{
3392	dTHX;
3393	FILE *stdio = NULL;
3394	if (PerlIOValid(f)) {
3395	char buf[8];
3396	PerlIO_flush(f);
3397	if (!mode \|\| !*mode) {
3398	mode = PerlIO_modestr(f, buf);
3399	}
3400	stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3401	if (stdio) {
3402	PerlIOl l = f;
3403	PerlIO *f2;
3404	/* De-link any lower layers so new :stdio sticks */
3405	*f = NULL;
3406	if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, Nullsv))) {
3407	PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3408	s->stdio = stdio;
3409	/* Link previous lower layers under new one */
3410	*PerlIONext(f) = l;
3411	}
3412	else {
3413	/* restore layers list */
3414	*f = l;
3415	}
3416	}
3417	}
3418	return stdio;
3419	}
3420
3421
3422	FILE *
3423	PerlIO_findFILE(PerlIO *f)
3424	{
3425	PerlIOl l = f;
3426	while (l) {
3427	if (l->tab == &PerlIO_stdio) {
3428	PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3429	return s->stdio;
3430	}
3431	l = *PerlIONext(&l);
3432	}
3433	/* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3434	return PerlIO_exportFILE(f, Nullch);
3435	}
3436
3437	/* Use this to reverse PerlIO_exportFILE calls. */
3438	void
3439	PerlIO_releaseFILE(PerlIO p, FILE f)
3440	{
3441	PerlIOl *l;
3442	while ((l = *p)) {
3443	if (l->tab == &PerlIO_stdio) {
3444	PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3445	if (s->stdio == f) {
3446	dTHX;
3447	PerlIO_pop(aTHX_ p);
3448	return;
3449	}
3450	}
3451	p = PerlIONext(p);
3452	}
3453	return;
3454	}
3455
3456	/--------------------------------------------------------------------------------------/
3457	/*
3458	* perlio buffer layer
3459	*/
3460
3461	IV
3462	PerlIOBuf_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
3463	{
3464	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3465	const int fd = PerlIO_fileno(f);
3466	if (fd >= 0 && PerlLIO_isatty(fd)) {
3467	PerlIOBase(f)->flags \|= PERLIO_F_LINEBUF \| PERLIO_F_TTY;
3468	}
3469	if (*PerlIONext(f)) {
3470	const Off_t posn = PerlIO_tell(PerlIONext(f));
3471	if (posn != (Off_t) - 1) {
3472	b->posn = posn;
3473	}
3474	}
3475	return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3476	}
3477
3478	PerlIO *
3479	PerlIOBuf_open(pTHX_ PerlIO_funcs self, PerlIO_list_t layers,
3480	IV n, const char *mode, int fd, int imode, int perm,
3481	PerlIO f, int narg, SV *args)
3482	{
3483	if (PerlIOValid(f)) {
3484	PerlIO *next = PerlIONext(f);
3485	PerlIO_funcs *tab =
3486	PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3487	if (tab && tab->Open)
3488	next =
3489	(*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3490	next, narg, args);
3491	if (!next \|\| (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3492	return NULL;
3493	}
3494	}
3495	else {
3496	PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3497	int init = 0;
3498	if (*mode == IoTYPE_IMPLICIT) {
3499	init = 1;
3500	/*
3501	* mode++;
3502	*/
3503	}
3504	if (tab && tab->Open)
3505	f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3506	f, narg, args);
3507	else
3508	SETERRNO(EINVAL, LIB_INVARG);
3509	if (f) {
3510	if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3511	/*
3512	* if push fails during open, open fails. close will pop us.
3513	*/
3514	PerlIO_close (f);
3515	return NULL;
3516	} else {
3517	fd = PerlIO_fileno(f);
3518	if (init && fd == 2) {
3519	/*
3520	* Initial stderr is unbuffered
3521	*/
3522	PerlIOBase(f)->flags \|= PERLIO_F_UNBUF;
3523	}
3524	#ifdef PERLIO_USING_CRLF
3525	# ifdef PERLIO_IS_BINMODE_FD
3526	if (PERLIO_IS_BINMODE_FD(fd))
3527	PerlIO_binmode(aTHX_ f, '<'/not used/, O_BINARY, Nullch);
3528	else
3529	# endif
3530	/*
3531	* do something about failing setmode()? --jhi
3532	*/
3533	PerlLIO_setmode(fd, O_BINARY);
3534	#endif
3535	}
3536	}
3537	}
3538	return f;
3539	}
3540
3541	/*
3542	* This "flush" is akin to sfio's sync in that it handles files in either
3543	* read or write state. For write state, we put the postponed data through
3544	* the next layers. For read state, we seek() the next layers to the
3545	* offset given by current position in the buffer, and discard the buffer
3546	* state (XXXX supposed to be for seek()able buffers only, but now it is done
3547	* in any case?). Then the pass the stick further in chain.
3548	*/
3549	IV
3550	PerlIOBuf_flush(pTHX_ PerlIO *f)
3551	{
3552	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3553	int code = 0;
3554	PerlIO *n = PerlIONext(f);
3555	if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3556	/*
3557	* write() the buffer
3558	*/
3559	const STDCHAR *buf = b->buf;
3560	const STDCHAR *p = buf;
3561	while (p < b->ptr) {
3562	SSize_t count = PerlIO_write(n, p, b->ptr - p);
3563	if (count > 0) {
3564	p += count;
3565	}
3566	else if (count < 0 \|\| PerlIO_error(n)) {
3567	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
3568	code = -1;
3569	break;
3570	}
3571	}
3572	b->posn += (p - buf);
3573	}
3574	else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3575	STDCHAR *buf = PerlIO_get_base(f);
3576	/*
3577	* Note position change
3578	*/
3579	b->posn += (b->ptr - buf);
3580	if (b->ptr < b->end) {
3581	/* We did not consume all of it - try and seek downstream to
3582	our logical position
3583	*/
3584	if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3585	/* Reload n as some layers may pop themselves on seek */
3586	b->posn = PerlIO_tell(n = PerlIONext(f));
3587	}
3588	else {
3589	/* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3590	data is lost for good - so return saying "ok" having undone
3591	the position adjust
3592	*/
3593	b->posn -= (b->ptr - buf);
3594	return code;
3595	}
3596	}
3597	}
3598	b->ptr = b->end = b->buf;
3599	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
3600	/* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3601	if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3602	code = -1;
3603	return code;
3604	}
3605
3606	/* This discards the content of the buffer after b->ptr, and rereads
3607	* the buffer from the position off in the layer downstream; here off
3608	* is at offset corresponding to b->ptr - b->buf.
3609	*/
3610	IV
3611	PerlIOBuf_fill(pTHX_ PerlIO *f)
3612	{
3613	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3614	PerlIO *n = PerlIONext(f);
3615	SSize_t avail;
3616	/*
3617	* Down-stream flush is defined not to loose read data so is harmless.
3618	* we would not normally be fill'ing if there was data left in anycase.
3619	*/
3620	if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3621	return -1;
3622	if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3623	PerlIOBase_flush_linebuf(aTHX);
3624
3625	if (!b->buf)
3626	PerlIO_get_base(f); /* allocate via vtable */
3627
3628	b->ptr = b->end = b->buf;
3629
3630	if (!PerlIOValid(n)) {
3631	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
3632	return -1;
3633	}
3634
3635	if (PerlIO_fast_gets(n)) {
3636	/*
3637	* Layer below is also buffered. We do _NOT_ want to call its
3638	* ->Read() because that will loop till it gets what we asked for
3639	* which may hang on a pipe etc. Instead take anything it has to
3640	* hand, or ask it to fill _once_.
3641	*/
3642	avail = PerlIO_get_cnt(n);
3643	if (avail <= 0) {
3644	avail = PerlIO_fill(n);
3645	if (avail == 0)
3646	avail = PerlIO_get_cnt(n);
3647	else {
3648	if (!PerlIO_error(n) && PerlIO_eof(n))
3649	avail = 0;
3650	}
3651	}
3652	if (avail > 0) {
3653	STDCHAR *ptr = PerlIO_get_ptr(n);
3654	SSize_t cnt = avail;
3655	if (avail > (SSize_t)b->bufsiz)
3656	avail = b->bufsiz;
3657	Copy(ptr, b->buf, avail, STDCHAR);
3658	PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3659	}
3660	}
3661	else {
3662	avail = PerlIO_read(n, b->ptr, b->bufsiz);
3663	}
3664	if (avail <= 0) {
3665	if (avail == 0)
3666	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
3667	else
3668	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
3669	return -1;
3670	}
3671	b->end = b->buf + avail;
3672	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
3673	return 0;
3674	}
3675
3676	SSize_t
3677	PerlIOBuf_read(pTHX_ PerlIO f, void vbuf, Size_t count)
3678	{
3679	if (PerlIOValid(f)) {
3680	const PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3681	if (!b->ptr)
3682	PerlIO_get_base(f);
3683	return PerlIOBase_read(aTHX_ f, vbuf, count);
3684	}
3685	return 0;
3686	}
3687
3688	SSize_t
3689	PerlIOBuf_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
3690	{
3691	const STDCHAR buf = (const STDCHAR ) vbuf + count;
3692	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3693	SSize_t unread = 0;
3694	SSize_t avail;
3695	if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3696	PerlIO_flush(f);
3697	if (!b->buf)
3698	PerlIO_get_base(f);
3699	if (b->buf) {
3700	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3701	/*
3702	* Buffer is already a read buffer, we can overwrite any chars
3703	* which have been read back to buffer start
3704	*/
3705	avail = (b->ptr - b->buf);
3706	}
3707	else {
3708	/*
3709	* Buffer is idle, set it up so whole buffer is available for
3710	* unread
3711	*/
3712	avail = b->bufsiz;
3713	b->end = b->buf + avail;
3714	b->ptr = b->end;
3715	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
3716	/*
3717	* Buffer extends _back_ from where we are now
3718	*/
3719	b->posn -= b->bufsiz;
3720	}
3721	if (avail > (SSize_t) count) {
3722	/*
3723	* If we have space for more than count, just move count
3724	*/
3725	avail = count;
3726	}
3727	if (avail > 0) {
3728	b->ptr -= avail;
3729	buf -= avail;
3730	/*
3731	* In simple stdio-like ungetc() case chars will be already
3732	* there
3733	*/
3734	if (buf != b->ptr) {
3735	Copy(buf, b->ptr, avail, STDCHAR);
3736	}
3737	count -= avail;
3738	unread += avail;
3739	PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3740	}
3741	}
3742	if (count > 0) {
3743	unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3744	}
3745	return unread;
3746	}
3747
3748	SSize_t
3749	PerlIOBuf_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
3750	{
3751	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3752	const STDCHAR buf = (const STDCHAR ) vbuf;
3753	const STDCHAR *flushptr = buf;
3754	Size_t written = 0;
3755	if (!b->buf)
3756	PerlIO_get_base(f);
3757	if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3758	return 0;
3759	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3760	if (PerlIO_flush(f) != 0) {
3761	return 0;
3762	}
3763	}
3764	if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3765	flushptr = buf + count;
3766	while (flushptr > buf && *(flushptr - 1) != '\n')
3767	--flushptr;
3768	}
3769	while (count > 0) {
3770	SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3771	if ((SSize_t) count < avail)
3772	avail = count;
3773	if (flushptr > buf && flushptr <= buf + avail)
3774	avail = flushptr - buf;
3775	PerlIOBase(f)->flags \|= PERLIO_F_WRBUF;
3776	if (avail) {
3777	Copy(buf, b->ptr, avail, STDCHAR);
3778	count -= avail;
3779	buf += avail;
3780	written += avail;
3781	b->ptr += avail;
3782	if (buf == flushptr)
3783	PerlIO_flush(f);
3784	}
3785	if (b->ptr >= (b->buf + b->bufsiz))
3786	PerlIO_flush(f);
3787	}
3788	if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3789	PerlIO_flush(f);
3790	return written;
3791	}
3792
3793	IV
3794	PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3795	{
3796	IV code;
3797	if ((code = PerlIO_flush(f)) == 0) {
3798	PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3799	code = PerlIO_seek(PerlIONext(f), offset, whence);
3800	if (code == 0) {
3801	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3802	b->posn = PerlIO_tell(PerlIONext(f));
3803	}
3804	}
3805	return code;
3806	}
3807
3808	Off_t
3809	PerlIOBuf_tell(pTHX_ PerlIO *f)
3810	{
3811	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3812	/*
3813	* b->posn is file position where b->buf was read, or will be written
3814	*/
3815	Off_t posn = b->posn;
3816	if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
3817	(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3818	#if 1
3819	/* As O_APPEND files are normally shared in some sense it is better
3820	to flush :
3821	*/
3822	PerlIO_flush(f);
3823	#else
3824	/* when file is NOT shared then this is sufficient */
3825	PerlIO_seek(PerlIONext(f),0, SEEK_END);
3826	#endif
3827	posn = b->posn = PerlIO_tell(PerlIONext(f));
3828	}
3829	if (b->buf) {
3830	/*
3831	* If buffer is valid adjust position by amount in buffer
3832	*/
3833	posn += (b->ptr - b->buf);
3834	}
3835	return posn;
3836	}
3837
3838	IV
3839	PerlIOBuf_popped(pTHX_ PerlIO *f)
3840	{
3841	const IV code = PerlIOBase_popped(aTHX_ f);
3842	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3843	if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3844	Safefree(b->buf);
3845	}
3846	b->buf = NULL;
3847	b->ptr = b->end = b->buf;
3848	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
3849	return code;
3850	}
3851
3852	IV
3853	PerlIOBuf_close(pTHX_ PerlIO *f)
3854	{
3855	const IV code = PerlIOBase_close(aTHX_ f);
3856	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3857	if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3858	Safefree(b->buf);
3859	}
3860	b->buf = NULL;
3861	b->ptr = b->end = b->buf;
3862	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
3863	return code;
3864	}
3865
3866	STDCHAR *
3867	PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3868	{
3869	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3870	if (!b->buf)
3871	PerlIO_get_base(f);
3872	return b->ptr;
3873	}
3874
3875	SSize_t
3876	PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3877	{
3878	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3879	if (!b->buf)
3880	PerlIO_get_base(f);
3881	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3882	return (b->end - b->ptr);
3883	return 0;
3884	}
3885
3886	STDCHAR *
3887	PerlIOBuf_get_base(pTHX_ PerlIO *f)
3888	{
3889	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3890	if (!b->buf) {
3891	if (!b->bufsiz)
3892	b->bufsiz = 4096;
3893	b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
3894	if (!b->buf) {
3895	b->buf = (STDCHAR *) & b->oneword;
3896	b->bufsiz = sizeof(b->oneword);
3897	}
3898	b->ptr = b->buf;
3899	b->end = b->ptr;
3900	}
3901	return b->buf;
3902	}
3903
3904	Size_t
3905	PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3906	{
3907	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3908	if (!b->buf)
3909	PerlIO_get_base(f);
3910	return (b->end - b->buf);
3911	}
3912
3913	void
3914	PerlIOBuf_set_ptrcnt(pTHX_ PerlIO f, STDCHAR ptr, SSize_t cnt)
3915	{
3916	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3917	if (!b->buf)
3918	PerlIO_get_base(f);
3919	b->ptr = ptr;
3920	if (PerlIO_get_cnt(f) != cnt \|\| b->ptr < b->buf) {
3921	assert(PerlIO_get_cnt(f) == cnt);
3922	assert(b->ptr >= b->buf);
3923	}
3924	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
3925	}
3926
3927	PerlIO *
3928	PerlIOBuf_dup(pTHX_ PerlIO f, PerlIO o, CLONE_PARAMS *param, int flags)
3929	{
3930	return PerlIOBase_dup(aTHX_ f, o, param, flags);
3931	}
3932
3933
3934
3935	PERLIO_FUNCS_DECL(PerlIO_perlio) = {
3936	sizeof(PerlIO_funcs),
3937	"perlio",
3938	sizeof(PerlIOBuf),
3939	PERLIO_K_BUFFERED\|PERLIO_K_RAW,
3940	PerlIOBuf_pushed,
3941	PerlIOBuf_popped,
3942	PerlIOBuf_open,
3943	PerlIOBase_binmode, /* binmode */
3944	NULL,
3945	PerlIOBase_fileno,
3946	PerlIOBuf_dup,
3947	PerlIOBuf_read,
3948	PerlIOBuf_unread,
3949	PerlIOBuf_write,
3950	PerlIOBuf_seek,
3951	PerlIOBuf_tell,
3952	PerlIOBuf_close,
3953	PerlIOBuf_flush,
3954	PerlIOBuf_fill,
3955	PerlIOBase_eof,
3956	PerlIOBase_error,
3957	PerlIOBase_clearerr,
3958	PerlIOBase_setlinebuf,
3959	PerlIOBuf_get_base,
3960	PerlIOBuf_bufsiz,
3961	PerlIOBuf_get_ptr,
3962	PerlIOBuf_get_cnt,
3963	PerlIOBuf_set_ptrcnt,
3964	};
3965
3966	/--------------------------------------------------------------------------------------/
3967	/*
3968	* Temp layer to hold unread chars when cannot do it any other way
3969	*/
3970
3971	IV
3972	PerlIOPending_fill(pTHX_ PerlIO *f)
3973	{
3974	/*
3975	* Should never happen
3976	*/
3977	PerlIO_flush(f);
3978	return 0;
3979	}
3980
3981	IV
3982	PerlIOPending_close(pTHX_ PerlIO *f)
3983	{
3984	/*
3985	* A tad tricky - flush pops us, then we close new top
3986	*/
3987	PerlIO_flush(f);
3988	return PerlIO_close(f);
3989	}
3990
3991	IV
3992	PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3993	{
3994	/*
3995	* A tad tricky - flush pops us, then we seek new top
3996	*/
3997	PerlIO_flush(f);
3998	return PerlIO_seek(f, offset, whence);
3999	}
4000
4001
4002	IV
4003	PerlIOPending_flush(pTHX_ PerlIO *f)
4004	{
4005	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4006	if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4007	Safefree(b->buf);
4008	b->buf = NULL;
4009	}
4010	PerlIO_pop(aTHX_ f);
4011	return 0;
4012	}
4013
4014	void
4015	PerlIOPending_set_ptrcnt(pTHX_ PerlIO f, STDCHAR ptr, SSize_t cnt)
4016	{
4017	if (cnt <= 0) {
4018	PerlIO_flush(f);
4019	}
4020	else {
4021	PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4022	}
4023	}
4024
4025	IV
4026	PerlIOPending_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
4027	{
4028	const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4029	PerlIOl *l = PerlIOBase(f);
4030	/*
4031	* Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4032	* etc. get muddled when it changes mid-string when we auto-pop.
4033	*/
4034	l->flags = (l->flags & ~(PERLIO_F_FASTGETS \| PERLIO_F_UTF8)) \|
4035	(PerlIOBase(PerlIONext(f))->
4036	flags & (PERLIO_F_FASTGETS \| PERLIO_F_UTF8));
4037	return code;
4038	}
4039
4040	SSize_t
4041	PerlIOPending_read(pTHX_ PerlIO f, void vbuf, Size_t count)
4042	{
4043	SSize_t avail = PerlIO_get_cnt(f);
4044	SSize_t got = 0;
4045	if ((SSize_t)count < avail)
4046	avail = count;
4047	if (avail > 0)
4048	got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4049	if (got >= 0 && got < (SSize_t)count) {
4050	const SSize_t more =
4051	PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4052	if (more >= 0 \|\| got == 0)
4053	got += more;
4054	}
4055	return got;
4056	}
4057
4058	PERLIO_FUNCS_DECL(PerlIO_pending) = {
4059	sizeof(PerlIO_funcs),
4060	"pending",
4061	sizeof(PerlIOBuf),
4062	PERLIO_K_BUFFERED\|PERLIO_K_RAW, /* not sure about RAW here */
4063	PerlIOPending_pushed,
4064	PerlIOBuf_popped,
4065	NULL,
4066	PerlIOBase_binmode, /* binmode */
4067	NULL,
4068	PerlIOBase_fileno,
4069	PerlIOBuf_dup,
4070	PerlIOPending_read,
4071	PerlIOBuf_unread,
4072	PerlIOBuf_write,
4073	PerlIOPending_seek,
4074	PerlIOBuf_tell,
4075	PerlIOPending_close,
4076	PerlIOPending_flush,
4077	PerlIOPending_fill,
4078	PerlIOBase_eof,
4079	PerlIOBase_error,
4080	PerlIOBase_clearerr,
4081	PerlIOBase_setlinebuf,
4082	PerlIOBuf_get_base,
4083	PerlIOBuf_bufsiz,
4084	PerlIOBuf_get_ptr,
4085	PerlIOBuf_get_cnt,
4086	PerlIOPending_set_ptrcnt,
4087	};
4088
4089
4090
4091	/--------------------------------------------------------------------------------------/
4092	/*
4093	* crlf - translation On read translate CR,LF to "\n" we do this by
4094	* overriding ptr/cnt entries to hand back a line at a time and keeping a
4095	* record of which nl we "lied" about. On write translate "\n" to CR,LF
4096	*
4097	* c->nl points on the first byte of CR LF pair when it is temporarily
4098	* replaced by LF, or to the last CR of the buffer. In the former case
4099	* the caller thinks that the buffer ends at c->nl + 1, in the latter
4100	* that it ends at c->nl; these two cases can be distinguished by
4101	* *c->nl. c->nl is set during _getcnt() call, and unset during
4102	* _unread() and _flush() calls.
4103	* It only matters for read operations.
4104	*/
4105
4106	typedef struct {
4107	PerlIOBuf base; /* PerlIOBuf stuff */
4108	STDCHAR nl; / Position of crlf we "lied" about in the
4109	* buffer */
4110	} PerlIOCrlf;
4111
4112	IV
4113	PerlIOCrlf_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
4114	{
4115	IV code;
4116	PerlIOBase(f)->flags \|= PERLIO_F_CRLF;
4117	code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4118	#if 0
4119	PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4120	f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4121	PerlIOBase(f)->flags);
4122	#endif
4123	{
4124	/* Enable the first CRLF capable layer you can find, but if none
4125	* found, the one we just pushed is fine. This results in at
4126	* any given moment at most one CRLF-capable layer being enabled
4127	* in the whole layer stack. */
4128	PerlIO *g = PerlIONext(f);
4129	while (g && *g) {
4130	PerlIOl *b = PerlIOBase(g);
4131	if (b && b->tab == &PerlIO_crlf) {
4132	if (!(b->flags & PERLIO_F_CRLF))
4133	b->flags \|= PERLIO_F_CRLF;
4134	PerlIO_pop(aTHX_ f);
4135	return code;
4136	}
4137	g = PerlIONext(g);
4138	}
4139	}
4140	return code;
4141	}
4142
4143
4144	SSize_t
4145	PerlIOCrlf_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
4146	{
4147	PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4148	if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4149	*(c->nl) = 0xd;
4150	c->nl = NULL;
4151	}
4152	if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4153	return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4154	else {
4155	const STDCHAR buf = (const STDCHAR ) vbuf + count;
4156	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4157	SSize_t unread = 0;
4158	if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4159	PerlIO_flush(f);
4160	if (!b->buf)
4161	PerlIO_get_base(f);
4162	if (b->buf) {
4163	if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4164	b->end = b->ptr = b->buf + b->bufsiz;
4165	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
4166	b->posn -= b->bufsiz;
4167	}
4168	while (count > 0 && b->ptr > b->buf) {
4169	int ch = *--buf;
4170	if (ch == '\n') {
4171	if (b->ptr - 2 >= b->buf) {
4172	*--(b->ptr) = 0xa;
4173	*--(b->ptr) = 0xd;
4174	unread++;
4175	count--;
4176	}
4177	else {
4178	/* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4179	--(b->ptr) = 0xa; / Works even if 0xa == '\r' */
4180	unread++;
4181	count--;
4182	}
4183	}
4184	else {
4185	*--(b->ptr) = ch;
4186	unread++;
4187	count--;
4188	}
4189	}
4190	}
4191	return unread;
4192	}
4193	}
4194
4195	/* XXXX This code assumes that buffer size >=2, but does not check it... */
4196	SSize_t
4197	PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4198	{
4199	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4200	if (!b->buf)
4201	PerlIO_get_base(f);
4202	if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4203	PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4204	if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl \|\| *c->nl == 0xd)) {
4205	STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4206	scan:
4207	while (nl < b->end && *nl != 0xd)
4208	nl++;
4209	if (nl < b->end && *nl == 0xd) {
4210	test:
4211	if (nl + 1 < b->end) {
4212	if (nl[1] == 0xa) {
4213	*nl = '\n';
4214	c->nl = nl;
4215	}
4216	else {
4217	/*
4218	* Not CR,LF but just CR
4219	*/
4220	nl++;
4221	goto scan;
4222	}
4223	}
4224	else {
4225	/*
4226	* Blast - found CR as last char in buffer
4227	*/
4228
4229	if (b->ptr < nl) {
4230	/*
4231	* They may not care, defer work as long as
4232	* possible
4233	*/
4234	c->nl = nl;
4235	return (nl - b->ptr);
4236	}
4237	else {
4238	int code;
4239	b->ptr++; /* say we have read it as far as
4240	* flush() is concerned */
4241	b->buf++; /* Leave space in front of buffer */
4242	/* Note as we have moved buf up flush's
4243	posn += ptr-buf
4244	will naturally make posn point at CR
4245	*/
4246	b->bufsiz--; /* Buffer is thus smaller */
4247	code = PerlIO_fill(f); /* Fetch some more */
4248	b->bufsiz++; /* Restore size for next time */
4249	b->buf--; /* Point at space */
4250	b->ptr = nl = b->buf; /* Which is what we hand
4251	* off */
4252	nl = 0xd; / Fill in the CR */
4253	if (code == 0)
4254	goto test; /* fill() call worked */
4255	/*
4256	* CR at EOF - just fall through
4257	*/
4258	/* Should we clear EOF though ??? */
4259	}
4260	}
4261	}
4262	}
4263	return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4264	}
4265	return 0;
4266	}
4267
4268	void
4269	PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO f, STDCHAR ptr, SSize_t cnt)
4270	{
4271	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4272	PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4273	if (!b->buf)
4274	PerlIO_get_base(f);
4275	if (!ptr) {
4276	if (c->nl) {
4277	ptr = c->nl + 1;
4278	if (ptr == b->end && *c->nl == 0xd) {
4279	/* Defered CR at end of buffer case - we lied about count */
4280	ptr--;
4281	}
4282	}
4283	else {
4284	ptr = b->end;
4285	}
4286	ptr -= cnt;
4287	}
4288	else {
4289	#if 0
4290	/*
4291	* Test code - delete when it works ...
4292	*/
4293	IV flags = PerlIOBase(f)->flags;
4294	STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4295	if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4296	/* Defered CR at end of buffer case - we lied about count */
4297	chk--;
4298	}
4299	chk -= cnt;
4300
4301	if (ptr != chk ) {
4302	Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4303	" nl=%p e=%p for %d", ptr, chk, flags, c->nl,
4304	b->end, cnt);
4305	}
4306	#endif
4307	}
4308	if (c->nl) {
4309	if (ptr > c->nl) {
4310	/*
4311	* They have taken what we lied about
4312	*/
4313	*(c->nl) = 0xd;
4314	c->nl = NULL;
4315	ptr++;
4316	}
4317	}
4318	b->ptr = ptr;
4319	PerlIOBase(f)->flags \|= PERLIO_F_RDBUF;
4320	}
4321
4322	SSize_t
4323	PerlIOCrlf_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
4324	{
4325	if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4326	return PerlIOBuf_write(aTHX_ f, vbuf, count);
4327	else {
4328	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4329	const STDCHAR buf = (const STDCHAR ) vbuf;
4330	const STDCHAR *ebuf = buf + count;
4331	if (!b->buf)
4332	PerlIO_get_base(f);
4333	if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4334	return 0;
4335	while (buf < ebuf) {
4336	STDCHAR *eptr = b->buf + b->bufsiz;
4337	PerlIOBase(f)->flags \|= PERLIO_F_WRBUF;
4338	while (buf < ebuf && b->ptr < eptr) {
4339	if (*buf == '\n') {
4340	if ((b->ptr + 2) > eptr) {
4341	/*
4342	* Not room for both
4343	*/
4344	PerlIO_flush(f);
4345	break;
4346	}
4347	else {
4348	(b->ptr)++ = 0xd; / CR */
4349	(b->ptr)++ = 0xa; / LF */
4350	buf++;
4351	if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4352	PerlIO_flush(f);
4353	break;
4354	}
4355	}
4356	}
4357	else {
4358	int ch = *buf++;
4359	*(b->ptr)++ = ch;
4360	}
4361	if (b->ptr >= eptr) {
4362	PerlIO_flush(f);
4363	break;
4364	}
4365	}
4366	}
4367	if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4368	PerlIO_flush(f);
4369	return (buf - (STDCHAR *) vbuf);
4370	}
4371	}
4372
4373	IV
4374	PerlIOCrlf_flush(pTHX_ PerlIO *f)
4375	{
4376	PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4377	if (c->nl) {
4378	*(c->nl) = 0xd;
4379	c->nl = NULL;
4380	}
4381	return PerlIOBuf_flush(aTHX_ f);
4382	}
4383
4384	IV
4385	PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4386	{
4387	if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4388	/* In text mode - flush any pending stuff and flip it */
4389	PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4390	#ifndef PERLIO_USING_CRLF
4391	/* CRLF is unusual case - if this is just the :crlf layer pop it */
4392	if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4393	PerlIO_pop(aTHX_ f);
4394	}
4395	#endif
4396	}
4397	return 0;
4398	}
4399
4400	PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4401	sizeof(PerlIO_funcs),
4402	"crlf",
4403	sizeof(PerlIOCrlf),
4404	PERLIO_K_BUFFERED \| PERLIO_K_CANCRLF \| PERLIO_K_RAW,
4405	PerlIOCrlf_pushed,
4406	PerlIOBuf_popped, /* popped */
4407	PerlIOBuf_open,
4408	PerlIOCrlf_binmode, /* binmode */
4409	NULL,
4410	PerlIOBase_fileno,
4411	PerlIOBuf_dup,
4412	PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4413	PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4414	PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4415	PerlIOBuf_seek,
4416	PerlIOBuf_tell,
4417	PerlIOBuf_close,
4418	PerlIOCrlf_flush,
4419	PerlIOBuf_fill,
4420	PerlIOBase_eof,
4421	PerlIOBase_error,
4422	PerlIOBase_clearerr,
4423	PerlIOBase_setlinebuf,
4424	PerlIOBuf_get_base,
4425	PerlIOBuf_bufsiz,
4426	PerlIOBuf_get_ptr,
4427	PerlIOCrlf_get_cnt,
4428	PerlIOCrlf_set_ptrcnt,
4429	};
4430
4431	#ifdef HAS_MMAP
4432	/--------------------------------------------------------------------------------------/
4433	/*
4434	* mmap as "buffer" layer
4435	*/
4436
4437	typedef struct {
4438	PerlIOBuf base; /* PerlIOBuf stuff */
4439	Mmap_t mptr; /* Mapped address */
4440	Size_t len; /* mapped length */
4441	STDCHAR bbuf; / malloced buffer if map fails */
4442	} PerlIOMmap;
4443
4444	static size_t page_size = 0;
4445
4446	IV
4447	PerlIOMmap_map(pTHX_ PerlIO *f)
4448	{
4449	PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4450	const IV flags = PerlIOBase(f)->flags;
4451	IV code = 0;
4452	if (m->len)
4453	abort();
4454	if (flags & PERLIO_F_CANREAD) {
4455	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4456	const int fd = PerlIO_fileno(f);
4457	Stat_t st;
4458	code = Fstat(fd, &st);
4459	if (code == 0 && S_ISREG(st.st_mode)) {
4460	SSize_t len = st.st_size - b->posn;
4461	if (len > 0) {
4462	Off_t posn;
4463	if (!page_size) {
4464	#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) \|\| defined(_SC_PAGE_SIZE))
4465	{
4466	SETERRNO(0, SS_NORMAL);
4467	# ifdef _SC_PAGESIZE
4468	page_size = sysconf(_SC_PAGESIZE);
4469	# else
4470	page_size = sysconf(_SC_PAGE_SIZE);
4471	# endif
4472	if ((long) page_size < 0) {
4473	if (errno) {
4474	SV *error = ERRSV;
4475	char *msg;
4476	STRLEN n_a;
4477	(void) SvUPGRADE(error, SVt_PV);
4478	msg = SvPVx(error, n_a);
4479	Perl_croak(aTHX_ "panic: sysconf: %s",
4480	msg);
4481	}
4482	else
4483	Perl_croak(aTHX_
4484	"panic: sysconf: pagesize unknown");
4485	}
4486	}
4487	#else
4488	# ifdef HAS_GETPAGESIZE
4489	page_size = getpagesize();
4490	# else
4491	# if defined(I_SYS_PARAM) && defined(PAGESIZE)
4492	page_size = PAGESIZE; /* compiletime, bad */
4493	# endif
4494	# endif
4495	#endif
4496	if ((IV) page_size <= 0)
4497	Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4498	(IV) page_size);
4499	}
4500	if (b->posn < 0) {
4501	/*
4502	* This is a hack - should never happen - open should
4503	* have set it !
4504	*/
4505	b->posn = PerlIO_tell(PerlIONext(f));
4506	}
4507	posn = (b->posn / page_size) * page_size;
4508	len = st.st_size - posn;
4509	m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4510	if (m->mptr && m->mptr != (Mmap_t) - 1) {
4511	#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4512	madvise(m->mptr, len, MADV_SEQUENTIAL);
4513	#endif
4514	#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4515	madvise(m->mptr, len, MADV_WILLNEED);
4516	#endif
4517	PerlIOBase(f)->flags =
4518	(flags & ~PERLIO_F_EOF) \| PERLIO_F_RDBUF;
4519	b->end = ((STDCHAR *) m->mptr) + len;
4520	b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4521	b->ptr = b->buf;
4522	m->len = len;
4523	}
4524	else {
4525	b->buf = NULL;
4526	}
4527	}
4528	else {
4529	PerlIOBase(f)->flags =
4530	flags \| PERLIO_F_EOF \| PERLIO_F_RDBUF;
4531	b->buf = NULL;
4532	b->ptr = b->end = b->ptr;
4533	code = -1;
4534	}
4535	}
4536	}
4537	return code;
4538	}
4539
4540	IV
4541	PerlIOMmap_unmap(pTHX_ PerlIO *f)
4542	{
4543	PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4544	PerlIOBuf *b = &m->base;
4545	IV code = 0;
4546	if (m->len) {
4547	if (b->buf) {
4548	code = munmap(m->mptr, m->len);
4549	b->buf = NULL;
4550	m->len = 0;
4551	m->mptr = NULL;
4552	if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4553	code = -1;
4554	}
4555	b->ptr = b->end = b->buf;
4556	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
4557	}
4558	return code;
4559	}
4560
4561	STDCHAR *
4562	PerlIOMmap_get_base(pTHX_ PerlIO *f)
4563	{
4564	PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4565	PerlIOBuf *b = &m->base;
4566	if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4567	/*
4568	* Already have a readbuffer in progress
4569	*/
4570	return b->buf;
4571	}
4572	if (b->buf) {
4573	/*
4574	* We have a write buffer or flushed PerlIOBuf read buffer
4575	*/
4576	m->bbuf = b->buf; /* save it in case we need it again */
4577	b->buf = NULL; /* Clear to trigger below */
4578	}
4579	if (!b->buf) {
4580	PerlIOMmap_map(aTHX_ f); /* Try and map it */
4581	if (!b->buf) {
4582	/*
4583	* Map did not work - recover PerlIOBuf buffer if we have one
4584	*/
4585	b->buf = m->bbuf;
4586	}
4587	}
4588	b->ptr = b->end = b->buf;
4589	if (b->buf)
4590	return b->buf;
4591	return PerlIOBuf_get_base(aTHX_ f);
4592	}
4593
4594	SSize_t
4595	PerlIOMmap_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
4596	{
4597	PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4598	PerlIOBuf *b = &m->base;
4599	if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4600	PerlIO_flush(f);
4601	if (b->ptr && (b->ptr - count) >= b->buf
4602	&& memEQ(b->ptr - count, vbuf, count)) {
4603	b->ptr -= count;
4604	PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4605	return count;
4606	}
4607	if (m->len) {
4608	/*
4609	* Loose the unwritable mapped buffer
4610	*/
4611	PerlIO_flush(f);
4612	/*
4613	* If flush took the "buffer" see if we have one from before
4614	*/
4615	if (!b->buf && m->bbuf)
4616	b->buf = m->bbuf;
4617	if (!b->buf) {
4618	PerlIOBuf_get_base(aTHX_ f);
4619	m->bbuf = b->buf;
4620	}
4621	}
4622	return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4623	}
4624
4625	SSize_t
4626	PerlIOMmap_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
4627	{
4628	PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4629	PerlIOBuf * const b = &m->base;
4630
4631	if (!b->buf \|\| !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4632	/*
4633	* No, or wrong sort of, buffer
4634	*/
4635	if (m->len) {
4636	if (PerlIOMmap_unmap(aTHX_ f) != 0)
4637	return 0;
4638	}
4639	/*
4640	* If unmap took the "buffer" see if we have one from before
4641	*/
4642	if (!b->buf && m->bbuf)
4643	b->buf = m->bbuf;
4644	if (!b->buf) {
4645	PerlIOBuf_get_base(aTHX_ f);
4646	m->bbuf = b->buf;
4647	}
4648	}
4649	return PerlIOBuf_write(aTHX_ f, vbuf, count);
4650	}
4651
4652	IV
4653	PerlIOMmap_flush(pTHX_ PerlIO *f)
4654	{
4655	PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4656	PerlIOBuf *b = &m->base;
4657	IV code = PerlIOBuf_flush(aTHX_ f);
4658	/*
4659	* Now we are "synced" at PerlIOBuf level
4660	*/
4661	if (b->buf) {
4662	if (m->len) {
4663	/*
4664	* Unmap the buffer
4665	*/
4666	if (PerlIOMmap_unmap(aTHX_ f) != 0)
4667	code = -1;
4668	}
4669	else {
4670	/*
4671	* We seem to have a PerlIOBuf buffer which was not mapped
4672	* remember it in case we need one later
4673	*/
4674	m->bbuf = b->buf;
4675	}
4676	}
4677	return code;
4678	}
4679
4680	IV
4681	PerlIOMmap_fill(pTHX_ PerlIO *f)
4682	{
4683	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4684	IV code = PerlIO_flush(f);
4685	if (code == 0 && !b->buf) {
4686	code = PerlIOMmap_map(aTHX_ f);
4687	}
4688	if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4689	code = PerlIOBuf_fill(aTHX_ f);
4690	}
4691	return code;
4692	}
4693
4694	IV
4695	PerlIOMmap_close(pTHX_ PerlIO *f)
4696	{
4697	PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4698	PerlIOBuf *b = &m->base;
4699	IV code = PerlIO_flush(f);
4700	if (m->bbuf) {
4701	b->buf = m->bbuf;
4702	m->bbuf = NULL;
4703	b->ptr = b->end = b->buf;
4704	}
4705	if (PerlIOBuf_close(aTHX_ f) != 0)
4706	code = -1;
4707	return code;
4708	}
4709
4710	PerlIO *
4711	PerlIOMmap_dup(pTHX_ PerlIO f, PerlIO o, CLONE_PARAMS *param, int flags)
4712	{
4713	return PerlIOBase_dup(aTHX_ f, o, param, flags);
4714	}
4715
4716
4717	PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4718	sizeof(PerlIO_funcs),
4719	"mmap",
4720	sizeof(PerlIOMmap),
4721	PERLIO_K_BUFFERED\|PERLIO_K_RAW,
4722	PerlIOBuf_pushed,
4723	PerlIOBuf_popped,
4724	PerlIOBuf_open,
4725	PerlIOBase_binmode, /* binmode */
4726	NULL,
4727	PerlIOBase_fileno,
4728	PerlIOMmap_dup,
4729	PerlIOBuf_read,
4730	PerlIOMmap_unread,
4731	PerlIOMmap_write,
4732	PerlIOBuf_seek,
4733	PerlIOBuf_tell,
4734	PerlIOBuf_close,
4735	PerlIOMmap_flush,
4736	PerlIOMmap_fill,
4737	PerlIOBase_eof,
4738	PerlIOBase_error,
4739	PerlIOBase_clearerr,
4740	PerlIOBase_setlinebuf,
4741	PerlIOMmap_get_base,
4742	PerlIOBuf_bufsiz,
4743	PerlIOBuf_get_ptr,
4744	PerlIOBuf_get_cnt,
4745	PerlIOBuf_set_ptrcnt,
4746	};
4747
4748	#endif /* HAS_MMAP */
4749
4750	PerlIO *
4751	Perl_PerlIO_stdin(pTHX)
4752	{
4753	if (!PL_perlio) {
4754	PerlIO_stdstreams(aTHX);
4755	}
4756	return &PL_perlio[1];
4757	}
4758
4759	PerlIO *
4760	Perl_PerlIO_stdout(pTHX)
4761	{
4762	if (!PL_perlio) {
4763	PerlIO_stdstreams(aTHX);
4764	}
4765	return &PL_perlio[2];
4766	}
4767
4768	PerlIO *
4769	Perl_PerlIO_stderr(pTHX)
4770	{
4771	if (!PL_perlio) {
4772	PerlIO_stdstreams(aTHX);
4773	}
4774	return &PL_perlio[3];
4775	}
4776
4777	/--------------------------------------------------------------------------------------/
4778
4779	char *
4780	PerlIO_getname(PerlIO f, char buf)
4781	{
4782	dTHX;
4783	#ifdef VMS
4784	char *name = NULL;
4785	bool exported = FALSE;
4786	FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4787	if (!stdio) {
4788	stdio = PerlIO_exportFILE(f,0);
4789	exported = TRUE;
4790	}
4791	if (stdio) {
4792	name = fgetname(stdio, buf);
4793	if (exported) PerlIO_releaseFILE(f,stdio);
4794	}
4795	return name;
4796	#else
4797	PERL_UNUSED_ARG(f);
4798	PERL_UNUSED_ARG(buf);
4799	Perl_croak(aTHX_ "Don't know how to get file name");
4800	return Nullch;
4801	#endif
4802	}
4803
4804
4805	/--------------------------------------------------------------------------------------/
4806	/*
4807	* Functions which can be called on any kind of PerlIO implemented in
4808	* terms of above
4809	*/
4810
4811	#undef PerlIO_fdopen
4812	PerlIO *
4813	PerlIO_fdopen(int fd, const char *mode)
4814	{
4815	dTHX;
4816	return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4817	}
4818
4819	#undef PerlIO_open
4820	PerlIO *
4821	PerlIO_open(const char path, const char mode)
4822	{
4823	dTHX;
4824	SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4825	return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4826	}
4827
4828	#undef Perlio_reopen
4829	PerlIO *
4830	PerlIO_reopen(const char path, const char mode, PerlIO *f)
4831	{
4832	dTHX;
4833	SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4834	return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4835	}
4836
4837	#undef PerlIO_getc
4838	int
4839	PerlIO_getc(PerlIO *f)
4840	{
4841	dTHX;
4842	STDCHAR buf[1];
4843	if ( 1 == PerlIO_read(f, buf, 1) ) {
4844	return (unsigned char) buf[0];
4845	}
4846	return EOF;
4847	}
4848
4849	#undef PerlIO_ungetc
4850	int
4851	PerlIO_ungetc(PerlIO *f, int ch)
4852	{
4853	dTHX;
4854	if (ch != EOF) {
4855	STDCHAR buf = ch;
4856	if (PerlIO_unread(f, &buf, 1) == 1)
4857	return ch;
4858	}
4859	return EOF;
4860	}
4861
4862	#undef PerlIO_putc
4863	int
4864	PerlIO_putc(PerlIO *f, int ch)
4865	{
4866	dTHX;
4867	STDCHAR buf = ch;
4868	return PerlIO_write(f, &buf, 1);
4869	}
4870
4871	#undef PerlIO_puts
4872	int
4873	PerlIO_puts(PerlIO f, const char s)
4874	{
4875	dTHX;
4876	STRLEN len = strlen(s);
4877	return PerlIO_write(f, s, len);
4878	}
4879
4880	#undef PerlIO_rewind
4881	void
4882	PerlIO_rewind(PerlIO *f)
4883	{
4884	dTHX;
4885	PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4886	PerlIO_clearerr(f);
4887	}
4888
4889	#undef PerlIO_vprintf
4890	int
4891	PerlIO_vprintf(PerlIO f, const char fmt, va_list ap)
4892	{
4893	dTHX;
4894	SV *sv = newSVpvn("", 0);
4895	const char *s;
4896	STRLEN len;
4897	SSize_t wrote;
4898	#ifdef NEED_VA_COPY
4899	va_list apc;
4900	Perl_va_copy(ap, apc);
4901	sv_vcatpvf(sv, fmt, &apc);
4902	#else
4903	sv_vcatpvf(sv, fmt, &ap);
4904	#endif
4905	s = SvPV_const(sv, len);
4906	wrote = PerlIO_write(f, s, len);
4907	SvREFCNT_dec(sv);
4908	return wrote;
4909	}
4910
4911	#undef PerlIO_printf
4912	int
4913	PerlIO_printf(PerlIO f, const char fmt, ...)
4914	{
4915	va_list ap;
4916	int result;
4917	va_start(ap, fmt);
4918	result = PerlIO_vprintf(f, fmt, ap);
4919	va_end(ap);
4920	return result;
4921	}
4922
4923	#undef PerlIO_stdoutf
4924	int
4925	PerlIO_stdoutf(const char *fmt, ...)
4926	{
4927	dTHX;
4928	va_list ap;
4929	int result;
4930	va_start(ap, fmt);
4931	result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4932	va_end(ap);
4933	return result;
4934	}
4935
4936	#undef PerlIO_tmpfile
4937	PerlIO *
4938	PerlIO_tmpfile(void)
4939	{
4940	dTHX;
4941	PerlIO *f = NULL;
4942	#ifdef WIN32
4943	const int fd = win32_tmpfd();
4944	if (fd >= 0)
4945	f = PerlIO_fdopen(fd, "w+b");
4946	#else /* WIN32 */
4947	# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4948	SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4949	/*
4950	* I have no idea how portable mkstemp() is ... NI-S
4951	*/
4952	const int fd = mkstemp(SvPVX(sv));
4953	if (fd >= 0) {
4954	f = PerlIO_fdopen(fd, "w+");
4955	if (f)
4956	PerlIOBase(f)->flags \|= PERLIO_F_TEMP;
4957	PerlLIO_unlink(SvPVX_const(sv));
4958	SvREFCNT_dec(sv);
4959	}
4960	# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
4961	FILE *stdio = PerlSIO_tmpfile();
4962
4963	if (stdio) {
4964	if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
4965	PERLIO_FUNCS_CAST(&PerlIO_stdio),
4966	"w+", Nullsv))) {
4967	PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
4968
4969	if (s)
4970	s->stdio = stdio;
4971	}
4972	}
4973	# endif /* else HAS_MKSTEMP */
4974	#endif /* else WIN32 */
4975	return f;
4976	}
4977
4978	#undef HAS_FSETPOS
4979	#undef HAS_FGETPOS
4980
4981	#endif /* USE_SFIO */
4982	#endif /* PERLIO_IS_STDIO */
4983
4984	/======================================================================================/
4985	/*
4986	* Now some functions in terms of above which may be needed even if we are
4987	* not in true PerlIO mode
4988	*/
4989
4990	#ifndef HAS_FSETPOS
4991	#undef PerlIO_setpos
4992	int
4993	PerlIO_setpos(PerlIO f, SV pos)
4994	{
4995	dTHX;
4996	if (SvOK(pos)) {
4997	STRLEN len;
4998	Off_t posn = (Off_t ) SvPV(pos, len);
4999	if (f && len == sizeof(Off_t))
5000	return PerlIO_seek(f, *posn, SEEK_SET);
5001	}
5002	SETERRNO(EINVAL, SS_IVCHAN);
5003	return -1;
5004	}
5005	#else
5006	#undef PerlIO_setpos
5007	int
5008	PerlIO_setpos(PerlIO f, SV pos)
5009	{
5010	dTHX;
5011	if (SvOK(pos)) {
5012	STRLEN len;
5013	Fpos_t fpos = (Fpos_t ) SvPV(pos, len);
5014	if (f && len == sizeof(Fpos_t)) {
5015	#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5016	return fsetpos64(f, fpos);
5017	#else
5018	return fsetpos(f, fpos);
5019	#endif
5020	}
5021	}
5022	SETERRNO(EINVAL, SS_IVCHAN);
5023	return -1;
5024	}
5025	#endif
5026
5027	#ifndef HAS_FGETPOS
5028	#undef PerlIO_getpos
5029	int
5030	PerlIO_getpos(PerlIO f, SV pos)
5031	{
5032	dTHX;
5033	Off_t posn = PerlIO_tell(f);
5034	sv_setpvn(pos, (char *) &posn, sizeof(posn));
5035	return (posn == (Off_t) - 1) ? -1 : 0;
5036	}
5037	#else
5038	#undef PerlIO_getpos
5039	int
5040	PerlIO_getpos(PerlIO f, SV pos)
5041	{
5042	dTHX;
5043	Fpos_t fpos;
5044	int code;
5045	#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5046	code = fgetpos64(f, &fpos);
5047	#else
5048	code = fgetpos(f, &fpos);
5049	#endif
5050	sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5051	return code;
5052	}
5053	#endif
5054
5055	#if (defined(PERLIO_IS_STDIO) \|\| !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5056
5057	int
5058	vprintf(char pat, char args)
5059	{
5060	_doprnt(pat, args, stdout);
5061	return 0; /* wrong, but perl doesn't use the return
5062	* value */
5063	}
5064
5065	int
5066	vfprintf(FILE fd, char pat, char *args)
5067	{
5068	_doprnt(pat, args, fd);
5069	return 0; /* wrong, but perl doesn't use the return
5070	* value */
5071	}
5072
5073	#endif
5074
5075	#ifndef PerlIO_vsprintf
5076	int
5077	PerlIO_vsprintf(char s, int n, const char fmt, va_list ap)
5078	{
5079	const int val = vsprintf(s, fmt, ap);
5080	if (n >= 0) {
5081	if (strlen(s) >= (STRLEN) n) {
5082	dTHX;
5083	(void) PerlIO_puts(Perl_error_log,
5084	"panic: sprintf overflow - memory corrupted!\n");
5085	my_exit(1);
5086	}
5087	}
5088	return val;
5089	}
5090	#endif
5091
5092	#ifndef PerlIO_sprintf
5093	int
5094	PerlIO_sprintf(char s, int n, const char fmt, ...)
5095	{
5096	va_list ap;
5097	int result;
5098	va_start(ap, fmt);
5099	result = PerlIO_vsprintf(s, n, fmt, ap);
5100	va_end(ap);
5101	return result;
5102	}
5103	#endif
5104
5105	/*
5106	* Local variables:
5107	* c-indentation-style: bsd
5108	* c-basic-offset: 4
5109	* indent-tabs-mode: t
5110	* End:
5111	*
5112	* ex: set ts=8 sts=4 sw=4 noet:
5113	*/

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: vendor/perl/5.8.8/perlio.c@ 3277

Download in other formats: