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