implement radiusd::radius_xlat in rlm_perl

Sponsored by: Yandex LLC

# Conflicts:
#	src/modules/rlm_perl/rlm_perl.c

diff --git a/doc/ChangeLog b/doc/ChangeLog
index c552405e14ae4053453096aff69af64745934a18..8f66a8877ef3e5ec4fc8d8a4305dc7c29136112f 100644 (file)
--- a/doc/ChangeLog
+++ b/doc/ChangeLog
@@ -27,6 +27,8 @@ FreeRADIUS 4.0.0 Sun 10 Jul 2016 15:48:14 EDT urgency=medium
        * TLV Attributes can now be nested to nearly any depth.
        * radsnmp client which can listen on Net-SNMP "pass persist"
          and translate that into queries to the server.
+       * rlm_perl: radiusd::xlat to evaluate xlat string within
+         perl script
 
        Bug fixes
        * Attribute names in unlang MUST be prefixed with &

diff --git a/raddb/mods-config/perl/example.pl b/raddb/mods-config/perl/example.pl
index cce15f204d31de081179fe3310c96f4d425d9272..3b96d948dfa6d904058216ab78b5c1bd4c8d9e23 100644 (file)
--- a/raddb/mods-config/perl/example.pl
+++ b/raddb/mods-config/perl/example.pl
@@ -126,7 +126,12 @@ sub authenticate {
                return RLM_MODULE_REJECT;
        } else {
                # Accept user and set some attribute
-               $RAD_REPLY{'h323-credit-amount'} = "100";
+               if (&radiusd::xlat("%{client:group}") eq 'UltraAllInclusive') {
+                       # User called from NAS with unlim plan set, set higher limits
+                       $RAD_REPLY{'h323-credit-amount'} = "1000000";
+               } else {
+                       $RAD_REPLY{'h323-credit-amount'} = "100";
+               }
                return RLM_MODULE_OK;
        }
 }

diff --git a/src/modules/rlm_perl/rlm_perl.c b/src/modules/rlm_perl/rlm_perl.c
index ecc63ed7f301cf2f6f20d98ee120af500c3adca5..c7b28199a99a350e2beacd81820588a1e19a111f 100644 (file)
--- a/src/modules/rlm_perl/rlm_perl.c
+++ b/src/modules/rlm_perl/rlm_perl.c
@@ -126,6 +126,7 @@ static const CONF_PARSER module_config[] = {
 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
 
 static int perl_sys_init3_called = 0;
+_Thread_local REQUEST *rlm_perl_request;
 
 #ifdef USE_ITHREADS
 #  define dl_librefs "DynaLoader::dl_librefs"
@@ -297,6 +298,39 @@ static XS(XS_radiusd_radlog)
        XSRETURN_NO;
 }
 
+/*
+ *     This is a wraper for radius_axlat
+ *     Now users are able to get data that is accessible only via xlat
+ *     e.g. %{client:...}
+ *     Call syntax is radiusd::xlat(string), string will be handled the
+ *     same way it is described in EXPANSIONS section of man unlang
+ */
+static XS(XS_radiusd_xlat)
+{
+       dXSARGS;
+       char *in_str;
+       char *expanded;
+       ssize_t slen;
+       REQUEST *request;
+
+       if (items != 1) croak("Usage: radiusd::xlat(string)");
+
+       request = rlm_perl_request;
+
+       in_str = (char *) SvPV(ST(0), PL_na);
+       expanded = NULL;
+       slen = radius_axlat(&expanded, request, in_str, NULL, NULL);
+
+       if (slen < 0) {
+               REDEBUG("Error parsing xlat '%s'", in_str);
+               XSRETURN_UNDEF;
+       }
+
+       XST_mPV(0, expanded);
+       talloc_free(expanded);
+       XSRETURN(1);
+}
+
 static void xs_init(pTHX)
 {
        char const *file = __FILE__;
@@ -305,6 +339,7 @@ static void xs_init(pTHX)
        newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 
        newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl");
+       newXS("radiusd::xlat",XS_radiusd_xlat, "rlm_perl");
 }
 
 /*
@@ -866,6 +901,11 @@ static int do_perl(void *instance, REQUEST *request, char const *function_name)
                }
 #endif
 
+               /*
+                * Store pointer to request structure globally so radiusd::xlat works
+                */
+               rlm_perl_request = request;
+
                PUSHMARK(SP);
                /*
                 * This way %RAD_xx can be pushed onto stack as sub parameters.