/* If compiling for a threaded perl, we will macro-wrap the system/library
* interfaces (e.g. getpwent()) which have threaded versions
* (e.g. getpwent_r()), which will handle things correctly for
- * the Perl interpreter, but otherwise (for XS) the wrapping does
- * not take place. See L<perlxs/Thread-aware system interfaces>.
+ * the Perl interpreter. This is done automatically for the perl core and
+ * extensions, but not generally for XS modules unless they
+ * #define PERL_REENTRANT
+ * See L<perlxs/Thread-aware system interfaces>.
+ *
+ * For a function 'foo', use the compile-time directive
+ * #ifdef PERL_REENTR_USING_FOO_R
+ * to test if the function actually did get replaced by the reentrant version.
+ * (If it isn't getting replaced, it might mean it uses a different prototype
+ * on the given platform than any we are expecting. To fix that, add the
+ * prototype to the __DATA__ section of regen/reentr.pl.)
*/
#ifndef PERL_REENTR_API
#ifdef USE_REENTRANT_API
+/* For thread-safe builds, alternative methods are used to make calls to this
+ * safe. */
+#ifdef USE_THREAD_SAFE_LOCALE
+# undef HAS_SETLOCALE_R
+#endif
+
/* Deprecations: some platforms have the said reentrant interfaces
* but they are declared obsolete and are not to be used. Often this
* means that the platform has threadsafed the interfaces (hopefully).
define('BUFFER', 'B',
qw(getpwent getpwgid getpwnam));
+define('BUFFER', 'B',
+ qw(getspent getspnam));
+
define('PTR', 'R',
qw(gethostent gethostbyaddr gethostbyname));
define('PTR', 'R',
char* _${func}_buffer;
size_t _${func}_size;
EOF
+ my $size = ($func =~ /^(asctime|ctime)$/)
+ ? 26
+ : "REENTRANTSMALLSIZE";
push @size, <<EOF;
- PL_reentrant_buffer->_${func}_size = REENTRANTSMALLSIZE;
+ PL_reentrant_buffer->_${func}_size = $size;
EOF
pushinitfree $func;
pushssif $endif;
}
+ elsif ($func =~ /^(gm|local)time$/) {
+ pushssif $ifdef;
+ push @struct, <<EOF; # Fixed size
+ $seent{$func} _${func}_struct;
+EOF
+ pushssif $endif;
+ }
elsif ($func =~ /^(crypt)$/) {
pushssif $ifdef;
push @struct, <<EOF;
push @wrap, $ifdef;
push @wrap, <<EOF;
-# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
-# undef $func
+# if defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# undef $func
EOF
# Write out what we have learned.
}
if (length $b) {
$w = join ", ",
- map {
- $_ eq 'R' ?
- "&PL_reentrant_buffer->_${genfunc}_ptr" :
- $_ eq 'E' ?
- "&PL_reentrant_buffer->_${genfunc}_errno" :
- $_ eq 'B' ?
- "PL_reentrant_buffer->_${genfunc}_buffer" :
- $_ =~ /^[WI]$/ ?
- "PL_reentrant_buffer->_${genfunc}_size" :
- $_ eq 'H' ?
- "&PL_reentrant_buffer->_${genfunc}_fptr" :
- $_ eq 'D' ?
- "&PL_reentrant_buffer->_${genfunc}_data" :
- $_ eq 'S' ?
- ($func =~ /^readdir\d*$/ ?
- "PL_reentrant_buffer->_${genfunc}_struct" :
- $func =~ /^crypt$/ ?
- "PL_reentrant_buffer->_${genfunc}_struct_buffer" :
- "&PL_reentrant_buffer->_${genfunc}_struct") :
- $_
- } split '', $b;
+ map { $_ eq 'R'
+ ? "&PL_reentrant_buffer->_${genfunc}_ptr"
+ : $_ eq 'E'
+ ? "&PL_reentrant_buffer->_${genfunc}_errno"
+ : $_ eq 'B'
+ ? "PL_reentrant_buffer->_${genfunc}_buffer"
+ : $_ =~ /^[WI]$/
+ ? "PL_reentrant_buffer->_${genfunc}_size"
+ : $_ eq 'H'
+ ? "&PL_reentrant_buffer->_${genfunc}_fptr"
+ : $_ eq 'D'
+ ? "&PL_reentrant_buffer->_${genfunc}_data"
+ : $_ eq 'S'
+ ? ($func =~ /^readdir\d*$/
+ ? "PL_reentrant_buffer->_${genfunc}_struct"
+ : $func =~ /^crypt$/
+ ? "PL_reentrant_buffer->_${genfunc}_struct_buffer"
+ : "&PL_reentrant_buffer->_${genfunc}_struct")
+ : $_
+ } split '', $b;
$w = ", $w" if length $v;
}
- my $call = "${func}_r($v$w)";
+ # This needs a special case, see its definition in config.h
+ my $setup = ($func eq 'localtime') ? "L_R_TZSET " : "";
+
+ my $call = "$setup${func}_r($v$w)";
# Must make OpenBSD happy
my $memzero = '';
$memzero = 'REENTR_MEMZERO(&PL_reentrant_buffer->_' . $genfunc . '_data, sizeof(PL_reentrant_buffer->_' . $genfunc . '_data)),';
}
push @wrap, <<EOF;
-# if !defined($func) && ${FUNC}_R_PROTO == REENTRANT_PROTO_$p
+# if !defined($func) && ${FUNC}_R_PROTO == REENTRANT_PROTO_$p
EOF
if ($r eq 'V' || $r eq 'B') {
push @wrap, <<EOF;
-# define $func($v) $call
+# define $func($v) $call
EOF
} else {
if ($func =~ /^get/) {
my $rv = $v ? ", $v" : "";
if ($r eq 'I') {
push @wrap, <<EOF;
-# define $func($v) ($memzero(PL_reentrant_retint = $call)$test ? $true : ((PL_reentrant_retint == ERANGE) ? ($seent{$func} *) Perl_reentrant_retry("$func"$rv) : 0))
+# define $func($v) ($memzero(PL_reentrant_retint = $call)$test ? $true : ((PL_reentrant_retint == ERANGE) ? ($seent{$func} *) Perl_reentrant_retry("$func"$rv) : 0))
EOF
} else {
push @wrap, <<EOF;
-# define $func($v) ($call$test ? $true : ((errno == ERANGE) ? ($seent{$func} *) Perl_reentrant_retry("$func"$rv) : 0))
+# define $func($v) ($call$test ? $true : ((errno == ERANGE) ? ($seent{$func} *) Perl_reentrant_retry("$func"$rv) : 0))
EOF
}
} else {
push @wrap, <<EOF;
-# define $func($v) ($call$test ? $true : 0)
+# define $func($v) ($call$test ? $true : 0)
EOF
}
}
- push @wrap, <<EOF; # !defined(xxx) && XXX_R_PROTO == REENTRANT_PROTO_Y_TS
-# endif
+ push @wrap, <<EOF; # !defined(xxx) && XXX_R_PROTO == REENTRANT_PROTO_Y_TS
+# endif
EOF
}
+ push @wrap, <<EOF;
+# if defined($func)
+# define PERL_REENTR_USING_${FUNC}_R
+# endif
+EOF
- push @wrap, <<EOF; # defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
-# endif
+ push @wrap, <<EOF; # defined(PERL_REENTR_API) && (PERL_REENTR_API+0 == 1)
+# endif
EOF
push @wrap, $endif, "\n";
/* The wrappers. */
@wrap
+
+/* Special case this; if others came along, could automate it */
+# ifdef HAS_GETSPNAM_R
+# define KEY_getspnam -1
+# endif
+
#endif /* USE_REENTRANT_API */
#endif
#define PERL_IN_REENTR_C
#include "perl.h"
#include "reentr.h"
+#include "keywords.h"
#define RenewDouble(data_pointer, size_pointer, type) \\
STMT_START { \\
- const size_t size = *(size_pointer) * 2; \\
+ const size_t size = MAX(*(size_pointer), 1) * 2; \\
Renew((data_pointer), (size), type); \\
*(size_pointer) = size; \\
} STMT_END
void *retptr = NULL;
va_list ap;
+ I32 key = 0;
+
#ifdef USE_REENTRANT_API
dTHX;
+ key = Perl_keyword (aTHX_ f, strlen(f), FALSE /* not feature enabled */);
+
/* Easier to special case this here than in embed.pl. (Look at what it
generates for proto.h) */
PERL_ARGS_ASSERT_REENTRANT_RETRY;
#endif
+ if (key == 0) {
+
+#ifdef HAS_GETSPNAM_R
+
+ /* This is a #define as has no corresponding keyword */
+ if (strEQ(f, "getspnam")) {
+ key = KEY_getspnam;
+ }
+
+#endif
+
+ }
+ else if (key < 0) {
+ key = -key;
+ }
+
va_start(ap, f);
- {
#ifdef USE_REENTRANT_API
-# 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)
- void *p0;
-# endif
-# if defined(USE_SERVENT_BUFFER)
- void *p1;
-# endif
-# if defined(USE_HOSTENT_BUFFER)
- size_t asize;
-# endif
-# if defined(USE_HOSTENT_BUFFER) || defined(USE_NETENT_BUFFER) || defined(USE_PROTOENT_BUFFER) || defined(USE_SERVENT_BUFFER)
- int anint;
-# endif
- switch (PL_op->op_type) {
+ switch (key) {
# ifdef USE_HOSTENT_BUFFER
- case OP_GHBYADDR:
- case OP_GHBYNAME:
- case OP_GHOSTENT:
+ case KEY_gethostbyaddr:
+ case KEY_gethostbyname:
+ case KEY_endhostent:
{
+ char * host_addr;
+ Size_t asize;
+ char * host_name;
+ int anint;
# ifdef PERL_REENTRANT_MAXSIZE
if (PL_reentrant_buffer->_hostent_size <=
PERL_REENTRANT_MAXSIZE / 2)
# endif
- {
RenewDouble(PL_reentrant_buffer->_hostent_buffer,
&PL_reentrant_buffer->_hostent_size, char);
- switch (PL_op->op_type) {
- case OP_GHBYADDR:
- p0 = va_arg(ap, void *);
- asize = va_arg(ap, size_t);
+ switch (key) {
+ case KEY_gethostbyaddr:
+ host_addr = va_arg(ap, char *);
+ asize = va_arg(ap, Size_t);
anint = va_arg(ap, int);
- retptr = gethostbyaddr((Netdb_host_t) p0, (Netdb_hlen_t) asize, anint); break;
- case OP_GHBYNAME:
- p0 = va_arg(ap, void *);
- retptr = gethostbyname((Netdb_name_t) p0); break;
- case OP_GHOSTENT:
+ /* socklen_t is what Posix 2001 says this should be */
+ retptr = gethostbyaddr(host_addr, (socklen_t) asize, anint); break;
+ case KEY_gethostbyname:
+ host_name = va_arg(ap, char *);
+ retptr = gethostbyname(host_name); break;
+ case KEY_endhostent:
retptr = gethostent(); break;
default:
SETERRNO(ERANGE, LIB_INVARG);
break;
- }
}
}
break;
# endif
# ifdef USE_GRENT_BUFFER
- case OP_GGRNAM:
- case OP_GGRGID:
- case OP_GGRENT:
+ case KEY_getgrent:
+ case KEY_getgrgid:
+ case KEY_getgrnam:
{
+ char * name;
+ Gid_t gid;
# ifdef PERL_REENTRANT_MAXSIZE
if (PL_reentrant_buffer->_grent_size <=
PERL_REENTRANT_MAXSIZE / 2)
# endif
- {
- Gid_t gid;
RenewDouble(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((char *)p0); break;
- case OP_GGRGID:
-
+ switch (key) {
+ case KEY_getgrnam:
+ name = va_arg(ap, char *);
+ retptr = getgrnam(name); break;
+ case KEY_getgrgid:
# 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:
+ case KEY_getgrent:
retptr = getgrent(); break;
default:
SETERRNO(ERANGE, LIB_INVARG);
break;
- }
}
}
break;
# endif
# ifdef USE_NETENT_BUFFER
- case OP_GNBYADDR:
- case OP_GNBYNAME:
- case OP_GNETENT:
+ case KEY_getnetbyaddr:
+ case KEY_getnetbyname:
+ case KEY_getnetent:
{
+ char * name;
+ Netdb_net_t net;
+ int anint;
# ifdef PERL_REENTRANT_MAXSIZE
if (PL_reentrant_buffer->_netent_size <=
PERL_REENTRANT_MAXSIZE / 2)
# endif
- {
- Netdb_net_t net;
RenewDouble(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);
- anint = va_arg(ap, int);
- retptr = getnetbyaddr(net, anint); break;
- case OP_GNBYNAME:
- p0 = va_arg(ap, void *);
- retptr = getnetbyname((char *)p0); break;
- case OP_GNETENT:
- retptr = getnetent(); break;
- default:
- SETERRNO(ERANGE, LIB_INVARG);
- break;
- }
- }
+ switch (key) {
+ case KEY_getnetbyaddr:
+ net = va_arg(ap, Netdb_net_t);
+ anint = va_arg(ap, int);
+ retptr = getnetbyaddr(net, anint); break;
+ case KEY_getnetbyname:
+ name = va_arg(ap, char *);
+ retptr = getnetbyname(name); break;
+ case KEY_getnetent:
+ retptr = getnetent(); break;
+ default:
+ SETERRNO(ERANGE, LIB_INVARG);
+ break;
+ }
}
break;
# endif
# ifdef USE_PWENT_BUFFER
- case OP_GPWNAM:
- case OP_GPWUID:
- case OP_GPWENT:
+ case KEY_getpwnam:
+ case KEY_getpwuid:
+ case KEY_getpwent:
{
+ Uid_t uid;
+ char * name;
# ifdef PERL_REENTRANT_MAXSIZE
if (PL_reentrant_buffer->_pwent_size <=
PERL_REENTRANT_MAXSIZE / 2)
# endif
- {
- Uid_t uid;
RenewDouble(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((char *)p0); break;
- case OP_GPWUID:
+ switch (key) {
+ case KEY_getpwnam:
+ name = va_arg(ap, char *);
+ retptr = getpwnam(name); break;
+ case KEY_getpwuid:
# if Uid_t_size < INTSIZE
uid = (Uid_t)va_arg(ap, int);
retptr = getpwuid(uid); break;
# if defined(HAS_GETPWENT) || defined(HAS_GETPWENT_R)
- case OP_GPWENT:
+
+ case KEY_getpwent:
retptr = getpwent(); break;
# endif
default:
SETERRNO(ERANGE, LIB_INVARG);
break;
}
- }
+ }
+ break;
+
+# endif
+# ifdef USE_SPENT_BUFFER
+
+ case KEY_getspnam:
+ {
+ char * name;
+
+# ifdef PERL_REENTRANT_MAXSIZE
+ if (PL_reentrant_buffer->_spent_size <=
+ PERL_REENTRANT_MAXSIZE / 2)
+
+# endif
+ RenewDouble(PL_reentrant_buffer->_spent_buffer,
+ &PL_reentrant_buffer->_spent_size, char);
+ switch (key) {
+ case KEY_getspnam:
+ name = va_arg(ap, char *);
+ retptr = getspnam(name); break;
+ default:
+ SETERRNO(ERANGE, LIB_INVARG);
+ break;
+ }
}
break;
# endif
# ifdef USE_PROTOENT_BUFFER
- case OP_GPBYNAME:
- case OP_GPBYNUMBER:
- case OP_GPROTOENT:
+ case KEY_getprotobyname:
+ case KEY_getprotobynumber:
+ case KEY_getprotoent:
{
+ char * name;
+ int anint;
# ifdef PERL_REENTRANT_MAXSIZE
if (PL_reentrant_buffer->_protoent_size <=
PERL_REENTRANT_MAXSIZE / 2)
# endif
- {
RenewDouble(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((char *)p0); break;
- case OP_GPBYNUMBER:
+ switch (key) {
+ case KEY_getprotobyname:
+ name = va_arg(ap, char *);
+ retptr = getprotobyname(name); break;
+ case KEY_getprotobynumber:
anint = va_arg(ap, int);
retptr = getprotobynumber(anint); break;
- case OP_GPROTOENT:
+ case KEY_getprotoent:
retptr = getprotoent(); break;
default:
SETERRNO(ERANGE, LIB_INVARG);
break;
}
- }
}
break;
# endif
# ifdef USE_SERVENT_BUFFER
- case OP_GSBYNAME:
- case OP_GSBYPORT:
- case OP_GSERVENT:
+ case KEY_getservbyname:
+ case KEY_getservbyport:
+ case KEY_getservent:
{
+ char * name;
+ char * proto;
+ int anint;
# ifdef PERL_REENTRANT_MAXSIZE
if (PL_reentrant_buffer->_servent_size <=
PERL_REENTRANT_MAXSIZE / 2)
# endif
- {
RenewDouble(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((char *)p0, (char *)p1); break;
- case OP_GSBYPORT:
+ switch (key) {
+ case KEY_getservbyname:
+ name = va_arg(ap, char *);
+ proto = va_arg(ap, char *);
+ retptr = getservbyname(name, proto); break;
+ case KEY_getservbyport:
anint = va_arg(ap, int);
- p0 = va_arg(ap, void *);
- retptr = getservbyport(anint, (char *)p0); break;
- case OP_GSERVENT:
+ name = va_arg(ap, char *);
+ retptr = getservbyport(anint, name); break;
+ case KEY_getservent:
retptr = getservent(); break;
default:
SETERRNO(ERANGE, LIB_INVARG);
break;
- }
}
}
break;
#endif
- }
va_end(ap);
return retptr;
}
read_only_bottom_close_and_rename($c);
+# As of March 2020, the config.h entries that have reentrant prototypes that
+# aren't in this file are:
+# drand48
+# random
+# srand48
+# srandom
+
# The meanings of the flags are derivable from %map above
# Fnc, arg flags| hdr | ? struct type | prototypes...
__DATA__
getservbyport IC|netdb |struct servent |I_ICSBWR|S_ICSBI|I_ICSD|D=struct servent_data*
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|T=time_t*
+localtime T |time |struct tm |S_TS|T=time_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
https://perl5.git.perl.org / perl5.git / blobdiff