6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, write to the Free Software
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 * Copyright 2002 The FreeRADIUS server project
21 * Copyright 2002 Boian Jordanov <bjordanov@orbitel.bg>
25 #include "libradius.h"
46 static const char rcsid[] = "$Id$";
49 * Define a structure for our module configuration.
51 * These variables do not need to be in a structure, but it's
52 * a lot cleaner to do so, and a pointer to the structure can
53 * be used as the instance handle.
55 typedef struct perl_config {
62 * Some other things will be added in future
64 typedef struct perl_inst {
65 PerlInterpreter *perl;
72 * A mapping of configuration file names to internal variables.
74 * Note that the string is dynamically allocated, so it MUST
75 * be freed. When the configuration file parse re-reads the string,
76 * it free's the old one, and strdup's the new one, placing the pointer
77 * to the strdup'd string into 'config.string'. This gets around
80 static CONF_PARSER module_config[] = {
81 { "cmd", PW_TYPE_STRING_PTR, offsetof(PERL_CONFIG,cmd), NULL, NULL},
82 { "persistent", PW_TYPE_STRING_PTR, offsetof(PERL_CONFIG,persistent), NULL, NULL},
83 { NULL, -1, 0, NULL, NULL } /* end the list */
89 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
92 * Do any per-module initialization. e.g. set up connections
93 * to external databases, read configuration files, set up
94 * dictionary entries, etc.
96 * Try to avoid putting too much stuff in here - it's better to
97 * do it in instantiate() where it is not global.
99 static int perl_init(void)
102 * Everything's OK, return without an error.
111 static void xs_init(pTHX)
113 const char *file = __FILE__;
116 /* DynaLoader is a special case */
117 DEBUG("rlm_perl:: xs_init enter \n");
118 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
119 DEBUG("rlm_perl:: xs_init leave \n");
124 * Perl xlat we use already running perl just recompile and store in memory
125 * REMEMBER: each file will only be compiled once. Note that the process
126 * will continue to grow for each file that it uses and is not compiled.
129 * %{perl:/usr/bin/test.pl %{User-Name}} will run /usr/bin/test.pl,
130 * give @ARGV with User-Name in $ARGV[0]
131 * To return something just assign it to $main::ret_val
138 * print "ARGV[1]=$ARGV[1] ARGV[2]=$ARGV[2]\n";
139 * $main::ret_val = "B";
143 static int perl_xlat(void *instance, REQUEST *request, char *fmt, char *out, int freespace,
144 RADIUS_ESCAPE_STRING func)
146 PERL_INST *inst=instance;
149 char *args[] = {"", DO_CLEAN, NULL};
150 char params[1024], *tmp_ptr, *ptr;
151 int exitstatus=0,len;
156 * Do an xlat on the provided string (nice recursive operation).
159 if (!radius_xlat(params, sizeof(params), fmt, request, func))
161 radlog(L_ERR, "rlm_perl: xlat failed.");
165 PERL_SET_CONTEXT(inst->perl);
166 ptr = strtok(params, " ");
169 array_av = get_av("ARGV",0);
171 ret_val = get_sv("main::ret_val",1);
174 while ((tmp_ptr=strtok(NULL, " ")) != NULL) {
175 av_store(array_av,key++,newSVpv(tmp_ptr,0));
178 PERL_SET_CONTEXT(inst->perl);
179 call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args);
182 exitstatus = SvIV(perl_get_sv("!",FALSE));
183 radlog(L_INFO, "perl_embed::perl_xlat exit status=%d, %s\n", exitstatus, SvPV(ERRSV,n_a));
187 * Now get the variable we need
188 * His name is $ret_val
193 if (SvTRUE(ret_val)) {
195 out = SvPV(ret_val,n_a);
198 radlog(L_INFO,"Len is %d , out is %s", len, out);
200 if (len <= freespace)
209 * Do any per-module initialization that is separate to each
210 * configured instance of the module. e.g. set up connections
211 * to external databases, read configuration files, set up
212 * dictionary entries, etc.
214 * If configuration information is given in the config section
215 * that must be referenced in later calls, store a handle to it
216 * in *instance otherwise put a null pointer there.
218 static int perl_instantiate(CONF_SECTION *conf, void **instance)
221 char *embed[2], *xlat_name;
225 * Set up a storage area for instance data
228 inst = rad_malloc(sizeof(PERL_INST));
229 memset(inst, 0, sizeof(PERL_INST));
231 inst->config = rad_malloc(sizeof(PERL_CONFIG));
232 memset(inst->config, 0, sizeof(PERL_CONFIG));
234 * If the configuration parameters can't be parsed, then
237 if (cf_section_parse(conf, inst->config, module_config) < 0) {
245 * Prepare perl instance
248 if((inst->perl = perl_alloc()) == NULL) {
249 radlog(L_INFO, "no memory!");
253 PERL_SET_CONTEXT(inst->perl);
254 perl_construct(inst->perl);
256 PERL_SET_CONTEXT(inst->perl);
259 embed[1] = inst->config->persistent;
261 exitstatus = perl_parse(inst->perl, xs_init, 2, embed, NULL);
263 PERL_SET_CONTEXT(inst->perl);
265 exitstatus = perl_run(inst->perl);
267 radlog(L_INFO,"perl_parse failed: %s not found or has syntax errors. \n", inst->config->persistent);
271 inst->env_hv = perl_get_hv("ENV",0);
272 inst->result_hv = perl_get_hv("main::result",1);
274 xlat_name = cf_section_name2(conf);
275 if (xlat_name == NULL)
276 xlat_name = cf_section_name1(conf);
278 inst->config->xlat_name = strdup(xlat_name);
279 xlat_register(xlat_name, perl_xlat, inst);
287 * Boyan get the request and put them in perl hash
288 * which will be given to perl cmd
290 static void perl_env(VALUE_PAIR *vp, PERL_INST *inst)
294 hv_clear(inst->env_hv);
295 hv_clear(inst->result_hv);
297 for ( ; vp != NULL; vp = vp->next) {
300 len = vp_prints_value(buffer, sizeof(buffer), vp, FALSE);
302 hv_store(inst->env_hv, vp->name, strlen(vp->name),
303 newSVpv(buffer, len),0);
308 * return structs and status 0 OK 1 Not
311 static int rlmperl_call(void *instance, REQUEST *request)
314 PERL_INST *inst = (PERL_INST *) instance;
317 char *key, *val, *ptr, *p;
318 char *args[] = {NULL, DO_CLEAN, NULL};
322 int exitstatus = 0, comma = 0;
325 args[0] = inst->config->cmd;
327 perl_env(request->packet->vps, inst);
329 for (i = hv_iterinit(inst->env_hv); i > 0; i--) {
330 res_sv = hv_iternextsv(inst->env_hv, &key, &key_len);
331 val = SvPV(res_sv,val_len);
332 radlog(L_DBG, "ENV %s= %s", key, val);
335 PERL_SET_CONTEXT(inst->perl);
336 call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args);
341 exitstatus = SvIV(perl_get_sv("!",FALSE));;
342 radlog(L_INFO, "exit status=%d, %s\n", exitstatus,
347 PERL_SET_CONTEXT(inst->perl);
349 for (i = hv_iterinit(inst->result_hv); i > 0; i--) {
350 res_sv = hv_iternextsv(inst->result_hv,&key,&key_len);
351 val = SvPV(res_sv,val_len);
352 sprintf(ptr, "%s=\"%s\"\n", key, val); /* FIXME: snprintf */
353 ptr += key_len + val_len + 4;
355 /* perl_free(inst->perl); */
360 for (p = answer; *p; p++) {
362 *p = comma ? ' ' : ',';
365 if (*p == ',') comma++;
369 * Replace any trailing comma by a NUL.
371 if (answer[strlen(answer) - 1] == ',') {
372 answer[strlen(answer) - 1] = '\0';
374 radlog(L_INFO,"perl_embed :: value-pairs: %s", answer);
376 if (userparse(answer, &vp) < 0) {
377 radlog(L_ERR, "perl_embed :: %s: unparsable reply", args[0]);
379 pairmove(&request->reply->vps, &vp);
387 * Find the named user in this modules database. Create the set
388 * of attribute-value pairs to check and reply with for this user
389 * from the database. The authentication code only needs to check
390 * the password, the rest is done here.
392 static int perl_authorize(void *instance, REQUEST *request)
396 radlog(L_INFO,"perl_embed :: Enter Authorize");
398 if ((status = rlmperl_call(instance, request)) == 0) {
399 return RLM_MODULE_OK;
402 return RLM_MODULE_FAIL;
406 * Authenticate the user with the given password.
408 static int perl_authenticate(void *instance, REQUEST *request)
412 radlog(L_INFO,"perl_embed :: Enter Auth");
414 if ((status = rlmperl_call(instance, request)) == 0) {
415 return RLM_MODULE_OK;
418 return RLM_MODULE_FAIL;
423 * Massage the request before recording it or proxying it
425 static int perl_preacct(void *instance, REQUEST *request)
429 radlog(L_INFO,"mod_perl :: Enter PreAccounting");
431 if ((status = rlmperl_call(instance, request)) == 0) {
432 return RLM_MODULE_OK;
435 return RLM_MODULE_FAIL;
439 * Write accounting information to this modules database.
442 static int perl_accounting(void *instance, REQUEST *request)
446 radlog(L_INFO,"mod_perl :: Enter Accounting");
448 if ((status = (rlmperl_call(instance, request))) == 0) {
449 return RLM_MODULE_OK;
452 return RLM_MODULE_FAIL;
456 * Detach a instance free all ..
458 static int perl_detach(void *instance)
460 PERL_INST *inst=instance;
461 PERL_SET_CONTEXT(inst->perl);
462 perl_destruct(inst->perl);
463 PERL_SET_CONTEXT(inst->perl);
464 perl_free(inst->perl);
467 hv_clear(inst->env_hv);
468 hv_clear(inst->result_hv);
475 * The module name should be the only globally exported symbol.
476 * That is, everything else should be 'static'.
478 * If the module needs to temporarily modify it's instantiation
479 * data, the type should be changed to RLM_TYPE_THREAD_UNSAFE.
480 * The server will then take care of ensuring that the module
481 * is single-threaded.
483 module_t rlm_perl = {
485 RLM_TYPE_THREAD_UNSAFE, /* type */
486 perl_init, /* initialization */
487 perl_instantiate, /* instantiation */
494 perl_detach, /* detach */