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