25 RCSID(
"$Id: 5c0f89825deb3ba0fed1852efff8ec395894ef79 $")
27 #include <freeradius-devel/radiusd.h>
28 #include <freeradius-devel/modules.h>
29 #include <freeradius-devel/rad_assert.h>
38 #include <semaphore.h>
41 extern char **environ;
81 pthread_mutex_t clone_mutex;
90 #define RLM_PERL_CONF(_x) { "func_" STRINGIFY(_x), PW_TYPE_STRING, \
91 offsetof(rlm_perl_t,func_##_x), NULL, STRINGIFY(_x), T_INVALID }
127 # define dl_librefs "DynaLoader::dl_librefs"
128 # define dl_modules "DynaLoader::dl_modules"
129 static void rlm_perl_clear_handles(pTHX)
131 AV *librefs = get_av(dl_librefs,
false);
137 static void **rlm_perl_get_handles(pTHX)
140 AV *librefs = get_av(dl_librefs,
false);
141 AV *modules = get_av(dl_modules,
false);
144 if (!librefs)
return NULL;
146 if (!(AvFILL(librefs) >= 0)) {
150 handles = (
void **)
rad_malloc(
sizeof(
void *) * (AvFILL(librefs)+2));
152 for (i = 0; i <= AvFILL(librefs); i++) {
154 SV *handle_sv = *av_fetch(librefs, i,
false);
156 ERROR(
"Could not fetch $%s[%d]!", dl_librefs, (
int)i);
159 handle = (
void *)SvIV(handle_sv);
161 if (handle) handles[i] = handle;
167 handles[i] = (
void *)0;
172 static void rlm_perl_close_handles(
void **handles)
180 for (i = 0; handles[i]; i++) {
181 DEBUG(
"Close %p", handles[i]);
189 static
void rlm_perl_destruct(PerlInterpreter *perl)
193 PERL_SET_CONTEXT(perl);
195 PL_perl_destruct_level = 2;
197 PL_origenviron = environ;
207 while (PL_scopestack_ix > 1) {
216 static
void rlm_destroy_perl(PerlInterpreter *perl)
221 PERL_SET_CONTEXT(perl);
223 handles = rlm_perl_get_handles(aTHX);
224 if (handles) rlm_perl_close_handles(handles);
225 rlm_perl_destruct(perl);
229 static void rlm_perl_make_key(pthread_key_t *key)
231 pthread_key_create(key, (
void (*)(
void *))rlm_destroy_perl);
234 static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
238 PerlInterpreter *interp;
241 PERL_SET_CONTEXT(perl);
243 interp = pthread_getspecific(*key);
244 if (interp)
return interp;
246 interp = perl_clone(perl, clone_flags);
250 # if PERL_REVISION >= 5 && PERL_VERSION <8
253 ptr_table_free(PL_ptr_table);
256 PERL_SET_CONTEXT(aTHX);
257 rlm_perl_clear_handles(aTHX);
259 ret = pthread_setspecific(*key, interp);
261 DEBUG(
"rlm_perl: Failed associating interpretor with thread %s",
fr_syserror(ret));
263 rlm_perl_destruct(interp);
276 static XS(XS_radiusd_radlog)
280 croak(
"Usage: radiusd::radlog(level, message)");
285 level = (int) SvIV(ST(0));
286 msg = (
char *) SvPV(ST(1), PL_na);
292 radlog(level,
"rlm_perl: %s", msg);
299 char const *file = __FILE__;
304 newXS(
"radiusd::radlog",XS_radiusd_radlog,
"rlm_perl");
311 void const *mod_inst,
UNUSED void const *xlat_inst,
312 REQUEST *request,
char const *fmt)
322 memcpy(&inst, &mod_inst,
sizeof(inst));
325 PerlInterpreter *interp;
331 PERL_SET_CONTEXT(interp);
335 PERL_SET_CONTEXT(inst->
perl);
350 XPUSHs(sv_2mortal(newSVpvn(p, q - p)));
356 while (*p ==
' ') p++;
366 XPUSHs(sv_2mortal(newSVpvn(p, strlen(p))));
371 count = call_pv(inst->
func_xlat, G_SCALAR | G_EVAL);
375 REDEBUG(
"Exit %s", SvPV(ERRSV,n_a));
377 }
else if (count > 0) {
382 RDEBUG(
"Len is %zu , out is %s freespace is %zu", ret, *out, outlen);
400 if (!cs || !rad_hv)
return;
402 int indent_section = (lvl + 1) * 4;
403 int indent_item = (lvl + 2) * 4;
423 if (hv_exists(rad_hv, key, strlen(key))) {
424 WARN(
"rlm_perl: Ignoring duplicate config section '%s'", key);
429 ref = newRV_inc((SV*) sub_hv);
431 (void)hv_store(rad_hv, key, strlen(key), ref, 0);
439 if (!key || !value)
continue;
445 if (hv_exists(rad_hv, key, strlen(key))) {
446 WARN(
"rlm_perl: Ignoring duplicate config item '%s'", key);
450 (void)hv_store(rad_hv, key, strlen(key), newSVpvn(value, strlen(value)), 0);
452 DEBUG(
"%*s%s = %s", indent_item,
" ", key, value);
456 DEBUG(
"%*s}", indent_section,
" ");
463 char const *xlat_name;
492 char const **embed_c;
495 int exitstatus = 0, argc=0;
515 MEM(embed_c = talloc_zero_array(inst,
char const *, 4));
516 memcpy(&embed, &embed_c,
sizeof(embed));
520 embed_c[2] = inst->
module;
524 embed_c[1] = inst->
module;
533 PERL_SYS_INIT3(&argc, &embed, &envp);
538 if ((inst->
perl = perl_alloc()) == NULL) {
539 ERROR(
"rlm_perl: No memory for allocating new perl !");
542 perl_construct(inst->
perl);
545 PL_perl_destruct_level = 2;
550 PERL_SET_CONTEXT(inst->
perl);
553 #if PERL_REVISION >= 5 && PERL_VERSION >=8
554 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
557 exitstatus = perl_parse(inst->
perl,
xs_init, argc, embed, NULL);
560 PL_endav = (AV *)NULL;
563 ERROR(
"rlm_perl: perl_parse failed: %s not found or has syntax errors", inst->
module);
575 perl_run(inst->
perl);
583 int *i,
const char *hash_name,
const char *list_name)
591 RDEBUG(
"$%s{'%s'}[%i] = &%s:%s -> '%s'", hash_name, vp->
da->
name, *i,
592 list_name, vp->
da->
name, vp->vp_strvalue);
593 av_push(av, newSVpvn(vp->vp_strvalue, vp->vp_length));
600 hex =
fr_abin2hex(request, vp->vp_octets, vp->vp_length);
601 RDEBUG(
"$%s{'%s'}[%i] = &%s:%s -> 0x%s", hash_name, vp->
da->
name, *i,
602 list_name, vp->
da->
name, hex);
605 av_push(av, newSVpvn((
char const *)vp->vp_octets, vp->vp_length));
610 RDEBUG(
"$%s{'%s'}[%i] = &%s:%s -> '%s'", hash_name, vp->
da->
name, *i,
611 list_name, vp->
da->
name, buffer);
612 av_push(av, newSVpvn(buffer,
truncate_len(len,
sizeof(buffer))));
625 const char *hash_name,
const char *list_name)
672 (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0);
682 RDEBUG(
"$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->
da->
name, list_name,
683 vp->
da->
name, vp->vp_strvalue);
684 (void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->vp_length), 0);
691 hex =
fr_abin2hex(request, vp->vp_octets, vp->vp_length);
692 RDEBUG(
"$%s{'%s'} = &%s:%s -> 0x%s", hash_name, vp->
da->
name,
693 list_name, vp->
da->
name, hex);
696 (void)hv_store(rad_hv, name, strlen(name),
697 newSVpvn((
char const *)vp->vp_octets, vp->vp_length), 0);
702 RDEBUG(
"$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->
da->
name,
703 list_name, vp->
da->
name, buffer);
704 (void)hv_store(rad_hv, name, strlen(name),
705 newSVpvn(buffer,
truncate_len(len,
sizeof(buffer))), 0);
719 const char *hash_name,
const char *list_name)
730 REDEBUG(
"Failed to create pair %s:%s %s %s", list_name, key,
749 hash_name, key, val);
759 const char *hash_name,
const char *list_name)
764 I32 key_len, len, i, j;
768 for (i = hv_iterinit(my_hv); i > 0; i--) {
769 res_sv = hv_iternextsv(my_hv,&key,&key_len);
770 if (SvROK(res_sv) && (SvTYPE(SvRV(res_sv)) == SVt_PVAV)) {
771 av = (AV*)SvRV(res_sv);
773 for (j = 0; j <= len; j++) {
774 av_sv = av_fetch(av, j, 0);
775 ret =
pairadd_sv(ctx, request, vps, key, *av_sv,
T_OP_ADD, hash_name, list_name) + ret;
777 }
else ret =
pairadd_sv(ctx, request, vps, key, res_sv,
T_OP_EQ, hash_name, list_name) + ret;
793 int exitstatus=0, count;
801 HV *rad_request_proxy_hv;
802 HV *rad_request_proxy_reply_hv;
814 PerlInterpreter *interp;
819 PERL_SET_CONTEXT(interp);
824 PERL_SET_CONTEXT(inst->
perl);
833 rad_reply_hv = get_hv(
"RAD_REPLY", 1);
834 rad_config_hv = get_hv(
"RAD_CONFIG", 1);
835 rad_request_hv = get_hv(
"RAD_REQUEST", 1);
836 rad_state_hv = get_hv(
"RAD_STATE", 1);
844 rad_request_proxy_hv = get_hv(
"RAD_REQUEST_PROXY",1);
845 rad_request_proxy_reply_hv = get_hv(
"RAD_REQUEST_PROXY_REPLY",1);
847 if (request->
proxy != NULL) {
849 "RAD_REQUEST_PROXY",
"proxy-request");
851 hv_undef(rad_request_proxy_hv);
856 rad_request_proxy_reply_hv,
"RAD_REQUEST_PROXY_REPLY",
"proxy-reply");
858 hv_undef(rad_request_proxy_reply_hv);
871 count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS);
876 RDEBUG(
"perl_embed:: module = %s , func = %s exit status= %s\n",
877 inst->
module, function_name, SvPV(ERRSV,n_a));
883 if (exitstatus >= 100 || exitstatus < 0) {
894 if ((
get_hv_content(request->
packet, request, rad_request_hv, &vp,
"RAD_REQUEST",
"request")) == 0) {
909 if ((
get_hv_content(request->
reply, request, rad_reply_hv, &vp,
"RAD_REPLY",
"reply")) == 0) {
915 if ((
get_hv_content(request, request, rad_config_hv, &vp,
"RAD_CONFIG",
"control")) == 0) {
928 if (request->
proxy &&
930 "RAD_REQUEST_PROXY",
"proxy-request") == 0)) {
938 "RAD_REQUEST_PROXY_REPLY",
"proxy-reply") == 0)) {
949 #define RLM_PERL_FUNC(_x) static rlm_rcode_t CC_HINT(nonnull) mod_##_x(void *instance, REQUEST *request) \
951 return do_perl(instance, request, \
952 ((rlm_perl_t *)instance)->func_##_x); \
979 int acctstatustype=0;
982 acctstatustype = pair->vp_integer;
984 RDEBUG(
"Invalid Accounting Packet");
988 switch (acctstatustype) {
990 if (((
rlm_perl_t *)instance)->func_start_accounting) {
991 return do_perl(instance, request,
992 ((
rlm_perl_t *)instance)->func_start_accounting);
994 return do_perl(instance, request,
999 if (((
rlm_perl_t *)instance)->func_stop_accounting) {
1000 return do_perl(instance, request,
1001 ((
rlm_perl_t *)instance)->func_stop_accounting);
1003 return do_perl(instance, request,
1008 return do_perl(instance, request,
1021 int exitstatus = 0, count = 0;
1027 PERL_SET_CONTEXT(inst->
perl);
1029 dSP; ENTER; SAVETMPS;
1032 count = call_pv(inst->
func_detach, G_SCALAR | G_EVAL );
1037 if (exitstatus >= 100 || exitstatus < 0) {
1048 rlm_perl_destruct(inst->
perl);
1051 perl_destruct(inst->
perl);
1052 perl_free(inst->
perl);
1079 .config = module_config,
void fr_pair_list_free(VALUE_PAIR **)
Free memory used by a valuepair list.
5 methods index for preproxy section.
#define PW_TYPE_FILE_INPUT
File matching value must exist, and must be readable.
#define pthread_mutex_init(_x, _y)
VALUE_PAIR * config
VALUE_PAIR (s) used to set per request parameters for modules and the server core at runtime...
#define RINDENT()
Indent R* messages by one level.
char const * func_pre_proxy
int xlat_register(void *mod_inst, char const *name, xlat_func_t func, xlat_escape_t escape, xlat_instantiate_t instantiate, size_t inst_size, size_t buf_len)
Register an xlat function.
static XS(XS_radiusd_radlog)
static rlm_rcode_t mod_accounting(void *instance, REQUEST *request)
Write accounting data to Couchbase documents.
RADIUS_PACKET * proxy_reply
Incoming response from proxy server.
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv)
static rlm_rcode_t mod_post_auth(void *instance, REQUEST *request) CC_HINT(nonnull)
Metadata exported by the module.
int radlog(log_type_t lvl, char const *fmt,...) CC_HINT(format(printf
#define RLM_TYPE_THREAD_UNSAFE
Module is not threadsafe.
pthread_key_t * thread_key
void * rad_malloc(size_t size)
7 methods index for postauth section.
#define RLM_PERL_FUNC(_x)
static rlm_rcode_t mod_authorize(void *instance, REQUEST *request)
Handle authorization requests using Couchbase document data.
#define RLM_TYPE_THREAD_SAFE
Module is threadsafe.
#define RDEBUG_ENABLED
True if request debug level 1 messages are enabled.
VALUE_PAIR * username
Cached username VALUE_PAIR from request RADIUS_PACKET.
int8_t tag
Tag value used to group valuepairs.
void size_t fr_pair_value_snprint(char *out, size_t outlen, VALUE_PAIR const *vp, char quote)
Print the value of an attribute to a string.
VALUE_PAIR * vps
Result of decoding the packet into VALUE_PAIRs.
#define CONF_PARSER_TERMINATOR
const FR_NAME_NUMBER fr_tokens_table[]
char * fr_abin2hex(TALLOC_CTX *ctx, uint8_t const *bin, size_t inlen)
Convert binary data to a hex string.
VALUE_PAIR * fr_cursor_init(vp_cursor_t *cursor, VALUE_PAIR *const *node)
Setup a cursor to iterate over attribute pairs.
PUBLIC int snprintf(char *string, size_t length, char *format, va_alist)
struct rlm_perl_t rlm_perl_t
VALUE_PAIR * password
Cached password VALUE_PAIR from request RADIUS_PACKET.
The module considers the request invalid.
#define XLAT_DEFAULT_BUF_LEN
CONF_SECTION * cf_item_to_section(CONF_ITEM const *item)
Cast a CONF_ITEM to a CONF_SECTION.
static rlm_rcode_t mod_authenticate(void *instance, REQUEST *request) CC_HINT(nonnull)
Defines a CONF_PAIR to C data type mapping.
static int do_perl(void *instance, REQUEST *request, char const *function_name)
Abstraction to allow iterating over different configurations of VALUE_PAIRs.
fr_dict_attr_flags_t flags
Flags.
char const * cf_pair_value(CONF_PAIR const *pair)
#define RLM_PERL_CONF(_x)
static void perl_vp_to_svpvn_element(REQUEST *request, AV *av, VALUE_PAIR const *vp, int *i, const char *hash_name, const char *list_name)
static int pairadd_sv(TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, char *key, SV *sv, FR_TOKEN op, const char *hash_name, const char *list_name)
RADIUS_PACKET * proxy
Outgoing request to proxy server.
static void perl_store_vps(UNUSED TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, HV *rad_hv, const char *hash_name, const char *list_name)
char const * fr_syserror(int num)
Guaranteed to be thread-safe version of strerror.
#define pthread_mutex_unlock(_x)
static void xs_init(pTHX)
char const * func_accounting
char const * cf_pair_attr(CONF_PAIR const *pair)
bool cf_item_is_section(CONF_ITEM const *item)
CONF_PAIR * cf_item_to_pair(CONF_ITEM const *item)
Cast a CONF_ITEM to a CONF_PAIR.
4 methods index for checksimul section.
TALLOC_CTX * state_ctx
for request->state
HV * rad_perlconf_hv
holds "config" items (perl RAD_PERLCONF hash).
3 methods index for accounting section.
static int mod_detach(void *instance)
Stores an attribute, a value and various bits of other data.
static rlm_rcode_t mod_checksimul(void *instance, REQUEST *request)
Check if a given user is already logged in.
RADIUS_PACKET * reply
Outgoing response.
char const * func_stop_accounting
int8_t fr_pair_cmp_by_da_tag(void const *a, void const *b)
0 methods index for authenticate section.
char const * func_post_proxy
bool cf_item_is_pair(CONF_ITEM const *item)
#define REXDENT()
Exdent (unindent) R* messages by one level.
Configuration AVP similar to a VALUE_PAIR.
enum rlm_rcodes rlm_rcode_t
Return codes indicating the result of the module call.
int fr_pair_value_from_str(VALUE_PAIR *vp, char const *value, size_t len)
Convert string value to native attribute value.
char const * func_preacct
CONF_SECTION * cf_section_sub_find(CONF_SECTION const *, char const *name)
Find a sub-section in a section.
char const * cf_section_name1(CONF_SECTION const *cs)
char const * func_checksimul
static int mod_bootstrap(CONF_SECTION *conf, void *instance)
char name[1]
Attribute name.
#define ATTRIBUTE_EQ(_x, _y)
uint64_t magic
Used to validate module struct.
Module failed, don't reply.
static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
void fr_pair_list_sort(VALUE_PAIR **vps, fr_cmp_t cmp)
Sort a linked list of VALUE_PAIRs using merge sort.
static rlm_rcode_t CC_HINT(nonnull)
#define FR_CONF_OFFSET(_n, _t, _s, _f)
char const * func_authorize
VALUE_PAIR * fr_cursor_next(vp_cursor_t *cursor)
Advanced the cursor to the next VALUE_PAIR.
VALUE_PAIR * state
VALUE_PAIR (s) available over the lifetime of the authentication attempt.
RADIUS_PACKET * packet
Incoming request.
unsigned int has_tag
Tagged attribute.
CONF_ITEM * cf_item_find_next(CONF_SECTION const *section, CONF_ITEM const *item)
Return the next item after a CONF_ITEM.
#define truncate_len(_ret, _max)
6 methods index for postproxy section.
2 methods index for preacct section.
char const * func_start_accounting
#define PW_TYPE_REQUIRED
Error out if no matching CONF_PAIR is found, and no dflt value is set.
VALUE_PAIR * fr_pair_find_by_num(VALUE_PAIR *head, unsigned int vendor, unsigned int attr, int8_t tag)
Find the pair with the matching attribute.
8 methods index for recvcoa section.
static int get_hv_content(TALLOC_CTX *ctx, REQUEST *request, HV *my_hv, VALUE_PAIR **vps, const char *hash_name, const char *list_name)
VALUE_PAIR * fr_cursor_next_peek(vp_cursor_t *cursor)
Return the next VALUE_PAIR without advancing the cursor.
#define pthread_mutex_lock(_x)
size_t strlcpy(char *dst, char const *src, size_t siz)
char const * fr_int2str(FR_NAME_NUMBER const *table, int number, char const *def)
static const CONF_PARSER module_config[]
fr_dict_attr_t const * da
Dictionary attribute defines the attribute.
void fr_pair_value_bstrncpy(VALUE_PAIR *vp, void const *src, size_t len)
Copy data into an "string" data type.
9 methods index for sendcoa section.
String of printable characters.
1 methods index for authorize section.
#define pthread_mutex_destroy(_x)
char const * func_send_coa
VALUE_PAIR * fr_pair_make(TALLOC_CTX *ctx, VALUE_PAIR **vps, char const *attribute, char const *value, FR_TOKEN op)
Create a VALUE_PAIR from ASCII strings.
void fr_pair_value_memcpy(VALUE_PAIR *vp, uint8_t const *src, size_t len)
Copy data into an "octets" data type.
char const * cf_section_name2(CONF_SECTION const *cs)
char const * func_recv_coa
char const * func_authenticate
static int mod_instantiate(CONF_SECTION *conf, void *instance)
char const * func_post_auth
static ssize_t perl_xlat(char **out, size_t outlen, void const *mod_inst, UNUSED void const *xlat_inst, REQUEST *request, char const *fmt)