Context Navigation

perlio.c @ 20075

Visit:

Revision 20075, 109.5 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.

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

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

Context Navigation

source: trunk/third/perl/perlio.c @ 20075

Download in other formats: