By default don't replace attribute lists after perl module calls

diff --git a/raddb/mods-available/perl b/raddb/mods-available/perl
index 3d37369f0f19d283bee054e2824f51bd9f37ff07..3de138dfbdd2f7542e561e37027008d6b143ae21 100644 (file)
--- a/raddb/mods-available/perl
+++ b/raddb/mods-available/perl
@@ -94,6 +94,19 @@ perl {
 #      func_post_auth = post_auth
 #      func_detach = detach
 
+       #
+       #  Control which attribute lists are replaced following calls to
+       #  the module.
+       #  The default is to not replace attribute lists.  Only enable
+       #  replacement where it is specifically required.
+       #
+       replace {
+#              request = no
+#              reply = no
+#              control = no
+#              session = no
+       }
+
        #
        #  config { ... }::
        #

diff --git a/src/modules/rlm_perl/rlm_perl.c b/src/modules/rlm_perl/rlm_perl.c
index ac56f0599d38f1a585da8efd975c1abab1231162..e3a0efa0ca5a79a787176cb4b96ee60434d93879 100644 (file)
--- a/src/modules/rlm_perl/rlm_perl.c
+++ b/src/modules/rlm_perl/rlm_perl.c
@@ -54,6 +54,13 @@ extern char **environ;
 #  error perl must be compiled with USE_ITHREADS
 #endif
 
+typedef struct {
+       bool    request;        //!< Should the request list be replaced after module call
+       bool    reply;          //!< Should the reply list be replaced after module call
+       bool    control;        //!< Should the control list be replaced after module call
+       bool    session;        //!< Should the session list be replaced after module call
+} rlm_perl_replace_t;
+
 /*
  *     Define a structure for our module configuration.
  *
@@ -75,6 +82,7 @@ typedef struct {
        char const      *perl_flags;
        PerlInterpreter *perl;
        bool            perl_parsed;
+       rlm_perl_replace_t      replace;
        HV              *rad_perlconf_hv;       //!< holds "config" items (perl %RAD_PERLCONF hash).
 
 } rlm_perl_t;
@@ -85,6 +93,14 @@ typedef struct {
 
 static void *perl_dlhandle;            //!< To allow us to load perl's symbols into the global symbol table.
 
+static const conf_parser_t replace_config[] = {
+       { FR_CONF_OFFSET("request", rlm_perl_replace_t, request) },
+       { FR_CONF_OFFSET("reply", rlm_perl_replace_t, reply) },
+       { FR_CONF_OFFSET("control", rlm_perl_replace_t, control) },
+       { FR_CONF_OFFSET("session", rlm_perl_replace_t, session) },
+       CONF_PARSER_TERMINATOR
+};
+
 /*
  *     A mapping of configuration file names to internal variables.
  */
@@ -103,6 +119,8 @@ static const conf_parser_t module_config[] = {
 
        { FR_CONF_OFFSET("perl_flags", rlm_perl_t, perl_flags) },
 
+       { FR_CONF_OFFSET_SUBSECTION("replace", 0, rlm_perl_t, replace, replace_config) },
+
        CONF_PARSER_TERMINATOR
 };
 
@@ -865,22 +883,26 @@ static unlang_action_t do_perl(rlm_rcode_t *p_result, module_ctx_t const *mctx,
                LEAVE;
 
                fr_pair_list_init(&vps);
-               if ((get_hv_content(request->request_ctx, request, rad_request_hv, &vps, "RAD_REQUEST", "request")) > 0) {
+               if (inst->replace.request &&
+                   (get_hv_content(request->request_ctx, request, rad_request_hv, &vps, "RAD_REQUEST", "request")) > 0) {
                        fr_pair_list_free(&request->request_pairs);
                        fr_pair_list_append(&request->request_pairs, &vps);
                }
 
-               if ((get_hv_content(request->reply_ctx, request, rad_reply_hv, &vps, "RAD_REPLY", "reply")) > 0) {
+               if (inst->replace.reply &&
+                   (get_hv_content(request->reply_ctx, request, rad_reply_hv, &vps, "RAD_REPLY", "reply")) > 0) {
                        fr_pair_list_free(&request->reply_pairs);
                        fr_pair_list_append(&request->reply_pairs, &vps);
                }
 
-               if ((get_hv_content(request->control_ctx, request, rad_config_hv, &vps, "RAD_CONFIG", "control")) > 0) {
+               if (inst->replace.control &&
+                   (get_hv_content(request->control_ctx, request, rad_config_hv, &vps, "RAD_CONFIG", "control")) > 0) {
                        fr_pair_list_free(&request->control_pairs);
                        fr_pair_list_append(&request->control_pairs, &vps);
                }
 
-               if ((get_hv_content(request->session_state_ctx, request, rad_state_hv, &vps, "RAD_STATE", "session-state")) > 0) {
+               if (inst->replace.session &&
+                   (get_hv_content(request->session_state_ctx, request, rad_state_hv, &vps, "RAD_STATE", "session-state")) > 0) {
                        fr_pair_list_free(&request->session_state_pairs);
                        fr_pair_list_append(&request->session_state_pairs, &vps);
                }

diff --git a/src/tests/modules/perl/module.conf b/src/tests/modules/perl/module.conf
index 0a8094235ff557e796fb807ede28ddca743814a0..8e576a3450de11394b066a7ac58e4a88c3d5394a 100644 (file)
--- a/src/tests/modules/perl/module.conf
+++ b/src/tests/modules/perl/module.conf
@@ -15,6 +15,10 @@ perl {
 #      func_xlat = xlat
 #      func_detach = detach
 
+       replace {
+               reply = yes
+       }
+
 #      config {
 #              name = "value"
 #              sub-config {