X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d6b7ef8642dbff7f74dde11fd4995a37e8f38c04..b69b1b834090b8cd183851bd96f347fb4bca3004:/reentr.pl diff --git a/reentr.pl b/reentr.pl index ae56377..13cf4d1 100644 --- a/reentr.pl +++ b/reentr.pl @@ -5,6 +5,11 @@ # and optionally also the relevant metaconfig units (-U option). # +BEGIN { + # Get function prototypes + require 'regen_lib.pl'; +} + use strict; use Getopt::Std; my %opts; @@ -35,23 +40,26 @@ my %map = ( # Example #3: S_CBI means type func_r(const char*, char*, int) +safer_unlink 'reentr.h'; die "reentr.h: $!" unless open(H, ">reentr.h"); +binmode H; select H; print <) { +while () { # Read in the protypes. next if /^\s+$/; chomp; - my ($f, $h, $t, @p) = split(/\s*\|\s*/, $_, -1); + my ($func, $hdr, $type, @p) = split(/\s*\|\s*/, $_, -1); my $u; - ($f, $u) = split(' ', $f); - $seenu{$f} = defined $u ? length $u : 0; - my $F = uc $f; - push @seenf, $f; + # Split off the real function name and the argument list. + ($func, $u) = split(' ', $func); + $seenu{$func} = defined $u ? length $u : 0; + my $FUNC = uc $func; # for output. + push @seenf, $func; my %m = %map; - if ($t) { - $m{S} = "$t*"; - $m{R} = "$t**"; + if ($type) { + $m{S} = "$type*"; + $m{R} = "$type**"; } + + # Set any special mapping variables (like X=x_t) if (@p) { while ($p[-1] =~ /=/) { my ($k, $v) = ($p[-1] =~ /^([A-Za-z])\s*=\s*(.*)/); @@ -158,96 +181,129 @@ while () { pop @p; } } - if ($opts{U} && open(U, ">d_${f}_r.U")) { + + # If given the -U option open up the metaconfig unit for this function. + if ($opts{U} && open(U, ">d_${func}_r.U")) { + binmode U; select U; } - my $prereqh = $h eq 'stdio' ? '' : "i_$h"; # There's no i_stdio. - print <{$p}++; - push @{$seena{$f}}, $p; - $seenp{$p}++; - $seent{$f} = $t; - $seens{$f} = $m{S}; - $seend{$f} = $m{D}; - } - if ($opts{U}) { - print <&4 ;; - * ) case "\$${f}_r_proto" in + } + $seenh{$func}->{$p}++; + push @{$seena{$func}}, $p; + $seenp{$p}++; + $seent{$func} = $type; + $seens{$func} = $m{S}; + $seend{$func} = $m{D}; + $seenm{$func} = \%m; + } + if ($opts{U}) { + print <&4 ;; + * ) case "\$${func}_r_proto" in REENTRANT_PROTO*) ;; - *) ${f}_r_proto="REENTRANT_PROTO_\$${f}_r_proto" ;; + *) ${func}_r_proto="REENTRANT_PROTO_\$${func}_r_proto" ;; esac echo "Prototype: \$try" ;; esac ;; *) case "\$usethreads" in - define) echo "${f}_r has no prototype, not using it." >&4 ;; + define) echo "${func}_r has no prototype, not using it." >&4 ;; esac + d_${func}_r=undef + ${func}_r_proto=0 ;; esac ;; -*) ${f}_r_proto=0 +*) ${func}_r_proto=0 ;; esac @@ -258,9 +314,12 @@ EOF close DATA; +# Prepare to continue writing the reentr.h. + select H; { + # Write out all the known prototype signatures. my $i = 1; for my $p (sort keys %seenp) { print "#define REENTRANT_PROTO_${p} ${i}\n"; @@ -268,18 +327,18 @@ select H; } } +my @struct; # REENTR struct members +my @size; # struct member buffer size initialization code +my @init; # struct member buffer initialization (malloc) code +my @free; # struct member buffer release (free) code +my @wrap; # the wrapper (foo(a) -> foo_r(a,...)) cpp code +my @define; # defines for optional features + sub ifprotomatch { - my $F = shift; - join " || ", map { "${F}_R_PROTO == REENTRANT_PROTO_$_" } @_; + my $FUNC = shift; + join " || ", map { "${FUNC}_R_PROTO == REENTRANT_PROTO_$_" } @_; } -my @struct; -my @size; -my @init; -my @free; -my @wrap; -my @define; - sub pushssif { push @struct, @_; push @size, @_; @@ -288,12 +347,12 @@ sub pushssif { } sub pushinitfree { - my $f = shift; + my $func = shift; push @init, <_${f}_buffer, PL_reentrant_buffer->_${f}_size, char); + Newx(PL_reentrant_buffer->_${func}_buffer, PL_reentrant_buffer->_${func}_size, char); EOF push @free, <_${f}_buffer); + Safefree(PL_reentrant_buffer->_${func}_buffer); EOF } @@ -305,22 +364,28 @@ sub define { /* The @F using \L$n? */ EOF - for my $f (@F) { - my $F = uc $f; - my $h = "${F}_R_HAS_$n"; - push @H, $h; - my @h = grep { /$p/ } @{$seena{$f}}; + my $GENFUNC; + for my $func (@F) { + my $FUNC = uc $func; + my $HAS = "${FUNC}_R_HAS_$n"; + push @H, $HAS; + my @h = grep { /$p/ } @{$seena{$func}}; + unless (defined $GENFUNC) { + $GENFUNC = $FUNC; + $GENFUNC =~ s/^GET//; + } if (@h) { - push @define, "#if defined(HAS_${F}_R) && (" . join(" || ", map { "${F}_R_PROTO == REENTRANT_PROTO_$_" } @h) . ")\n"; + push @define, "#if defined(HAS_${FUNC}_R) && (" . join(" || ", map { "${FUNC}_R_PROTO == REENTRANT_PROTO_$_" } @h) . ")\n"; push @define, <_${f}_size = 256; /* Make something up. */ + PL_reentrant_buffer->_${func}_size = REENTRANTSMALLSIZE; EOF - pushinitfree $f; + pushinitfree $func; pushssif $endif; } - elsif ($f =~ /^(crypt)$/) { + elsif ($func =~ /^(crypt)$/) { pushssif $ifdef; push @struct, <_${f}_struct.initialized = 0; +#if CRYPT_R_PROTO != REENTRANT_PROTO_B_CCD + PL_reentrant_buffer->_${func}_struct_buffer = 0; +#endif +EOF + push @free, <_${func}_struct_buffer); #endif EOF pushssif $endif; } - elsif ($f =~ /^(drand48|gmtime|localtime|random)$/) { + elsif ($func =~ /^(drand48|gmtime|localtime|random|srandom)$/) { pushssif $ifdef; push @struct, <_${g}_size = 1024; -EOF - } else { - push @struct, <_${g}_fptr = NULL; + push @init, <_${genfunc}_fptr = NULL; # endif EOF - my $sc = $g eq 'getgrent' ? + my $sc = $genfunc eq 'grent' ? '_SC_GETGR_R_SIZE_MAX' : '_SC_GETPW_R_SIZE_MAX'; - push @size, <_${g}_size = sysconf($sc); + PL_reentrant_buffer->$sz = sysconf($sc); + if (PL_reentrant_buffer->$sz == -1) + PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE; # else # if defined(__osf__) && defined(__alpha) && defined(SIABUFSIZ) - PL_reentrant_buffer->_${g}_size = SIABUFSIZ; + PL_reentrant_buffer->$sz = SIABUFSIZ; # else # ifdef __sgi - PL_reentrant_buffer->_${g}_size = BUFSIZ; + PL_reentrant_buffer->$sz = BUFSIZ; # else - PL_reentrant_buffer->_${g}_size = 256; + PL_reentrant_buffer->$sz = REENTRANTUSUALSIZE; # endif # endif # endif EOF - } - pushinitfree $g; + pushinitfree $genfunc; pushssif $endif; } - elsif ($f =~ /^(gethostbyname|getnetbyname|getservbyname|getprotobyname)$/) { + elsif ($func =~ /^(gethostbyname|getnetbyname|getservbyname|getprotobyname)$/) { pushssif $ifdef; - my $g = $f; - $g =~ s/byname/ent/; - my $G = uc $g; - my $D = ifprotomatch($F, grep {/D/} @p); - my $d = $seend{$f}; + my $genfunc = $func; + $genfunc =~ s/byname/ent/; + $genfunc =~ s/^get//; + my $GENFUNC = uc $genfunc; + my $D = ifprotomatch($FUNC, grep {/D/} @p); + my $d = $seend{$func}; + $d =~ s/\*$//; # snip: we need need the base type. push @struct, <_${g}_size = 2048; /* Any better ideas? */ + PL_reentrant_buffer->_${genfunc}_size = REENTRANTUSUALSIZE; #endif EOF push @init, <_${g}_buffer, PL_reentrant_buffer->_${g}_size, char); + Newx(PL_reentrant_buffer->_${genfunc}_buffer, PL_reentrant_buffer->_${genfunc}_size, char); #endif EOF push @free, <_${g}_buffer); + Safefree(PL_reentrant_buffer->_${genfunc}_buffer); #endif EOF pushssif $endif; } - elsif ($f =~ /^(readdir|readdir64)$/) { + elsif ($func =~ /^(readdir|readdir64)$/) { pushssif $ifdef; - my $R = ifprotomatch($F, grep {/R/} @p); + my $R = ifprotomatch($FUNC, grep {/R/} @p); push @struct, <_${f}_size = sizeof($seent{$f}) + MAXPATHLEN + 1; + PL_reentrant_buffer->_${func}_size = sizeof($seent{$func}) + MAXPATHLEN + 1; EOF push @init, <_${f}_struct = ($seent{$f}*)safemalloc(PL_reentrant_buffer->_${f}_size); + PL_reentrant_buffer->_${func}_struct = ($seent{$func}*)safemalloc(PL_reentrant_buffer->_${func}_size); EOF push @free, <_${f}_struct); + Safefree(PL_reentrant_buffer->_${func}_struct); EOF pushssif $endif; } push @wrap, $ifdef; -# Doesn't implement the buffer growth loop for glibc gethostby*(). push @wrap, <_${g}_ptr" : + "&PL_reentrant_buffer->_${genfunc}_ptr" : $_ eq 'E' ? - "&PL_reentrant_buffer->_${g}_errno" : + "&PL_reentrant_buffer->_${genfunc}_errno" : $_ eq 'B' ? - "PL_reentrant_buffer->_${g}_buffer" : + "PL_reentrant_buffer->_${genfunc}_buffer" : $_ =~ /^[WI]$/ ? - "PL_reentrant_buffer->_${g}_size" : + "PL_reentrant_buffer->_${genfunc}_size" : $_ eq 'H' ? - "&PL_reentrant_buffer->_${g}_fptr" : + "&PL_reentrant_buffer->_${genfunc}_fptr" : $_ eq 'D' ? - "&PL_reentrant_buffer->_${g}_data" : + "&PL_reentrant_buffer->_${genfunc}_data" : $_ eq 'S' ? - ($f =~ /^readdir/ ? - "PL_reentrant_buffer->_${g}_struct" : - "&PL_reentrant_buffer->_${g}_struct" ) : - $_ eq 'T' && $f eq 'drand48' ? - "&PL_reentrant_buffer->_${g}_double" : + ($func =~ /^readdir\d*$/ ? + "PL_reentrant_buffer->_${genfunc}_struct" : + $func =~ /^crypt$/ ? + "PL_reentrant_buffer->_${genfunc}_struct_buffer" : + "&PL_reentrant_buffer->_${genfunc}_struct") : + $_ eq 'T' && $func eq 'drand48' ? + "&PL_reentrant_buffer->_${genfunc}_double" : + $_ =~ /^[ilt]$/ && $func eq 'random' ? + "&PL_reentrant_buffer->_random_retval" : $_ } split '', $b; $w = ", $w" if length $v; } - my $call = "${f}_r($v$w)"; - $call = "((errno = $call))" if $r eq 'I'; + my $call = "${func}_r($v$w)"; + + # Must make OpenBSD happy + my $memzero = ''; + if($p =~ /D$/ && + ($genfunc eq 'protoent' || $genfunc eq 'servent')) { + $memzero = 'REENTR_MEMZERO(&PL_reentrant_buffer->_' . $genfunc . '_data, sizeof(PL_reentrant_buffer->_' . $genfunc . '_data))'; + } push @wrap, <reentr.c"); +binmode C; select C; print <op_type) { -#ifdef USE_GETHOSTENT_BUFFER +#ifdef USE_HOSTENT_BUFFER case OP_GHBYADDR: case OP_GHBYNAME: case OP_GHOSTENT: { - if (PL_reentrant_buffer->_gethostent_size <= REENTRANTHALFMAXSIZE) { - PL_reentrant_buffer->_gethostent_size *= 2; - Renew(PL_reentrant_buffer->_gethostent_buffer, - PL_reentrant_buffer->_gethostent_size, char); +#ifdef PERL_REENTRANT_MAXSIZE + if (PL_reentrant_buffer->_hostent_size <= + PERL_REENTRANT_MAXSIZE / 2) +#endif + { + PL_reentrant_buffer->_hostent_size *= 2; + Renew(PL_reentrant_buffer->_hostent_buffer, + PL_reentrant_buffer->_hostent_size, char); switch (PL_op->op_type) { case OP_GHBYADDR: p0 = va_arg(ap, void *); @@ -731,52 +870,66 @@ Perl_reentrant_retry(const char *f, ...) retptr = gethostbyaddr(p0, asize, anint); break; case OP_GHBYNAME: p0 = va_arg(ap, void *); - retptr = gethostbyname(p0); break; + retptr = gethostbyname((char *)p0); break; case OP_GHOSTENT: retptr = gethostent(); break; default: + SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif -#ifdef USE_GETGRENT_BUFFER +#ifdef USE_GRENT_BUFFER case OP_GGRNAM: case OP_GGRGID: case OP_GGRENT: { - if (PL_reentrant_buffer->_getgrent_size <= REENTRANTHALFMAXSIZE) { +#ifdef PERL_REENTRANT_MAXSIZE + if (PL_reentrant_buffer->_grent_size <= + PERL_REENTRANT_MAXSIZE / 2) +#endif + { Gid_t gid; - PL_reentrant_buffer->_getgrent_size *= 2; - Renew(PL_reentrant_buffer->_getgrent_buffer, - PL_reentrant_buffer->_getgrent_size, char); + PL_reentrant_buffer->_grent_size *= 2; + Renew(PL_reentrant_buffer->_grent_buffer, + PL_reentrant_buffer->_grent_size, char); switch (PL_op->op_type) { case OP_GGRNAM: p0 = va_arg(ap, void *); - retptr = getgrnam(p0); break; + retptr = getgrnam((char *)p0); break; case OP_GGRGID: +#if Gid_t_size < INTSIZE + gid = (Gid_t)va_arg(ap, int); +#else gid = va_arg(ap, Gid_t); +#endif retptr = getgrgid(gid); break; case OP_GGRENT: retptr = getgrent(); break; default: + SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif -#ifdef USE_GETNETENT_BUFFER +#ifdef USE_NETENT_BUFFER case OP_GNBYADDR: case OP_GNBYNAME: case OP_GNETENT: { - if (PL_reentrant_buffer->_getnetent_size <= REENTRANTHALFMAXSIZE) { +#ifdef PERL_REENTRANT_MAXSIZE + if (PL_reentrant_buffer->_netent_size <= + PERL_REENTRANT_MAXSIZE / 2) +#endif + { Netdb_net_t net; - PL_reentrant_buffer->_getnetent_size *= 2; - Renew(PL_reentrant_buffer->_getnetent_buffer, - PL_reentrant_buffer->_getnetent_size, char); + PL_reentrant_buffer->_netent_size *= 2; + Renew(PL_reentrant_buffer->_netent_buffer, + PL_reentrant_buffer->_netent_size, char); switch (PL_op->op_type) { case OP_GNBYADDR: net = va_arg(ap, Netdb_net_t); @@ -784,88 +937,108 @@ Perl_reentrant_retry(const char *f, ...) retptr = getnetbyaddr(net, anint); break; case OP_GNBYNAME: p0 = va_arg(ap, void *); - retptr = getnetbyname(p0); break; + retptr = getnetbyname((char *)p0); break; case OP_GNETENT: retptr = getnetent(); break; default: + SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif -#ifdef USE_GETPWENT_BUFFER +#ifdef USE_PWENT_BUFFER case OP_GPWNAM: case OP_GPWUID: case OP_GPWENT: { - if (PL_reentrant_buffer->_getpwent_size <= REENTRANTHALFMAXSIZE) { +#ifdef PERL_REENTRANT_MAXSIZE + if (PL_reentrant_buffer->_pwent_size <= + PERL_REENTRANT_MAXSIZE / 2) +#endif + { Uid_t uid; - PL_reentrant_buffer->_getpwent_size *= 2; - Renew(PL_reentrant_buffer->_getpwent_buffer, - PL_reentrant_buffer->_getpwent_size, char); + PL_reentrant_buffer->_pwent_size *= 2; + Renew(PL_reentrant_buffer->_pwent_buffer, + PL_reentrant_buffer->_pwent_size, char); switch (PL_op->op_type) { case OP_GPWNAM: p0 = va_arg(ap, void *); - retptr = getpwnam(p0); break; + retptr = getpwnam((char *)p0); break; case OP_GPWUID: +#if Uid_t_size < INTSIZE + uid = (Uid_t)va_arg(ap, int); +#else uid = va_arg(ap, Uid_t); +#endif retptr = getpwuid(uid); break; case OP_GPWENT: retptr = getpwent(); break; default: + SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif -#ifdef USE_GETPROTOENT_BUFFER +#ifdef USE_PROTOENT_BUFFER case OP_GPBYNAME: case OP_GPBYNUMBER: case OP_GPROTOENT: { - if (PL_reentrant_buffer->_getprotoent_size <= REENTRANTHALFMAXSIZE) { - PL_reentrant_buffer->_getprotoent_size *= 2; - Renew(PL_reentrant_buffer->_getprotoent_buffer, - PL_reentrant_buffer->_getprotoent_size, char); +#ifdef PERL_REENTRANT_MAXSIZE + if (PL_reentrant_buffer->_protoent_size <= + PERL_REENTRANT_MAXSIZE / 2) +#endif + { + PL_reentrant_buffer->_protoent_size *= 2; + Renew(PL_reentrant_buffer->_protoent_buffer, + PL_reentrant_buffer->_protoent_size, char); switch (PL_op->op_type) { case OP_GPBYNAME: p0 = va_arg(ap, void *); - retptr = getprotobyname(p0); break; + retptr = getprotobyname((char *)p0); break; case OP_GPBYNUMBER: anint = va_arg(ap, int); retptr = getprotobynumber(anint); break; case OP_GPROTOENT: retptr = getprotoent(); break; default: + SETERRNO(ERANGE, LIB_INVARG); break; } } } break; #endif -#ifdef USE_GETSERVENT_BUFFER +#ifdef USE_SERVENT_BUFFER case OP_GSBYNAME: case OP_GSBYPORT: case OP_GSERVENT: { - if (PL_reentrant_buffer->_getservent_size <= REENTRANTHALFMAXSIZE) { - PL_reentrant_buffer->_getservent_size *= 2; - Renew(PL_reentrant_buffer->_getservent_buffer, - PL_reentrant_buffer->_getservent_size, char); +#ifdef PERL_REENTRANT_MAXSIZE + if (PL_reentrant_buffer->_servent_size <= + PERL_REENTRANT_MAXSIZE / 2) +#endif + { + PL_reentrant_buffer->_servent_size *= 2; + Renew(PL_reentrant_buffer->_servent_buffer, + PL_reentrant_buffer->_servent_size, char); switch (PL_op->op_type) { case OP_GSBYNAME: p0 = va_arg(ap, void *); p1 = va_arg(ap, void *); - retptr = getservbyname(p0, p1); break; + retptr = getservbyname((char *)p0, (char *)p1); break; case OP_GSBYPORT: anint = va_arg(ap, int); p0 = va_arg(ap, void *); - retptr = getservbyport(anint, p0); break; + retptr = getservbyport(anint, (char *)p0); break; case OP_GSERVENT: retptr = getservent(); break; default: + SETERRNO(ERANGE, LIB_INVARG); break; } } @@ -878,10 +1051,13 @@ Perl_reentrant_retry(const char *f, ...) } va_end(ap); +#else + PERL_UNUSED_ARG(f); #endif return retptr; } +/* ex: set ro: */ EOF __DATA__ @@ -891,19 +1067,19 @@ ctermid B |stdio | |B_B ctime S |time |const time_t |B_SB|B_SBI|I_SB|I_SBI drand48 |stdlib |struct drand48_data |I_ST|T=double* endgrent |grp | |I_H|V_H -endhostent |netdb |struct hostent_data |I_S|V_S -endnetent |netdb |struct netent_data |I_S|V_S -endprotoent |netdb |struct protoent_data |I_S|V_S +endhostent |netdb | |I_D|V_D|D=struct hostent_data* +endnetent |netdb | |I_D|V_D|D=struct netent_data* +endprotoent |netdb | |I_D|V_D|D=struct protoent_data* endpwent |pwd | |I_H|V_H -endservent |netdb |struct servent_data |I_S|V_S +endservent |netdb | |I_D|V_D|D=struct servent_data* getgrent |grp |struct group |I_SBWR|I_SBIR|S_SBW|S_SBI|I_SBI|I_SBIH getgrgid T |grp |struct group |I_TSBWR|I_TSBIR|I_TSBI|S_TSBI|T=gid_t getgrnam C |grp |struct group |I_CSBWR|I_CSBIR|S_CBI|I_CSBI|S_CSBI -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|D=struct hostent_data*|T=const void* +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 gethostbyname C |netdb |struct hostent |I_CSBWRE|S_CSBIE|I_CSD|D=struct hostent_data* gethostent |netdb |struct hostent |I_SBWRE|I_SBIE|S_SBIE|S_SBI|I_SBI|I_SD|D=struct hostent_data* -getlogin |unistd | |I_BW|I_BI|B_BW|B_BI -getnetbyaddr LI |netdb |struct netent |I_UISBWRE|I_LISBI|S_TISBI|S_LISBI|I_TISD|I_LISD|I_IISD|D=struct netent_data*|T=in_addr_t|U=unsigned long +getlogin |unistd |char |I_BW|I_BI|B_BW|B_BI +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 getnetbyname C |netdb |struct netent |I_CSBWRE|I_CSBI|S_CSBI|I_CSD|D=struct netent_data* getnetent |netdb |struct netent |I_SBWRE|I_SBIE|S_SBIE|S_SBI|I_SBI|I_SD|D=struct netent_data* getprotobyname C|netdb |struct protoent|I_CSBWR|S_CSBI|I_CSD|D=struct protoent_data* @@ -918,7 +1094,7 @@ getservent |netdb |struct servent |I_SBWR|I_SBI|S_SBI|I_SD|D=struct servent_data getspnam C |shadow |struct spwd |I_CSBWR|S_CSBI gmtime T |time |struct tm |S_TS|I_TS|T=const time_t* localtime T |time |struct tm |S_TS|I_TS|T=const time_t* -random |stdlib |struct random_data|I_TS|T=int* +random |stdlib |struct random_data|I_iS|I_lS|I_St|i=int*|l=long*|t=int32_t* readdir T |dirent |struct dirent |I_TSR|I_TS|T=DIR* readdir64 T |dirent |struct dirent64|I_TSR|I_TS|T=DIR* setgrent |grp | |I_H|V_H