Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

reentr.pl@ 3898

Visit:

Last change on this file since 3898 was 3181, checked in by bird, 19 years ago
perl 5.8.8
File size: 32.0 KB

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

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

Context Navigation

source: trunk/essentials/dev-lang/perl/reentr.pl@ 3898

Download in other formats: