ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/staticperl/perl/reentr.pl
Revision: 1.1
Committed: Thu Jun 30 14:26:42 2005 UTC (21 years, 3 months ago) by root
Content type: text/plain
Branch: MAIN
CVS Tags: HEAD
Branch point for: PERL
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.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, 2005 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 reentr.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: d_${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    
688     # Must make OpenBSD happy
689     my $memzero = '';
690     if($p =~ /D$/ &&
691     ($genfunc eq 'protoent' || $genfunc eq 'servent')) {
692     $memzero = 'REENTR_MEMZERO(&PL_reentrant_buffer->_' . $genfunc . '_data, sizeof(PL_reentrant_buffer->_' . $genfunc . '_data))';
693     }
694     push @wrap, <<EOF;
695     # if !defined($func) && ${FUNC}_R_PROTO == REENTRANT_PROTO_$p
696     EOF
697     if ($r eq 'V' || $r eq 'B') {
698     push @wrap, <<EOF;
699     # define $func($v) $call
700     EOF
701     } else {
702     if ($func =~ /^get/) {
703     my $rv = $v ? ", $v" : "";
704     if ($r eq 'I') {
705     $call = qq[((PL_REENTRANT_RETINT = $call)$test ? $true : (((PL_REENTRANT_RETINT == ERANGE) || (errno == ERANGE)) ? ($seenm{$func}{$seenr{$func}})Perl_reentrant_retry("$func"$rv) : 0))];
706     my $arg = join(", ", map { $seenm{$func}{substr($a,$_,1)}." ".$v[$_] } 0..$seenu{$func}-1);
707     my $ret = $seenr{$func} eq 'V' ? "" : "return ";
708     my $memzero_ = $memzero ? "$memzero, " : "";
709     push @wrap, <<EOF;
710     # ifdef PERL_CORE
711     # define $func($v) ($memzero_$call)
712     # else
713     # if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
714     # define $func($v) ({int PL_REENTRANT_RETINT; $memzero; $call;})
715     # else
716     # define $func($v) Perl_reentr_$func($v)
717     static $seenm{$func}{$seenr{$func}} Perl_reentr_$func($arg) {
718     dTHX;
719     int PL_REENTRANT_RETINT;
720     $memzero;
721     $ret$call;
722     }
723     # endif
724     # endif
725     EOF
726     } else {
727     push @wrap, <<EOF;
728     # define $func($v) ($call$test ? $true : ((errno == ERANGE) ? ($seent{$func} *) Perl_reentrant_retry("$func"$rv) : 0))
729     EOF
730     }
731     } else {
732     push @wrap, <<EOF;
733     # define $func($v) ($call$test ? $true : 0)
734     EOF
735     }
736     }
737     push @wrap, <<EOF;
738     # endif
739     EOF
740     }
741    
742     push @wrap, $endif, "\n";
743     }
744     }
745    
746     # New struct members added here to maintain binary compatibility with 5.8.0
747    
748     if (exists $seena{crypt}) {
749     push @struct, <<EOF;
750     #ifdef HAS_CRYPT_R
751     #if CRYPT_R_PROTO == REENTRANT_PROTO_B_CCD
752     #else
753     struct crypt_data *_crypt_struct_buffer;
754     #endif
755     #endif /* HAS_CRYPT_R */
756     EOF
757     }
758    
759     if (exists $seena{random}) {
760     push @struct, <<EOF;
761     #ifdef HAS_RANDOM_R
762     # if RANDOM_R_PROTO == REENTRANT_PROTO_I_iS
763     int _random_retval;
764     # endif
765     # if RANDOM_R_PROTO == REENTRANT_PROTO_I_lS
766     long _random_retval;
767     # endif
768     # if RANDOM_R_PROTO == REENTRANT_PROTO_I_St
769     $seent{random} _random_struct;
770     int32_t _random_retval;
771     # endif
772     #endif /* HAS_RANDOM_R */
773     EOF
774     }
775    
776     if (exists $seena{srandom}) {
777     push @struct, <<EOF;
778     #ifdef HAS_SRANDOM_R
779     $seent{srandom} _srandom_struct;
780     #endif /* HAS_SRANDOM_R */
781     EOF
782     }
783    
784    
785     local $" = '';
786    
787     print <<EOF;
788    
789     /* Defines for indicating which special features are supported. */
790    
791     @define
792     typedef struct {
793     @struct
794     int dummy; /* cannot have empty structs */
795     } REENTR;
796    
797     #endif /* USE_REENTRANT_API */
798    
799     #endif
800     EOF
801    
802     close(H);
803    
804     die "reentr.inc: $!" unless open(H, ">reentr.inc");
805     select H;
806    
807     local $" = '';
808    
809     print <<EOF;
810     /*
811     * reentr.inc
812     *
813     * You may distribute under the terms of either the GNU General Public
814     * License or the Artistic License, as specified in the README file.
815     *
816     * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
817     * This file is built by reentrl.pl from data in reentr.pl.
818     */
819    
820     #ifndef REENTRINC
821     #define REENTRINC
822    
823     #ifdef USE_REENTRANT_API
824    
825     /*
826     * As of OpenBSD 3.7, reentrant functions are now working, they just are
827     * incompatible with everyone else. To make OpenBSD happy, we have to
828     * memzero out certain structures before calling the functions.
829     */
830     #if defined(__OpenBSD__)
831     # define REENTR_MEMZERO(a,b) memzero(a,b)
832     #else
833     # define REENTR_MEMZERO(a,b) 0
834     #endif
835    
836     /* The reentrant wrappers. */
837    
838     @wrap
839    
840     #endif /* USE_REENTRANT_API */
841    
842     #endif
843    
844     EOF
845    
846     close(H);
847    
848     # Prepare to write the reentr.c.
849    
850     die "reentr.c: $!" unless open(C, ">reentr.c");
851     select C;
852     print <<EOF;
853     /*
854     * reentr.c
855     *
856     * Copyright (C) 2002, 2003, by Larry Wall and others
857     *
858     * You may distribute under the terms of either the GNU General Public
859     * License or the Artistic License, as specified in the README file.
860     *
861     * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
862     * This file is built by reentr.pl from data in reentr.pl.
863     *
864     * "Saruman," I said, standing away from him, "only one hand at a time can
865     * wield the One, and you know that well, so do not trouble to say we!"
866     *
867     * This file contains a collection of automatically created wrappers
868     * (created by running reentr.pl) for reentrant (thread-safe) versions of
869     * various library calls, such as getpwent_r. The wrapping is done so
870     * that other files like pp_sys.c calling those library functions need not
871     * care about the differences between various platforms' idiosyncrasies
872     * regarding these reentrant interfaces.
873     */
874    
875     #include "EXTERN.h"
876     #define PERL_IN_REENTR_C
877     #include "perl.h"
878     #include "reentr.h"
879    
880     void
881     Perl_reentrant_size(pTHX) {
882     #ifdef USE_REENTRANT_API
883     #define REENTRANTSMALLSIZE 256 /* Make something up. */
884     #define REENTRANTUSUALSIZE 4096 /* Make something up. */
885     @size
886     #endif /* USE_REENTRANT_API */
887     }
888    
889     void
890     Perl_reentrant_init(pTHX) {
891     #ifdef USE_REENTRANT_API
892     New(31337, PL_reentrant_buffer, 1, REENTR);
893     Perl_reentrant_size(aTHX);
894     @init
895     #endif /* USE_REENTRANT_API */
896     }
897    
898     void
899     Perl_reentrant_free(pTHX) {
900     #ifdef USE_REENTRANT_API
901     @free
902     Safefree(PL_reentrant_buffer);
903     #endif /* USE_REENTRANT_API */
904     }
905    
906     void*
907     Perl_reentrant_retry(const char *f, ...)
908     {
909     dTHX;
910     void *retptr = NULL;
911     #ifdef USE_REENTRANT_API
912     # 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)
913     void *p0;
914     # endif
915     # if defined(USE_SERVENT_BUFFER)
916     void *p1;
917     # endif
918     # if defined(USE_HOSTENT_BUFFER)
919     size_t asize;
920     # endif
921     # if defined(USE_HOSTENT_BUFFER) || defined(USE_NETENT_BUFFER) || defined(USE_PROTOENT_BUFFER) || defined(USE_SERVENT_BUFFER)
922     int anint;
923     # endif
924     va_list ap;
925    
926     va_start(ap, f);
927    
928     switch (PL_op->op_type) {
929     #ifdef USE_HOSTENT_BUFFER
930     case OP_GHBYADDR:
931     case OP_GHBYNAME:
932     case OP_GHOSTENT:
933     {
934     #ifdef PERL_REENTRANT_MAXSIZE
935     if (PL_reentrant_buffer->_hostent_size <=
936     PERL_REENTRANT_MAXSIZE / 2)
937     #endif
938     {
939     PL_reentrant_buffer->_hostent_size *= 2;
940     Renew(PL_reentrant_buffer->_hostent_buffer,
941     PL_reentrant_buffer->_hostent_size, char);
942     switch (PL_op->op_type) {
943     case OP_GHBYADDR:
944     p0 = va_arg(ap, void *);
945     asize = va_arg(ap, size_t);
946     anint = va_arg(ap, int);
947     retptr = gethostbyaddr(p0, asize, anint); break;
948     case OP_GHBYNAME:
949     p0 = va_arg(ap, void *);
950     retptr = gethostbyname((char *)p0); break;
951     case OP_GHOSTENT:
952     retptr = gethostent(); break;
953     default:
954     SETERRNO(ERANGE, LIB_INVARG);
955     break;
956     }
957     }
958     }
959     break;
960     #endif
961     #ifdef USE_GRENT_BUFFER
962     case OP_GGRNAM:
963     case OP_GGRGID:
964     case OP_GGRENT:
965     {
966     #ifdef PERL_REENTRANT_MAXSIZE
967     if (PL_reentrant_buffer->_grent_size <=
968     PERL_REENTRANT_MAXSIZE / 2)
969     #endif
970     {
971     Gid_t gid;
972     PL_reentrant_buffer->_grent_size *= 2;
973     Renew(PL_reentrant_buffer->_grent_buffer,
974     PL_reentrant_buffer->_grent_size, char);
975     switch (PL_op->op_type) {
976     case OP_GGRNAM:
977     p0 = va_arg(ap, void *);
978     retptr = getgrnam((char *)p0); break;
979     case OP_GGRGID:
980     #if Gid_t_size < INTSIZE
981     gid = (Gid_t)va_arg(ap, int);
982     #else
983     gid = va_arg(ap, Gid_t);
984     #endif
985     retptr = getgrgid(gid); break;
986     case OP_GGRENT:
987     retptr = getgrent(); break;
988     default:
989     SETERRNO(ERANGE, LIB_INVARG);
990     break;
991     }
992     }
993     }
994     break;
995     #endif
996     #ifdef USE_NETENT_BUFFER
997     case OP_GNBYADDR:
998     case OP_GNBYNAME:
999     case OP_GNETENT:
1000     {
1001     #ifdef PERL_REENTRANT_MAXSIZE
1002     if (PL_reentrant_buffer->_netent_size <=
1003     PERL_REENTRANT_MAXSIZE / 2)
1004     #endif
1005     {
1006     Netdb_net_t net;
1007     PL_reentrant_buffer->_netent_size *= 2;
1008     Renew(PL_reentrant_buffer->_netent_buffer,
1009     PL_reentrant_buffer->_netent_size, char);
1010     switch (PL_op->op_type) {
1011     case OP_GNBYADDR:
1012     net = va_arg(ap, Netdb_net_t);
1013     anint = va_arg(ap, int);
1014     retptr = getnetbyaddr(net, anint); break;
1015     case OP_GNBYNAME:
1016     p0 = va_arg(ap, void *);
1017     retptr = getnetbyname((char *)p0); break;
1018     case OP_GNETENT:
1019     retptr = getnetent(); break;
1020     default:
1021     SETERRNO(ERANGE, LIB_INVARG);
1022     break;
1023     }
1024     }
1025     }
1026     break;
1027     #endif
1028     #ifdef USE_PWENT_BUFFER
1029     case OP_GPWNAM:
1030     case OP_GPWUID:
1031     case OP_GPWENT:
1032     {
1033     #ifdef PERL_REENTRANT_MAXSIZE
1034     if (PL_reentrant_buffer->_pwent_size <=
1035     PERL_REENTRANT_MAXSIZE / 2)
1036     #endif
1037     {
1038     Uid_t uid;
1039     PL_reentrant_buffer->_pwent_size *= 2;
1040     Renew(PL_reentrant_buffer->_pwent_buffer,
1041     PL_reentrant_buffer->_pwent_size, char);
1042     switch (PL_op->op_type) {
1043     case OP_GPWNAM:
1044     p0 = va_arg(ap, void *);
1045     retptr = getpwnam((char *)p0); break;
1046     case OP_GPWUID:
1047     #if Uid_t_size < INTSIZE
1048     uid = (Uid_t)va_arg(ap, int);
1049     #else
1050     uid = va_arg(ap, Uid_t);
1051     #endif
1052     retptr = getpwuid(uid); break;
1053     case OP_GPWENT:
1054     retptr = getpwent(); break;
1055     default:
1056     SETERRNO(ERANGE, LIB_INVARG);
1057     break;
1058     }
1059     }
1060     }
1061     break;
1062     #endif
1063     #ifdef USE_PROTOENT_BUFFER
1064     case OP_GPBYNAME:
1065     case OP_GPBYNUMBER:
1066     case OP_GPROTOENT:
1067     {
1068     #ifdef PERL_REENTRANT_MAXSIZE
1069     if (PL_reentrant_buffer->_protoent_size <=
1070     PERL_REENTRANT_MAXSIZE / 2)
1071     #endif
1072     {
1073     PL_reentrant_buffer->_protoent_size *= 2;
1074     Renew(PL_reentrant_buffer->_protoent_buffer,
1075     PL_reentrant_buffer->_protoent_size, char);
1076     switch (PL_op->op_type) {
1077     case OP_GPBYNAME:
1078     p0 = va_arg(ap, void *);
1079     retptr = getprotobyname((char *)p0); break;
1080     case OP_GPBYNUMBER:
1081     anint = va_arg(ap, int);
1082     retptr = getprotobynumber(anint); break;
1083     case OP_GPROTOENT:
1084     retptr = getprotoent(); break;
1085     default:
1086     SETERRNO(ERANGE, LIB_INVARG);
1087     break;
1088     }
1089     }
1090     }
1091     break;
1092     #endif
1093     #ifdef USE_SERVENT_BUFFER
1094     case OP_GSBYNAME:
1095     case OP_GSBYPORT:
1096     case OP_GSERVENT:
1097     {
1098     #ifdef PERL_REENTRANT_MAXSIZE
1099     if (PL_reentrant_buffer->_servent_size <=
1100     PERL_REENTRANT_MAXSIZE / 2)
1101     #endif
1102     {
1103     PL_reentrant_buffer->_servent_size *= 2;
1104     Renew(PL_reentrant_buffer->_servent_buffer,
1105     PL_reentrant_buffer->_servent_size, char);
1106     switch (PL_op->op_type) {
1107     case OP_GSBYNAME:
1108     p0 = va_arg(ap, void *);
1109     p1 = va_arg(ap, void *);
1110     retptr = getservbyname((char *)p0, (char *)p1); break;
1111     case OP_GSBYPORT:
1112     anint = va_arg(ap, int);
1113     p0 = va_arg(ap, void *);
1114     retptr = getservbyport(anint, (char *)p0); break;
1115     case OP_GSERVENT:
1116     retptr = getservent(); break;
1117     default:
1118     SETERRNO(ERANGE, LIB_INVARG);
1119     break;
1120     }
1121     }
1122     }
1123     break;
1124     #endif
1125     default:
1126     /* Not known how to retry, so just fail. */
1127     break;
1128     }
1129    
1130     va_end(ap);
1131     #endif
1132     return retptr;
1133     }
1134    
1135     EOF
1136    
1137     __DATA__
1138     asctime B_S |time |const struct tm|B_SB|B_SBI|I_SB|I_SBI
1139     crypt B_CC |crypt |struct crypt_data|B_CCS|B_CCD|D=CRYPTD*
1140     ctermid B_B |stdio | |B_B
1141     ctime B_S |time |const time_t |B_SB|B_SBI|I_SB|I_SBI
1142     drand48 d_V |stdlib |struct drand48_data |I_ST|T=double*|d=double
1143     endgrent |grp | |I_H|V_H
1144     endhostent |netdb | |I_D|V_D|D=struct hostent_data*
1145     endnetent |netdb | |I_D|V_D|D=struct netent_data*
1146     endprotoent |netdb | |I_D|V_D|D=struct protoent_data*
1147     endpwent |pwd | |I_H|V_H
1148     endservent |netdb | |I_D|V_D|D=struct servent_data*
1149     getgrent S_V |grp |struct group |I_SBWR|I_SBIR|S_SBW|S_SBI|I_SBI|I_SBIH
1150     getgrgid S_T |grp |struct group |I_TSBWR|I_TSBIR|I_TSBI|S_TSBI|T=gid_t
1151     getgrnam S_C |grp |struct group |I_CSBWR|I_CSBIR|S_CBI|I_CSBI|S_CSBI
1152     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
1153     gethostbyname S_C |netdb |struct hostent |I_CSBWRE|S_CSBIE|I_CSD|D=struct hostent_data*
1154     gethostent S_V |netdb |struct hostent |I_SBWRE|I_SBIE|S_SBIE|S_SBI|I_SBI|I_SD|D=struct hostent_data*
1155     getlogin B_V |unistd |char |I_BW|I_BI|B_BW|B_BI
1156     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
1157     getnetbyname S_C |netdb |struct netent |I_CSBWRE|I_CSBI|S_CSBI|I_CSD|D=struct netent_data*
1158     getnetent S_V |netdb |struct netent |I_SBWRE|I_SBIE|S_SBIE|S_SBI|I_SBI|I_SD|D=struct netent_data*
1159     getprotobyname S_C |netdb |struct protoent|I_CSBWR|S_CSBI|I_CSD|D=struct protoent_data*
1160     getprotobynumber S_I |netdb |struct protoent|I_ISBWR|S_ISBI|I_ISD|D=struct protoent_data*
1161     getprotoent S_V |netdb |struct protoent|I_SBWR|I_SBI|S_SBI|I_SD|D=struct protoent_data*
1162     getpwent S_V |pwd |struct passwd |I_SBWR|I_SBIR|S_SBW|S_SBI|I_SBI|I_SBIH
1163     getpwnam S_C |pwd |struct passwd |I_CSBWR|I_CSBIR|S_CSBI|I_CSBI
1164     getpwuid S_T |pwd |struct passwd |I_TSBWR|I_TSBIR|I_TSBI|S_TSBI|T=uid_t
1165     getservbyname S_CC |netdb |struct servent |I_CCSBWR|S_CCSBI|I_CCSD|D=struct servent_data*
1166     getservbyport S_IC |netdb |struct servent |I_ICSBWR|S_ICSBI|I_ICSD|D=struct servent_data*
1167     getservent S_V |netdb |struct servent |I_SBWR|I_SBI|S_SBI|I_SD|D=struct servent_data*
1168     getspnam S_C |shadow |struct spwd |I_CSBWR|S_CSBI
1169     gmtime S_T |time |struct tm |S_TS|I_TS|T=const time_t*
1170     localtime S_T |time |struct tm |S_TS|I_TS|T=const time_t*
1171     random L_V |stdlib |struct random_data|I_iS|I_lS|I_St|i=int*|l=long*|t=int32_t*
1172     readdir S_T |dirent |struct dirent |I_TSR|I_TS|T=DIR*
1173     readdir64 S_T |dirent |struct dirent64|I_TSR|I_TS|T=DIR*
1174     setgrent |grp | |I_H|V_H
1175     sethostent V_I |netdb | |I_ID|V_ID|D=struct hostent_data*
1176     setlocale B_IC |locale | |I_ICBI
1177     setnetent V_I |netdb | |I_ID|V_ID|D=struct netent_data*
1178     setprotoent V_I |netdb | |I_ID|V_ID|D=struct protoent_data*
1179     setpwent |pwd | |I_H|V_H
1180     setservent V_I |netdb | |I_ID|V_ID|D=struct servent_data*
1181     srand48 V_L |stdlib |struct drand48_data |I_LS
1182     srandom V_T |stdlib |struct random_data|I_TS|T=unsigned int
1183     strerror B_I |string | |I_IBW|I_IBI|B_IBW
1184     tmpnam B_B |stdio | |B_B
1185     ttyname B_I |unistd | |I_IBW|I_IBI|B_IBI