Context Navigation

reentr.pl @ 20075

Visit:

Revision 20075, 30.6 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	#!/usr/bin/perl -w
2
3	#
4	# Generate the reentr.c and reentr.h,
5	# and optionally also the relevant metaconfig units (-U option).
6	#
7
8	use strict;
9	use Getopt::Std;
10	my %opts;
11	getopts('U', \%opts);
12
13	my %map = (
14	V => "void",
15	A => "char*", # as an input argument
16	B => "char*", # as an output argument
17	C => "const char*", # as a read-only input argument
18	I => "int",
19	L => "long",
20	W => "size_t",
21	H => "FILE**",
22	E => "int*",
23	);
24
25	# (See the definitions after __DATA__.)
26	# In func\|inc\|type\|... a "S" means "type", and a "R" means "type*".
27	# (The "types" are often structs, such as "struct passwd".)
28	#
29	# After the prototypes one can have \|X=...\|Y=... to define more types.
30	# A commonly used extra type is to define D to be equal to "type_data",
31	# for example "struct_hostent_data to" go with "struct hostent".
32	#
33	# Example #1: I_XSBWR means int func_r(X, type, char, size_t, type*)
34	# Example #2: S_SBIE means type func_r(type, char, int, int)
35	# Example #3: S_CBI means type func_r(const char, char, int)
36
37
38	die "reentr.h: $!" unless open(H, ">reentr.h");
39	select H;
40	print <<EOF;
41	/*
42	* reentr.h
43	*
44	* Copyright (C) 2002, 2003, by Larry Wall and others
45	*
46	* You may distribute under the terms of either the GNU General Public
47	* License or the Artistic License, as specified in the README file.
48	*
49	* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
50	* This file is built by reentrl.pl from data in reentr.pl.
51	*/
52
53	#ifndef REENTR_H
54	#define REENTR_H
55
56	#ifdef USE_REENTRANT_API
57
58	#ifdef PERL_CORE
59	# define PL_REENTRANT_RETINT PL_reentrant_retint
60	#endif
61
62	/* Deprecations: some platforms have the said reentrant interfaces
63	* but they are declared obsolete and are not to be used. Often this
64	* means that the platform has threadsafed the interfaces (hopefully).
65	* All this is OS version dependent, so we are of course fooling ourselves.
66	* If you know of more deprecations on some platforms, please add your own. */
67
68	#ifdef __hpux
69	# undef HAS_CRYPT_R
70	# undef HAS_DRAND48_R
71	# undef HAS_ENDGRENT_R
72	# undef HAS_ENDPWENT_R
73	# undef HAS_GETGRENT_R
74	# undef HAS_GETPWENT_R
75	# undef HAS_SETLOCALE_R
76	# undef HAS_SRAND48_R
77	# undef HAS_STRERROR_R
78	# define NETDB_R_OBSOLETE
79	#endif
80
81	#if defined(__osf__) && defined(__alpha) /* Tru64 aka Digital UNIX */
82	# undef HAS_CRYPT_R
83	# undef HAS_STRERROR_R
84	# define NETDB_R_OBSOLETE
85	#endif
86
87	#ifdef NETDB_R_OBSOLETE
88	# undef HAS_ENDHOSTENT_R
89	# undef HAS_ENDNETENT_R
90	# undef HAS_ENDPROTOENT_R
91	# undef HAS_ENDSERVENT_R
92	# undef HAS_GETHOSTBYADDR_R
93	# undef HAS_GETHOSTBYNAME_R
94	# undef HAS_GETHOSTENT_R
95	# undef HAS_GETNETBYADDR_R
96	# undef HAS_GETNETBYNAME_R
97	# undef HAS_GETNETENT_R
98	# undef HAS_GETPROTOBYNAME_R
99	# undef HAS_GETPROTOBYNUMBER_R
100	# undef HAS_GETPROTOENT_R
101	# undef HAS_GETSERVBYNAME_R
102	# undef HAS_GETSERVBYPORT_R
103	# undef HAS_GETSERVENT_R
104	# undef HAS_SETHOSTENT_R
105	# undef HAS_SETNETENT_R
106	# undef HAS_SETPROTOENT_R
107	# undef HAS_SETSERVENT_R
108	#endif
109
110	#ifdef I_PWD
111	# include <pwd.h>
112	#endif
113	#ifdef I_GRP
114	# include <grp.h>
115	#endif
116	#ifdef I_NETDB
117	# include <netdb.h>
118	#endif
119	#ifdef I_STDLIB
120	# include <stdlib.h> /* drand48_data */
121	#endif
122	#ifdef I_CRYPT
123	# ifdef I_CRYPT
124	# include <crypt.h>
125	# endif
126	#endif
127	#ifdef HAS_GETSPNAM_R
128	# ifdef I_SHADOW
129	# include <shadow.h>
130	# endif
131	#endif
132
133	EOF
134
135	my %seenh; # the different prototypes signatures for this function
136	my %seena; # the different prototypes signatures for this function in order
137	my @seenf; # all the seen functions
138	my %seenp; # the different prototype signatures for all functions
139	my %seent; # the return type of this function
140	my %seens; # the type of this function's "S"
141	my %seend; # the type of this function's "D"
142	my %seenm; # all the types
143	my %seenu; # the length of the argument list of this function
144	my %seenr; # the return type of this function
145
146	while (<DATA>) { # Read in the protypes.
147	next if /^\s+$/;
148	chomp;
149	my ($func, $hdr, $type, @p) = split(/\s\\|\s/, $_, -1);
150	my ($r,$u);
151	# Split off the real function name and the argument list.
152	($func, $u) = split(' ', $func);
153	$u = "V_V" unless $u;
154	($r, $u) = ($u =~ /^(.)_(.+)/);
155	$seenu{$func} = $u eq 'V' ? 0 : length $u;
156	$seenr{$func} = $r;
157	my $FUNC = uc $func; # for output.
158	push @seenf, $func;
159	my %m = %map;
160	if ($type) {
161	$m{S} = "$type*";
162	$m{R} = "$type**";
163	}
164
165	# Set any special mapping variables (like X=x_t)
166	if (@p) {
167	while ($p[-1] =~ /=/) {
168	my ($k, $v) = ($p[-1] =~ /^([A-Za-z])\s=\s(.*)/);
169	$m{$k} = $v;
170	pop @p;
171	}
172	}
173
174	# If given the -U option open up the metaconfig unit for this function.
175	if ($opts{U} && open(U, ">d_${func}_r.U")) {
176	select U;
177	}
178
179	if ($opts{U}) {
180	# The metaconfig units needs prerequisite dependencies.
181	my $prereqs = '';
182	my $prereqh = '';
183	my $prereqsh = '';
184	if ($hdr ne 'stdio') { # There's no i_stdio.
185	$prereqs = "i_$hdr";
186	$prereqh = "$hdr.h";
187	$prereqsh = "\$$prereqs $prereqh";
188	}
189	my @prereq = qw(Inlibc Protochk Hasproto i_systypes usethreads);
190	push @prereq, $prereqs;
191	my $hdrs = "\$i_systypes sys/types.h define stdio.h $prereqsh";
192	if ($hdr eq 'time') {
193	$hdrs .= " \$i_systime sys/time.h";
194	push @prereq, 'i_systime';
195	}
196	# Output the metaconfig unit header.
197	print <<EOF;
198	?RCS: \$Id: reentr.pl,v 1.1.1.2 2004-02-09 19:09:00 zacheiss Exp ${func}_r.U,v $
199	?RCS:
200	?RCS: Copyright (c) 2002,2003 Jarkko Hietaniemi
201	?RCS:
202	?RCS: You may distribute under the terms of either the GNU General Public
203	?RCS: License or the Artistic License, as specified in the README file.
204	?RCS:
205	?RCS: Generated by the reentr.pl from the Perl 5.8 distribution.
206	?RCS:
207	?MAKE:d_${func}_r ${func}_r_proto: @prereq
208	?MAKE: -pick add \$@ %<
209	?S:d_${func}_r:
210	?S: This variable conditionally defines the HAS_${FUNC}_R symbol,
211	?S: which indicates to the C program that the ${func}_r()
212	?S: routine is available.
213	?S:.
214	?S:${func}_r_proto:
215	?S: This variable encodes the prototype of ${func}_r.
216	?S: It is zero if d_${func}_r is undef, and one of the
217	?S: REENTRANT_PROTO_T_ABC macros of reentr.h if d_${func}_r
218	?S: is defined.
219	?S:.
220	?C:HAS_${FUNC}_R:
221	?C: This symbol, if defined, indicates that the ${func}_r routine
222	?C: is available to ${func} re-entrantly.
223	?C:.
224	?C:${FUNC}_R_PROTO:
225	?C: This symbol encodes the prototype of ${func}_r.
226	?C: It is zero if d_${func}_r is undef, and one of the
227	?C: REENTRANT_PROTO_T_ABC macros of reentr.h if d_${func}_r
228	?C: is defined.
229	?C:.
230	?H:#\$d_${func}_r HAS_${FUNC}_R /**/
231	?H:#define ${FUNC}_R_PROTO \$${func}_r_proto /**/
232	?H:.
233	?T:try hdrs d_${func}_r_proto
234	?LINT:set d_${func}_r
235	?LINT:set ${func}_r_proto
236	: see if ${func}_r exists
237	set ${func}_r d_${func}_r
238	eval \$inlibc
239	case "\$d_${func}_r" in
240	"\$define")
241	EOF
242	print <<EOF;
243	hdrs="$hdrs"
244	case "\$d_${func}_r_proto:\$usethreads" in
245	":define") d_${func}_r_proto=define
246	set d_${func}_r_proto ${func}_r \$hdrs
247	eval \$hasproto ;;
248	*) ;;
249	esac
250	case "\$d_${func}_r_proto" in
251	define)
252	EOF
253	}
254	for my $p (@p) {
255	my ($r, $a) = ($p =~ /^(.)_(.+)/);
256	my $v = join(", ", map { $m{$_} } split '', $a);
257	if ($opts{U}) {
258	print <<EOF ;
259	case "\$${func}_r_proto" in
260	''\|0) try='$m{$r} ${func}_r($v);'
261	./protochk "extern \$try" \$hdrs && ${func}_r_proto=$p ;;
262	esac
263	EOF
264	}
265	$seenh{$func}->{$p}++;
266	push @{$seena{$func}}, $p;
267	$seenp{$p}++;
268	$seent{$func} = $type;
269	$seens{$func} = $m{S};
270	$seend{$func} = $m{D};
271	$seenm{$func} = \%m;
272	}
273	if ($opts{U}) {
274	print <<EOF;
275	case "\$${func}_r_proto" in
276	''\|0) d_${func}_r=undef
277	${func}_r_proto=0
278	echo "Disabling ${func}_r, cannot determine prototype." >&4 ;;
279	* ) case "\$${func}_r_proto" in
280	REENTRANT_PROTO*) ;;
281	*) ${func}_r_proto="REENTRANT_PROTO_\$${func}_r_proto" ;;
282	esac
283	echo "Prototype: \$try" ;;
284	esac
285	;;
286	*) case "\$usethreads" in
287	define) echo "${func}_r has no prototype, not using it." >&4 ;;
288	esac
289	d_${func}_r=undef
290	${func}_r_proto=0
291	;;
292	esac
293	;;
294	*) ${func}_r_proto=0
295	;;
296	esac
297
298	EOF
299	close(U);
300	}
301	}
302
303	close DATA;
304
305	# Prepare to continue writing the reentr.h.
306
307	select H;
308
309	{
310	# Write out all the known prototype signatures.
311	my $i = 1;
312	for my $p (sort keys %seenp) {
313	print "#define REENTRANT_PROTO_${p} ${i}\n";
314	$i++;
315	}
316	}
317
318	my @struct; # REENTR struct members
319	my @size; # struct member buffer size initialization code
320	my @init; # struct member buffer initialization (malloc) code
321	my @free; # struct member buffer release (free) code
322	my @wrap; # the wrapper (foo(a) -> foo_r(a,...)) cpp code
323	my @define; # defines for optional features
324
325	sub ifprotomatch {
326	my $FUNC = shift;
327	join " \|\| ", map { "${FUNC}_R_PROTO == REENTRANT_PROTO_$_" } @_;
328	}
329
330	sub pushssif {
331	push @struct, @_;
332	push @size, @_;
333	push @init, @_;
334	push @free, @_;
335	}
336
337	sub pushinitfree {
338	my $func = shift;
339	push @init, <<EOF;
340	New(31338, PL_reentrant_buffer->_${func}_buffer, PL_reentrant_buffer->_${func}_size, char);
341	EOF
342	push @free, <<EOF;
343	Safefree(PL_reentrant_buffer->_${func}_buffer);
344	EOF
345	}
346
347	sub define {
348	my ($n, $p, @F) = @_;
349	my @H;
350	my $H = uc $F[0];
351	push @define, <<EOF;
352	/* The @F using \L$n? */
353
354	EOF
355	my $GENFUNC;
356	for my $func (@F) {
357	my $FUNC = uc $func;
358	my $HAS = "${FUNC}_R_HAS_$n";
359	push @H, $HAS;
360	my @h = grep { /$p/ } @{$seena{$func}};
361	unless (defined $GENFUNC) {
362	$GENFUNC = $FUNC;
363	$GENFUNC =~ s/^GET//;
364	}
365	if (@h) {
366	push @define, "#if defined(HAS_${FUNC}_R) && (" . join(" \|\| ", map { "${FUNC}_R_PROTO == REENTRANT_PROTO_$_" } @h) . ")\n";
367
368	push @define, <<EOF;
369	# define $HAS
370	#else
371	# undef $HAS
372	#endif
373	EOF
374	}
375	}
376	return if @F == 1;
377	push @define, <<EOF;
378
379	/* Any of the @F using \L$n? */
380
381	EOF
382	push @define, "#if (" . join(" \|\| ", map { "defined($_)" } @H) . ")\n";
383	push @define, <<EOF;
384	# define USE_${GENFUNC}_$n
385	#else
386	# undef USE_${GENFUNC}_$n
387	#endif
388
389	EOF
390	}
391
392	define('BUFFER', 'B',
393	qw(getgrent getgrgid getgrnam));
394
395	define('PTR', 'R',
396	qw(getgrent getgrgid getgrnam));
397	define('PTR', 'R',
398	qw(getpwent getpwnam getpwuid));
399	define('PTR', 'R',
400	qw(getspent getspnam));
401
402	define('FPTR', 'H',
403	qw(getgrent getgrgid getgrnam setgrent endgrent));
404	define('FPTR', 'H',
405	qw(getpwent getpwnam getpwuid setpwent endpwent));
406
407	define('BUFFER', 'B',
408	qw(getpwent getpwgid getpwnam));
409
410	define('PTR', 'R',
411	qw(gethostent gethostbyaddr gethostbyname));
412	define('PTR', 'R',
413	qw(getnetent getnetbyaddr getnetbyname));
414	define('PTR', 'R',
415	qw(getprotoent getprotobyname getprotobynumber));
416	define('PTR', 'R',
417	qw(getservent getservbyname getservbyport));
418
419	define('BUFFER', 'B',
420	qw(gethostent gethostbyaddr gethostbyname));
421	define('BUFFER', 'B',
422	qw(getnetent getnetbyaddr getnetbyname));
423	define('BUFFER', 'B',
424	qw(getprotoent getprotobyname getprotobynumber));
425	define('BUFFER', 'B',
426	qw(getservent getservbyname getservbyport));
427
428	define('ERRNO', 'E',
429	qw(gethostent gethostbyaddr gethostbyname));
430	define('ERRNO', 'E',
431	qw(getnetent getnetbyaddr getnetbyname));
432
433	# The following loop accumulates the "ssif" (struct, size, init, free)
434	# sections that declare the struct members (in reentr.h), and the buffer
435	# size initialization, buffer initialization (malloc), and buffer
436	# release (free) code (in reentr.c).
437	#
438	# The loop also contains a lot of intrinsic logic about groups of
439	# functions (since functions of certain kind operate the same way).
440
441	for my $func (@seenf) {
442	my $FUNC = uc $func;
443	my $ifdef = "#ifdef HAS_${FUNC}_R\n";
444	my $endif = "#endif /* HAS_${FUNC}_R */\n";
445	if (exists $seena{$func}) {
446	my @p = @{$seena{$func}};
447	if ($func =~ /^(asctime\|ctime\|getlogin\|setlocale\|strerror\|ttyname)$/) {
448	pushssif $ifdef;
449	push @struct, <<EOF;
450	char* _${func}_buffer;
451	size_t _${func}_size;
452	EOF
453	push @size, <<EOF;
454	PL_reentrant_buffer->_${func}_size = REENTRANTSMALLSIZE;
455	EOF
456	pushinitfree $func;
457	pushssif $endif;
458	}
459	elsif ($func =~ /^(crypt)$/) {
460	pushssif $ifdef;
461	push @struct, <<EOF;
462	#if CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD
463	$seend{$func} _${func}_data;
464	#else
465	$seent{$func} _${func}_struct;
466	#endif
467	EOF
468	push @init, <<EOF;
469	#if CRYPT_R_PROTO != REENTRANT_PROTO_B_CCD
470	PL_reentrant_buffer->_${func}_struct_buffer = 0;
471	#endif
472	EOF
473	push @free, <<EOF;
474	#if CRYPT_R_PROTO != REENTRANT_PROTO_B_CCD
475	Safefree(PL_reentrant_buffer->_${func}_struct_buffer);
476	#endif
477	EOF
478	pushssif $endif;
479	}
480	elsif ($func =~ /^(drand48\|gmtime\|localtime)$/) {
481	pushssif $ifdef;
482	push @struct, <<EOF;
483	$seent{$func} _${func}_struct;
484	EOF
485	if ($1 eq 'drand48') {
486	push @struct, <<EOF;
487	double _${func}_double;
488	EOF
489	}
490	pushssif $endif;
491	}
492	elsif ($func =~ /^random$/) {
493	pushssif $ifdef;
494	push @struct, <<EOF;
495	# if RANDOM_R_PROTO != REENTRANT_PROTO_I_St
496	$seent{$func} _${func}_struct;
497	# endif
498	EOF
499	pushssif $endif;
500	}
501	elsif ($func =~ /^(getgrnam\|getpwnam\|getspnam)$/) {
502	pushssif $ifdef;
503	# 'genfunc' can be read either as 'generic' or 'genre',
504	# it represents a group of functions.
505	my $genfunc = $func;
506	$genfunc =~ s/nam/ent/g;
507	$genfunc =~ s/^get//;
508	my $GENFUNC = uc $genfunc;
509	push @struct, <<EOF;
510	$seent{$func} _${genfunc}_struct;
511	char* _${genfunc}_buffer;
512	size_t _${genfunc}_size;
513	EOF
514	push @struct, <<EOF;
515	# ifdef USE_${GENFUNC}_PTR
516	$seent{$func}* _${genfunc}_ptr;
517	# endif
518	EOF
519	push @struct, <<EOF;
520	# ifdef USE_${GENFUNC}_FPTR
521	FILE* _${genfunc}_fptr;
522	# endif
523	EOF
524	push @init, <<EOF;
525	# ifdef USE_${GENFUNC}_FPTR
526	PL_reentrant_buffer->_${genfunc}_fptr = NULL;
527	# endif
528	EOF
529	my $sc = $genfunc eq 'grent' ?
530	'_SC_GETGR_R_SIZE_MAX' : '_SC_GETPW_R_SIZE_MAX';
531	my $sz = "_${genfunc}_size";
532	push @size, <<EOF;
533	# if defined(HAS_SYSCONF) && defined($sc) && !defined(__GLIBC__)
534	PL_reentrant_buffer->$sz = sysconf($sc);
535	if (PL_reentrant_buffer->$sz == -1)
536	PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE;
537	# else
538	# if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ)
539	PL_reentrant_buffer->$sz = SIABUFSIZ;
540	# else
541	# ifdef __sgi
542	PL_reentrant_buffer->$sz = BUFSIZ;
543	# else
544	PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE;
545	# endif
546	# endif
547	# endif
548	EOF
549	pushinitfree $genfunc;
550	pushssif $endif;
551	}
552	elsif ($func =~ /^(gethostbyname\|getnetbyname\|getservbyname\|getprotobyname)$/) {
553	pushssif $ifdef;
554	my $genfunc = $func;
555	$genfunc =~ s/byname/ent/;
556	$genfunc =~ s/^get//;
557	my $GENFUNC = uc $genfunc;
558	my $D = ifprotomatch($FUNC, grep {/D/} @p);
559	my $d = $seend{$func};
560	$d =~ s/\*$//; # snip: we need need the base type.
561	push @struct, <<EOF;
562	$seent{$func} _${genfunc}_struct;
563	# if $D
564	$d _${genfunc}_data;
565	# else
566	char* _${genfunc}_buffer;
567	size_t _${genfunc}_size;
568	# endif
569	# ifdef USE_${GENFUNC}_PTR
570	$seent{$func}* _${genfunc}_ptr;
571	# endif
572	EOF
573	push @struct, <<EOF;
574	# ifdef USE_${GENFUNC}_ERRNO
575	int _${genfunc}_errno;
576	# endif
577	EOF
578	push @size, <<EOF;
579	#if !($D)
580	PL_reentrant_buffer->_${genfunc}_size = REENTRANTUSUALSIZE;
581	#endif
582	EOF
583	push @init, <<EOF;
584	#if !($D)
585	New(31338, PL_reentrant_buffer->_${genfunc}_buffer, PL_reentrant_buffer->_${genfunc}_size, char);
586	#endif
587	EOF
588	push @free, <<EOF;
589	#if !($D)
590	Safefree(PL_reentrant_buffer->_${genfunc}_buffer);
591	#endif
592	EOF
593	pushssif $endif;
594	}
595	elsif ($func =~ /^(readdir\|readdir64)$/) {
596	pushssif $ifdef;
597	my $R = ifprotomatch($FUNC, grep {/R/} @p);
598	push @struct, <<EOF;
599	$seent{$func}* _${func}_struct;
600	size_t _${func}_size;
601	# if $R
602	$seent{$func}* _${func}_ptr;
603	# endif
604	EOF
605	push @size, <<EOF;
606	/* This is the size Solaris recommends.
607	* (though we go static, should use pathconf() instead) */
608	PL_reentrant_buffer->_${func}_size = sizeof($seent{$func}) + MAXPATHLEN + 1;
609	EOF
610	push @init, <<EOF;
611	PL_reentrant_buffer->_${func}_struct = ($seent{$func}*)safemalloc(PL_reentrant_buffer->_${func}_size);
612	EOF
613	push @free, <<EOF;
614	Safefree(PL_reentrant_buffer->_${func}_struct);
615	EOF
616	pushssif $endif;
617	}
618
619	push @wrap, $ifdef;
620
621	push @wrap, <<EOF;
622	# undef $func
623	EOF
624
625	# Write out what we have learned.
626
627	my @v = 'a'..'z';
628	my $v = join(", ", @v[0..$seenu{$func}-1]);
629	for my $p (@p) {
630	my ($r, $a) = split '_', $p;
631	my $test = $r eq 'I' ? ' == 0' : '';
632	my $true = 1;
633	my $genfunc = $func;
634	if ($genfunc =~ /^(?:get\|set\|end)(pw\|gr\|host\|net\|proto\|serv\|sp)/) {
635	$genfunc = "${1}ent";
636	} elsif ($genfunc eq 'srand48') {
637	$genfunc = "drand48";
638	}
639	my $b = $a;
640	my $w = '';
641	substr($b, 0, $seenu{$func}) = '';
642	if ($func =~ /^random$/) {
643	$true = "PL_reentrant_buffer->_random_retval";
644	} elsif ($b =~ /R/) {
645	$true = "PL_reentrant_buffer->_${genfunc}_ptr";
646	} elsif ($b =~ /T/ && $func eq 'drand48') {
647	$true = "PL_reentrant_buffer->_${genfunc}_double";
648	} elsif ($b =~ /S/) {
649	if ($func =~ /^readdir/) {
650	$true = "PL_reentrant_buffer->_${genfunc}_struct";
651	} else {
652	$true = "&PL_reentrant_buffer->_${genfunc}_struct";
653	}
654	} elsif ($b =~ /B/) {
655	$true = "PL_reentrant_buffer->_${genfunc}_buffer";
656	}
657	if (length $b) {
658	$w = join ", ",
659	map {
660	$_ eq 'R' ?
661	"&PL_reentrant_buffer->_${genfunc}_ptr" :
662	$_ eq 'E' ?
663	"&PL_reentrant_buffer->_${genfunc}_errno" :
664	$_ eq 'B' ?
665	"PL_reentrant_buffer->_${genfunc}_buffer" :
666	$_ =~ /^[WI]$/ ?
667	"PL_reentrant_buffer->_${genfunc}_size" :
668	$_ eq 'H' ?
669	"&PL_reentrant_buffer->_${genfunc}_fptr" :
670	$_ eq 'D' ?
671	"&PL_reentrant_buffer->_${genfunc}_data" :
672	$_ eq 'S' ?
673	($func =~ /^readdir\d*$/ ?
674	"PL_reentrant_buffer->_${genfunc}_struct" :
675	$func =~ /^crypt$/ ?
676	"PL_reentrant_buffer->_${genfunc}_struct_buffer" :
677	"&PL_reentrant_buffer->_${genfunc}_struct") :
678	$_ eq 'T' && $func eq 'drand48' ?
679	"&PL_reentrant_buffer->_${genfunc}_double" :
680	$_ =~ /^[ilt]$/ && $func eq 'random' ?
681	"&PL_reentrant_buffer->_random_retval" :
682	$_
683	} split '', $b;
684	$w = ", $w" if length $v;
685	}
686	my $call = "${func}_r($v$w)";
687	push @wrap, <<EOF;
688	# if !defined($func) && ${FUNC}_R_PROTO == REENTRANT_PROTO_$p
689	EOF
690	if ($r eq 'V' \|\| $r eq 'B') {
691	push @wrap, <<EOF;
692	# define $func($v) $call
693	EOF
694	} else {
695	if ($func =~ /^get/) {
696	my $rv = $v ? ", $v" : "";
697	if ($r eq 'I') {
698	$call = qq[((PL_REENTRANT_RETINT = $call)$test ? $true : (((PL_REENTRANT_RETINT == ERANGE) \|\| (errno == ERANGE)) ? ($seenm{$func}{$seenr{$func}})Perl_reentrant_retry("$func"$rv) : 0))];
699	my $arg = join(", ", map { $seenm{$func}{substr($a,$_,1)}." ".$v[$_] } 0..$seenu{$func}-1);
700	my $ret = $seenr{$func} eq 'V' ? "" : "return ";
701	push @wrap, <<EOF;
702	# ifdef PERL_CORE
703	# define $func($v) $call
704	# else
705	# if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
706	# define $func($v) ({int PL_REENTRANT_RETINT; $call;})
707	# else
708	# define $func($v) Perl_reentr_$func($v)
709	static $seenm{$func}{$seenr{$func}} Perl_reentr_$func($arg) {
710	dTHX;
711	int PL_REENTRANT_RETINT;
712	$ret$call;
713	}
714	# endif
715	# endif
716	EOF
717	} else {
718	push @wrap, <<EOF;
719	# define $func($v) ($call$test ? $true : ((errno == ERANGE) ? Perl_reentrant_retry("$func"$rv) : 0))
720	EOF
721	}
722	} else {
723	push @wrap, <<EOF;
724	# define $func($v) ($call$test ? $true : 0)
725	EOF
726	}
727	}
728	push @wrap, <<EOF;
729	# endif
730	EOF
731	}
732
733	push @wrap, $endif, "\n";
734	}
735	}
736
737	# New struct members added here to maintain binary compatibility with 5.8.0
738
739	if (exists $seena{crypt}) {
740	push @struct, <<EOF;
741	#ifdef HAS_CRYPT_R
742	#if CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD
743	#else
744	struct crypt_data *_crypt_struct_buffer;
745	#endif
746	#endif /* HAS_CRYPT_R */
747	EOF
748	}
749
750	if (exists $seena{random}) {
751	push @struct, <<EOF;
752	#ifdef HAS_RANDOM_R
753	# if RANDOM_R_PROTO == REENTRANT_PROTO_I_iS
754	int _random_retval;
755	# endif
756	# if RANDOM_R_PROTO == REENTRANT_PROTO_I_lS
757	long _random_retval;
758	# endif
759	# if RANDOM_R_PROTO == REENTRANT_PROTO_I_St
760	$seent{random} _random_struct;
761	int32_t _random_retval;
762	# endif
763	#endif /* HAS_RANDOM_R */
764	EOF
765	}
766
767	if (exists $seena{srandom}) {
768	push @struct, <<EOF;
769	#ifdef HAS_SRANDOM_R
770	$seent{srandom} _srandom_struct;
771	#endif /* HAS_SRANDOM_R */
772	EOF
773	}
774
775
776	local $" = '';
777
778	print <<EOF;
779
780	/* Defines for indicating which special features are supported. */
781
782	@define
783	typedef struct {
784	@struct
785	int dummy; /* cannot have empty structs */
786	} REENTR;
787
788	#endif /* USE_REENTRANT_API */
789
790	#endif
791	EOF
792
793	close(H);
794
795	die "reentr.inc: $!" unless open(H, ">reentr.inc");
796	select H;
797
798	local $" = '';
799
800	print <<EOF;
801	/*
802	* reentr.inc
803	*
804	* You may distribute under the terms of either the GNU General Public
805	* License or the Artistic License, as specified in the README file.
806	*
807	* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
808	* This file is built by reentrl.pl from data in reentr.pl.
809	*/
810
811	#ifndef REENTRINC
812	#define REENTRINC
813
814	#ifdef USE_REENTRANT_API
815
816	/* The reentrant wrappers. */
817
818	@wrap
819
820	#endif /* USE_REENTRANT_API */
821
822	#endif
823
824	EOF
825
826	close(H);
827
828	# Prepare to write the reentr.c.
829
830	die "reentr.c: $!" unless open(C, ">reentr.c");
831	select C;
832	print <<EOF;
833	/*
834	* reentr.c
835	*
836	* Copyright (C) 2002, 2003, by Larry Wall and others
837	*
838	* You may distribute under the terms of either the GNU General Public
839	* License or the Artistic License, as specified in the README file.
840	*
841	* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
842	* This file is built by reentrl.pl from data in reentr.pl.
843	*
844	* "Saruman," I said, standing away from him, "only one hand at a time can
845	* wield the One, and you know that well, so do not trouble to say we!"
846	*
847	*/
848
849	#include "EXTERN.h"
850	#define PERL_IN_REENTR_C
851	#include "perl.h"
852	#include "reentr.h"
853
854	void
855	Perl_reentrant_size(pTHX) {
856	#ifdef USE_REENTRANT_API
857	#define REENTRANTSMALLSIZE 256 /* Make something up. */
858	#define REENTRANTUSUALSIZE 4096 /* Make something up. */
859	@size
860	#endif /* USE_REENTRANT_API */
861	}
862
863	void
864	Perl_reentrant_init(pTHX) {
865	#ifdef USE_REENTRANT_API
866	New(31337, PL_reentrant_buffer, 1, REENTR);
867	Perl_reentrant_size(aTHX);
868	@init
869	#endif /* USE_REENTRANT_API */
870	}
871
872	void
873	Perl_reentrant_free(pTHX) {
874	#ifdef USE_REENTRANT_API
875	@free
876	Safefree(PL_reentrant_buffer);
877	#endif /* USE_REENTRANT_API */
878	}
879
880	void*
881	Perl_reentrant_retry(const char *f, ...)
882	{
883	dTHX;
884	void *retptr = NULL;
885	#ifdef USE_REENTRANT_API
886	# if defined(USE_HOSTENT_BUFFER) \|\| defined(USE_GRENT_BUFFER) \|\| defined(USE_NETENT_BUFFER) \|\| defined(USE_PWENT_BUFFER) \|\| defined(USE_PROTOENT_BUFFER) \|\| defined(USE_SERVENT_BUFFER)
887	void *p0;
888	# endif
889	# if defined(USE_SERVENT_BUFFER)
890	void *p1;
891	# endif
892	# if defined(USE_HOSTENT_BUFFER)
893	size_t asize;
894	# endif
895	# if defined(USE_HOSTENT_BUFFER) \|\| defined(USE_NETENT_BUFFER) \|\| defined(USE_PROTOENT_BUFFER) \|\| defined(USE_SERVENT_BUFFER)
896	int anint;
897	# endif
898	va_list ap;
899
900	va_start(ap, f);
901
902	switch (PL_op->op_type) {
903	#ifdef USE_HOSTENT_BUFFER
904	case OP_GHBYADDR:
905	case OP_GHBYNAME:
906	case OP_GHOSTENT:
907	{
908	#ifdef PERL_REENTRANT_MAXSIZE
909	if (PL_reentrant_buffer->_hostent_size <=
910	PERL_REENTRANT_MAXSIZE / 2)
911	#endif
912	{
913	PL_reentrant_buffer->_hostent_size *= 2;
914	Renew(PL_reentrant_buffer->_hostent_buffer,
915	PL_reentrant_buffer->_hostent_size, char);
916	switch (PL_op->op_type) {
917	case OP_GHBYADDR:
918	p0 = va_arg(ap, void *);
919	asize = va_arg(ap, size_t);
920	anint = va_arg(ap, int);
921	retptr = gethostbyaddr(p0, asize, anint); break;
922	case OP_GHBYNAME:
923	p0 = va_arg(ap, void *);
924	retptr = gethostbyname(p0); break;
925	case OP_GHOSTENT:
926	retptr = gethostent(); break;
927	default:
928	SETERRNO(ERANGE, LIB_INVARG);
929	break;
930	}
931	}
932	}
933	break;
934	#endif
935	#ifdef USE_GRENT_BUFFER
936	case OP_GGRNAM:
937	case OP_GGRGID:
938	case OP_GGRENT:
939	{
940	#ifdef PERL_REENTRANT_MAXSIZE
941	if (PL_reentrant_buffer->_grent_size <=
942	PERL_REENTRANT_MAXSIZE / 2)
943	#endif
944	{
945	Gid_t gid;
946	PL_reentrant_buffer->_grent_size *= 2;
947	Renew(PL_reentrant_buffer->_grent_buffer,
948	PL_reentrant_buffer->_grent_size, char);
949	switch (PL_op->op_type) {
950	case OP_GGRNAM:
951	p0 = va_arg(ap, void *);
952	retptr = getgrnam(p0); break;
953	case OP_GGRGID:
954	#if Gid_t_size < INTSIZE
955	gid = (Gid_t)va_arg(ap, int);
956	#else
957	gid = va_arg(ap, Gid_t);
958	#endif
959	retptr = getgrgid(gid); break;
960	case OP_GGRENT:
961	retptr = getgrent(); break;
962	default:
963	SETERRNO(ERANGE, LIB_INVARG);
964	break;
965	}
966	}
967	}
968	break;
969	#endif
970	#ifdef USE_NETENT_BUFFER
971	case OP_GNBYADDR:
972	case OP_GNBYNAME:
973	case OP_GNETENT:
974	{
975	#ifdef PERL_REENTRANT_MAXSIZE
976	if (PL_reentrant_buffer->_netent_size <=
977	PERL_REENTRANT_MAXSIZE / 2)
978	#endif
979	{
980	Netdb_net_t net;
981	PL_reentrant_buffer->_netent_size *= 2;
982	Renew(PL_reentrant_buffer->_netent_buffer,
983	PL_reentrant_buffer->_netent_size, char);
984	switch (PL_op->op_type) {
985	case OP_GNBYADDR:
986	net = va_arg(ap, Netdb_net_t);
987	anint = va_arg(ap, int);
988	retptr = getnetbyaddr(net, anint); break;
989	case OP_GNBYNAME:
990	p0 = va_arg(ap, void *);
991	retptr = getnetbyname(p0); break;
992	case OP_GNETENT:
993	retptr = getnetent(); break;
994	default:
995	SETERRNO(ERANGE, LIB_INVARG);
996	break;
997	}
998	}
999	}
1000	break;
1001	#endif
1002	#ifdef USE_PWENT_BUFFER
1003	case OP_GPWNAM:
1004	case OP_GPWUID:
1005	case OP_GPWENT:
1006	{
1007	#ifdef PERL_REENTRANT_MAXSIZE
1008	if (PL_reentrant_buffer->_pwent_size <=
1009	PERL_REENTRANT_MAXSIZE / 2)
1010	#endif
1011	{
1012	Uid_t uid;
1013	PL_reentrant_buffer->_pwent_size *= 2;
1014	Renew(PL_reentrant_buffer->_pwent_buffer,
1015	PL_reentrant_buffer->_pwent_size, char);
1016	switch (PL_op->op_type) {
1017	case OP_GPWNAM:
1018	p0 = va_arg(ap, void *);
1019	retptr = getpwnam(p0); break;
1020	case OP_GPWUID:
1021	#if Uid_t_size < INTSIZE
1022	uid = (Uid_t)va_arg(ap, int);
1023	#else
1024	uid = va_arg(ap, Uid_t);
1025	#endif
1026	retptr = getpwuid(uid); break;
1027	case OP_GPWENT:
1028	retptr = getpwent(); break;
1029	default:
1030	SETERRNO(ERANGE, LIB_INVARG);
1031	break;
1032	}
1033	}
1034	}
1035	break;
1036	#endif
1037	#ifdef USE_PROTOENT_BUFFER
1038	case OP_GPBYNAME:
1039	case OP_GPBYNUMBER:
1040	case OP_GPROTOENT:
1041	{
1042	#ifdef PERL_REENTRANT_MAXSIZE
1043	if (PL_reentrant_buffer->_protoent_size <=
1044	PERL_REENTRANT_MAXSIZE / 2)
1045	#endif
1046	{
1047	PL_reentrant_buffer->_protoent_size *= 2;
1048	Renew(PL_reentrant_buffer->_protoent_buffer,
1049	PL_reentrant_buffer->_protoent_size, char);
1050	switch (PL_op->op_type) {
1051	case OP_GPBYNAME:
1052	p0 = va_arg(ap, void *);
1053	retptr = getprotobyname(p0); break;
1054	case OP_GPBYNUMBER:
1055	anint = va_arg(ap, int);
1056	retptr = getprotobynumber(anint); break;
1057	case OP_GPROTOENT:
1058	retptr = getprotoent(); break;
1059	default:
1060	SETERRNO(ERANGE, LIB_INVARG);
1061	break;
1062	}
1063	}
1064	}
1065	break;
1066	#endif
1067	#ifdef USE_SERVENT_BUFFER
1068	case OP_GSBYNAME:
1069	case OP_GSBYPORT:
1070	case OP_GSERVENT:
1071	{
1072	#ifdef PERL_REENTRANT_MAXSIZE
1073	if (PL_reentrant_buffer->_servent_size <=
1074	PERL_REENTRANT_MAXSIZE / 2)
1075	#endif
1076	{
1077	PL_reentrant_buffer->_servent_size *= 2;
1078	Renew(PL_reentrant_buffer->_servent_buffer,
1079	PL_reentrant_buffer->_servent_size, char);
1080	switch (PL_op->op_type) {
1081	case OP_GSBYNAME:
1082	p0 = va_arg(ap, void *);
1083	p1 = va_arg(ap, void *);
1084	retptr = getservbyname(p0, p1); break;
1085	case OP_GSBYPORT:
1086	anint = va_arg(ap, int);
1087	p0 = va_arg(ap, void *);
1088	retptr = getservbyport(anint, p0); break;
1089	case OP_GSERVENT:
1090	retptr = getservent(); break;
1091	default:
1092	SETERRNO(ERANGE, LIB_INVARG);
1093	break;
1094	}
1095	}
1096	}
1097	break;
1098	#endif
1099	default:
1100	/* Not known how to retry, so just fail. */
1101	break;
1102	}
1103
1104	va_end(ap);
1105	#endif
1106	return retptr;
1107	}
1108
1109	EOF
1110
1111	__DATA__
1112	asctime B_S \|time \|const struct tm\|B_SB\|B_SBI\|I_SB\|I_SBI
1113	crypt B_CC \|crypt \|struct crypt_data\|B_CCS\|B_CCD\|D=CRYPTD*
1114	ctermid B_B \|stdio \| \|B_B
1115	ctime B_S \|time \|const time_t \|B_SB\|B_SBI\|I_SB\|I_SBI
1116	drand48 d_V \|stdlib \|struct drand48_data \|I_ST\|T=double*\|d=double
1117	endgrent \|grp \| \|I_H\|V_H
1118	endhostent \|netdb \| \|I_D\|V_D\|D=struct hostent_data*
1119	endnetent \|netdb \| \|I_D\|V_D\|D=struct netent_data*
1120	endprotoent \|netdb \| \|I_D\|V_D\|D=struct protoent_data*
1121	endpwent \|pwd \| \|I_H\|V_H
1122	endservent \|netdb \| \|I_D\|V_D\|D=struct servent_data*
1123	getgrent S_V \|grp \|struct group \|I_SBWR\|I_SBIR\|S_SBW\|S_SBI\|I_SBI\|I_SBIH
1124	getgrgid S_T \|grp \|struct group \|I_TSBWR\|I_TSBIR\|I_TSBI\|S_TSBI\|T=gid_t
1125	getgrnam S_C \|grp \|struct group \|I_CSBWR\|I_CSBIR\|S_CBI\|I_CSBI\|S_CSBI
1126	gethostbyaddr S_CWI \|netdb \|struct hostent \|I_CWISBWRE\|S_CWISBWIE\|S_CWISBIE\|S_TWISBIE\|S_CIISBIE\|S_CSBIE\|S_TSBIE\|I_CWISD\|I_CIISD\|I_CII\|I_TsISBWRE\|D=struct hostent_data\|T=const void\|s=socklen_t
1127	gethostbyname S_C \|netdb \|struct hostent \|I_CSBWRE\|S_CSBIE\|I_CSD\|D=struct hostent_data*
1128	gethostent S_V \|netdb \|struct hostent \|I_SBWRE\|I_SBIE\|S_SBIE\|S_SBI\|I_SBI\|I_SD\|D=struct hostent_data*
1129	getlogin B_V \|unistd \| \|I_BW\|I_BI\|B_BW\|B_BI
1130	getnetbyaddr S_LI \|netdb \|struct netent \|I_UISBWRE\|I_LISBI\|S_TISBI\|S_LISBI\|I_TISD\|I_LISD\|I_IISD\|I_uISBWRE\|D=struct netent_data*\|T=in_addr_t\|U=unsigned long\|u=uint32_t
1131	getnetbyname S_C \|netdb \|struct netent \|I_CSBWRE\|I_CSBI\|S_CSBI\|I_CSD\|D=struct netent_data*
1132	getnetent S_V \|netdb \|struct netent \|I_SBWRE\|I_SBIE\|S_SBIE\|S_SBI\|I_SBI\|I_SD\|D=struct netent_data*
1133	getprotobyname S_C \|netdb \|struct protoent\|I_CSBWR\|S_CSBI\|I_CSD\|D=struct protoent_data*
1134	getprotobynumber S_I \|netdb \|struct protoent\|I_ISBWR\|S_ISBI\|I_ISD\|D=struct protoent_data*
1135	getprotoent S_V \|netdb \|struct protoent\|I_SBWR\|I_SBI\|S_SBI\|I_SD\|D=struct protoent_data*
1136	getpwent S_V \|pwd \|struct passwd \|I_SBWR\|I_SBIR\|S_SBW\|S_SBI\|I_SBI\|I_SBIH
1137	getpwnam S_C \|pwd \|struct passwd \|I_CSBWR\|I_CSBIR\|S_CSBI\|I_CSBI
1138	getpwuid S_T \|pwd \|struct passwd \|I_TSBWR\|I_TSBIR\|I_TSBI\|S_TSBI\|T=uid_t
1139	getservbyname S_CC \|netdb \|struct servent \|I_CCSBWR\|S_CCSBI\|I_CCSD\|D=struct servent_data*
1140	getservbyport S_IC \|netdb \|struct servent \|I_ICSBWR\|S_ICSBI\|I_ICSD\|D=struct servent_data*
1141	getservent S_V \|netdb \|struct servent \|I_SBWR\|I_SBI\|S_SBI\|I_SD\|D=struct servent_data*
1142	getspnam S_C \|shadow \|struct spwd \|I_CSBWR\|S_CSBI
1143	gmtime S_T \|time \|struct tm \|S_TS\|I_TS\|T=const time_t*
1144	localtime S_T \|time \|struct tm \|S_TS\|I_TS\|T=const time_t*
1145	random L_V \|stdlib \|struct random_data\|I_iS\|I_lS\|I_St\|i=int\|l=long\|t=int32_t*
1146	readdir S_T \|dirent \|struct dirent \|I_TSR\|I_TS\|T=DIR*
1147	readdir64 S_T \|dirent \|struct dirent64\|I_TSR\|I_TS\|T=DIR*
1148	setgrent \|grp \| \|I_H\|V_H
1149	sethostent V_I \|netdb \| \|I_ID\|V_ID\|D=struct hostent_data*
1150	setlocale B_IC \|locale \| \|I_ICBI
1151	setnetent V_I \|netdb \| \|I_ID\|V_ID\|D=struct netent_data*
1152	setprotoent V_I \|netdb \| \|I_ID\|V_ID\|D=struct protoent_data*
1153	setpwent \|pwd \| \|I_H\|V_H
1154	setservent V_I \|netdb \| \|I_ID\|V_ID\|D=struct servent_data*
1155	srand48 V_L \|stdlib \|struct drand48_data \|I_LS
1156	srandom V_T \|stdlib \|struct random_data\|I_TS\|T=unsigned int
1157	strerror B_I \|string \| \|I_IBW\|I_IBI\|B_IBW
1158	tmpnam B_B \|stdio \| \|B_B
1159	ttyname B_I \|unistd \| \|I_IBW\|I_IBI\|B_IBI

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

Context Navigation

source: trunk/third/perl/reentr.pl @ 20075

Download in other formats: