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