The FreeRADIUS server $Id: 15bac2a4c627c01d1aa2047687b3418955ac7f00 $
Loading...
Searching...
No Matches
rlm_perl.c
Go to the documentation of this file.
1/*
2 * This program is is free software; you can redistribute it and/or modify
3 * it under the terms of the GNU General Public License as published by
4 * the Free Software Foundation; either version 2 of the License, or (at
5 * your option) any later version.
6 *
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * GNU General Public License for more details.
11 *
12 * You should have received a copy of the GNU General Public License
13 * along with this program; if not, write to the Free Software
14 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
15 */
16
17/**
18 * $Id: bdc32e5faae45a8bb3d58c3fabf64b1486629fef $
19 * @file rlm_perl.c
20 * @brief Translates requests between the server an a perl interpreter.
21 *
22 * @copyright 2002,2006 The FreeRADIUS server project
23 * @copyright 2002 Boian Jordanov (bjordanov@orbitel.bg)
24 */
25RCSID("$Id: bdc32e5faae45a8bb3d58c3fabf64b1486629fef $")
26
27#define LOG_PREFIX "perl"
28
29#include <freeradius-devel/server/base.h>
30#include <freeradius-devel/server/module_rlm.h>
31#include <freeradius-devel/util/debug.h>
32#include <freeradius-devel/unlang/xlat_func.h>
33#include <freeradius-devel/unlang/xlat.h>
34#include <freeradius-devel/radius/radius.h>
35
37DIAG_OFF(compound-token-split-by-macro) /* Perl does horrible things with macros */
39
40#ifdef INADDR_ANY
41# undef INADDR_ANY
42#endif
43#include <EXTERN.h>
44#include <perl.h>
45#include <XSUB.h>
46#include <dlfcn.h>
47#include <semaphore.h>
48
49#if defined(__APPLE__) || defined(__FreeBSD__)
50extern char **environ;
51#endif
52
53#ifndef USE_ITHREADS
54# error perl must be compiled with USE_ITHREADS
55#endif
56
57typedef struct {
58 char const *function_name; //!< Name of the function being called
59 char *name1; //!< Section name1 where this is called
60 char *name2; //!< Section name2 where this is called
61 fr_rb_node_t node; //!< Node in tree of function calls.
63
64typedef struct {
67
71
72/*
73 * Define a structure for our module configuration.
74 *
75 * These variables do not need to be in a structure, but it's
76 * a lot cleaner to do so, and a pointer to the structure can
77 * be used as the instance handle.
78 */
79typedef struct {
80 /* Name of the perl module */
81 char const *module;
82
83 fr_rb_tree_t funcs; //!< Tree of function calls found by call_env parser.
84 bool funcs_init; //!< Has the tree been initialised.
85 char const *func_detach; //!< Function to run when mod_detach is run.
86 char const *perl_flags;
87 PerlInterpreter *perl;
89 HV *rad_perlconf_hv; //!< holds "config" items (perl %RAD_PERLCONF hash).
91
93
94typedef struct {
95 PerlInterpreter *perl; //!< Thread specific perl interpreter.
97
98/*
99 * C structure associated with tied hashes and arrays
100 */
103 fr_dict_attr_t const *da; //!< Dictionary attribute associated with hash / array.
104 fr_pair_t *vp; //!< Real pair associated with the hash / array, if it exists.
105 unsigned int idx; //!< Instance number.
106 fr_perl_pair_t *parent; //!< Parent attribute data.
107 fr_dcursor_t cursor; //!< Cursor used for iterating over the keys of a tied hash.
108};
109
110/*
111 * Dummy Magic Virtual Table used to ensure we retrieve the correct magic data
112 */
113static MGVTBL rlm_perl_vtbl = { 0, 0, 0, 0, 0, 0, 0, 0 };
114
115static void *perl_dlhandle; //!< To allow us to load perl's symbols into the global symbol table.
116
117/*
118 * A mapping of configuration file names to internal variables.
119 */
120static const conf_parser_t module_config[] = {
122
123 { FR_CONF_OFFSET("func_detach", rlm_perl_t, func_detach), .data = NULL, .dflt = "detach", .quote = T_INVALID },
124
125 { FR_CONF_OFFSET("perl_flags", rlm_perl_t, perl_flags) },
126
128};
129
130/** How to compare two Perl function calls
131 *
132 */
133static int8_t perl_func_def_cmp(void const *one, void const *two)
134{
135 perl_func_def_t const *a = one, *b = two;
136 int ret;
137
138 ret = strcmp(a->name1, b->name1);
139 if (ret != 0) return CMP(ret, 0);
140 if (!a->name2 && !b->name2) return 0;
141 if (!a->name2 || !b->name2) return a->name2 ? 1 : -1;
142 ret = strcmp(a->name2, b->name2);
143 return CMP(ret, 0);
144}
145
146/*
147 * man perlembed
148 */
149EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
150
151static _Thread_local request_t *rlm_perl_request;
152
153# define dl_librefs "DynaLoader::dl_librefs"
154# define dl_modules "DynaLoader::dl_modules"
155static void rlm_perl_clear_handles(pTHX)
156{
157 AV *librefs = get_av(dl_librefs, false);
158 if (librefs) {
159 av_clear(librefs);
160 }
161}
162
163static void **rlm_perl_get_handles(pTHX)
164{
165 I32 i;
166 AV *librefs = get_av(dl_librefs, false);
167 AV *modules = get_av(dl_modules, false);
168 void **handles;
169
170 if (!librefs) return NULL;
171
172 if (!(AvFILL(librefs) >= 0)) {
173 return NULL;
174 }
175
176 MEM(handles = talloc_array(NULL, void *, AvFILL(librefs) + 2));
177 for (i = 0; i <= AvFILL(librefs); i++) {
178 void *handle;
179 SV *handle_sv = *av_fetch(librefs, i, false);
180 if (!handle_sv) {
181 ERROR("Could not fetch $%s[%d]!", dl_librefs, (int)i);
182 continue;
183 }
184 handle = (void *)SvIV(handle_sv);
185
186 if (handle) handles[i] = handle;
187 }
188
189 av_clear(modules);
190 av_clear(librefs);
191
192 handles[i] = (void *)0;
193
194 return handles;
195}
196
197static void rlm_perl_close_handles(void **handles)
198{
199 int i;
200
201 if (!handles) {
202 return;
203 }
204
205 for (i = 0; handles[i]; i++) {
206 DEBUG("Close %p", handles[i]);
207 dlclose(handles[i]);
208 }
209
210 talloc_free(handles);
211}
212
213/*
214 * This is wrapper for fr_log
215 * Now users can call freeradius::log(level,msg) which is the same
216 * as calling fr_log from C code.
217 */
218static XS(XS_freeradius_log)
219{
220 dXSARGS;
221 if (items !=2)
222 croak("Usage: radiusd::log(level, message)");
223 {
224 int level;
225 char *msg;
226
227 level = (int) SvIV(ST(0));
228 msg = (char *) SvPV(ST(1), PL_na);
229
230 /*
231 * Because 'msg' is a 'char *', we don't want '%s', etc.
232 * in it to give us printf-style vulnerabilities.
233 */
234 fr_log(&default_log, level, __FILE__, __LINE__, "rlm_perl: %s", msg);
235 }
236 XSRETURN_NO;
237}
238
239/*
240 * This is a wrapper for xlat_aeval
241 * Now users are able to get data that is accessible only via xlat
242 * e.g. %request.client(...)
243 * Call syntax is freeradius::xlat(string), string will be handled as
244 * a double-quoted string in the configuration files.
245 */
246static XS(XS_freeradius_xlat)
247{
248 dXSARGS;
249 char *in_str;
250 char *expanded;
251 ssize_t slen;
252 request_t *request;
253
254 if (items != 1) croak("Usage: radiusd::xlat(string)");
255
256 request = rlm_perl_request;
257
258 in_str = (char *) SvPV(ST(0), PL_na);
259
260 slen = xlat_aeval(request, &expanded, request, in_str, NULL, NULL);
261 if (slen < 0) {
262 REDEBUG("Error parsing xlat '%s'", in_str);
263 XSRETURN_UNDEF;
264 }
265
266 XST_mPV(0, expanded);
267 talloc_free(expanded);
268 XSRETURN(1);
269}
270
271/** Helper function for turning hash keys into dictionary attributes
272 *
273 */
274static inline fr_dict_attr_t const *perl_attr_lookup(fr_perl_pair_t *pair_data, char const *attr)
275{
276 fr_dict_attr_t const *da = fr_dict_attr_by_name(NULL, pair_data->da, attr);
277
278 /*
279 * Allow fallback to internal attributes if the parent is a group or dictionary root.
280 */
281 if (!da && (fr_type_is_group(pair_data->da->type) || pair_data->da->flags.is_root)) {
283 }
284
285 if (!da) croak("Unknown or invalid attribute name \"%s\"", attr);
286
287 return da;
288}
289
290/** Convenience macro for fetching C data associated with tied hash / array and validating stack size
291 *
292 */
293#define GET_PAIR_MAGIC(count) MAGIC *mg = mg_findext(ST(0), PERL_MAGIC_ext, &rlm_perl_vtbl); \
294 fr_perl_pair_t *pair_data; \
295 if (unlikely(items < count)) { \
296 croak("Expected %d stack entries, got %d", count, items); \
297 XSRETURN_UNDEF; \
298 } \
299 if (!mg) { \
300 croak("Failed to find Perl magic value"); \
301 XSRETURN_UNDEF; \
302 } \
303 pair_data = (fr_perl_pair_t *)mg->mg_ptr;
304
305/** Functions to implement subroutines required for a tied hash
306 *
307 * All structural components of attributes are represented by tied hashes
308 */
309
310/** Called when fetching hash values
311 *
312 * The stack contains
313 * - the tied SV
314 * - the hash key being requested
315 *
316 * When a numeric key is requested, we treat that as in instruction to find
317 * a specific instance of the key of the parent.
318 *
319 * Whilst this is a bit odd, the alternative would be for every attribute to
320 * be returned as an array so you would end up with crazy syntax like
321 * p{'request'}{'Vendor-Specific'}[0]{'Cisco'}[0]{'AVPair}[0]
322 */
323static XS(XS_pairlist_FETCH)
324{
325 dXSARGS;
326 char *attr;
327 fr_dict_attr_t const *da;
328 fr_pair_t *vp = NULL;
329 STRLEN len, i = 0;
330 int idx = 0;
331
333
334 attr = (char *) SvPV(ST(1), len);
335
336 /*
337 * Check if our key is entirely numeric.
338 */
339 while (i < len) {
340 if (!isdigit(attr[i])) break;
341 i++;
342 }
343 if (i == len) {
344 idx = SvIV(ST(1));
345 da = pair_data->da;
346 if (pair_data->parent->vp) vp = fr_pair_find_by_da_idx(&pair_data->parent->vp->vp_group, da, idx);
347 } else {
348 da = perl_attr_lookup(pair_data, attr);
349 if (!da) XSRETURN_UNDEF;
350 if (pair_data->vp) vp = fr_pair_find_by_da(&pair_data->vp->vp_group, NULL, da);
351 }
352
353 switch(da->type) {
354 /*
355 * Leaf attributes are returned as an array with magic
356 */
357 case FR_TYPE_LEAF:
358 {
359 AV *pair_av;
360 SV *pair_tie;
361 HV *frpair_stash;
362 fr_perl_pair_t child_pair_data;
363
364 frpair_stash = gv_stashpv("freeradiuspairs", GV_ADD);
365 pair_av = newAV();
366 pair_tie = newRV_noinc((SV *)newAV());
367 sv_bless(pair_tie, frpair_stash);
368 sv_magic(MUTABLE_SV(pair_av), MUTABLE_SV((GV *)pair_tie), PERL_MAGIC_tied, NULL, 0);
369 SvREFCNT_dec(pair_tie);
370
371 child_pair_data = (fr_perl_pair_t) {
372 .vp = vp,
373 .da = da,
374 .parent = pair_data
375 };
376 sv_magicext((SV *)pair_tie, 0, PERL_MAGIC_ext, &rlm_perl_vtbl, (char *)&child_pair_data, sizeof(child_pair_data));
377 ST(0) = sv_2mortal(newRV((SV *)pair_av));
378 }
379 break;
380
381 /*
382 * Structural attributes are returned as a hash with magic
383 */
385 {
386 HV *struct_hv;
387 SV *struct_tie;
388 HV *frpair_stash;
389 fr_perl_pair_t child_pair_data;
390
391 frpair_stash = gv_stashpv("freeradiuspairlist", GV_ADD);
392 struct_hv = newHV();
393 struct_tie = newRV_noinc((SV *)newHV());
394 sv_bless(struct_tie, frpair_stash);
395 hv_magic(struct_hv, (GV *)struct_tie, PERL_MAGIC_tied);
396 SvREFCNT_dec(struct_tie);
397
398 child_pair_data = (fr_perl_pair_t) {
399 .vp = vp,
400 .da = da,
401 .parent = pair_data,
402 .idx = idx
403 };
404 sv_magicext((SV *)struct_tie, 0, PERL_MAGIC_ext, &rlm_perl_vtbl, (char *)&child_pair_data, sizeof(child_pair_data));
405 ST(0) = sv_2mortal(newRV((SV *)struct_hv));
406 }
407 break;
408
409 default:
410 fr_assert(0);
411 }
412
413 XSRETURN(1);
414}
415
416/** Called when a hash value is set / updated
417 *
418 * This is not allowed - only leaf node arrays can have values set
419 */
420static XS(XS_pairlist_STORE)
421{
422 dXSARGS;
423 char *attr;
424 fr_dict_attr_t const *da;
425
427
428 attr = (char *) SvPV(ST(1), PL_na);
429 da = perl_attr_lookup(pair_data, attr);
430 if (!da) XSRETURN(0);
431
432 if (fr_type_is_leaf(da->type)) {
433 croak("Cannot set value of array of \"%s\" values. Use array index to set a specific instance.", da->name);
434 } else {
435 croak("Cannot set values of structural object %s", da->name);
436 }
437 XSRETURN(0);
438}
439
440/** Called to test the existence of a key in a tied hash
441 *
442 * The stack contains
443 * - the tied SV
444 * - the key to check for
445 */
446static XS(XS_pairlist_EXISTS)
447{
448 dXSARGS;
449 char *attr;
450 fr_dict_attr_t const *da;
451 STRLEN len, i = 0;
452
454
455 attr = (char *) SvPV(ST(1), len);
456 while (i < len) {
457 if (!isdigit(attr[i])) break;
458 i++;
459 }
460
461 /*
462 * Numeric key - check for an instance of the attribute
463 */
464 if (i == len) {
465 unsigned int idx = SvIV(ST(1));
466 if (pair_data->parent->vp) {
467 if (fr_pair_find_by_da_idx(&pair_data->parent->vp->vp_group, pair_data->da, idx)) XSRETURN_YES;
468 }
469 XSRETURN_NO;
470 }
471
472 if (!pair_data->vp) XSRETURN_NO;
473
474 da = perl_attr_lookup(pair_data, attr);
475 if (!da) XSRETURN_NO;
476
477 if(fr_pair_find_by_da(&pair_data->vp->vp_group, NULL, da)) XSRETURN_YES;
478
479 XSRETURN_NO;
480}
481
482/** Called when functions like keys() want the first key in a tied hash
483 *
484 * The stack contains just the tied SV
485 */
486static XS(XS_pairlist_FIRSTKEY)
487{
488 dXSARGS;
489 fr_pair_t *vp;
490
492 if (!pair_data->vp) XSRETURN_EMPTY;
493
494 vp = fr_pair_dcursor_init(&pair_data->cursor, &pair_data->vp->vp_group);
495 ST(0) = sv_2mortal(newSVpv(vp->da->name, vp->da->name_len));
496 XSRETURN(1);
497}
498
499/** Called by functions like keys() which iterate over the keys in a tied hash
500 *
501 * The stack contains
502 * - the tied SV
503 * - the previous key
504 */
505static XS(XS_pairlist_NEXTKEY)
506{
507 dXSARGS;
508 fr_pair_t *vp;
509
511 if (!pair_data->vp) XSRETURN_EMPTY;
512
513 vp = fr_dcursor_next(&pair_data->cursor);
514 if (!vp) XSRETURN_EMPTY;
515
516 ST(0) = sv_2mortal(newSVpv(vp->da->name, vp->da->name_len));
517 XSRETURN(1);
518}
519
520/** Called to delete a key from a tied hash
521 *
522 * The stack contains
523 * - the tied SV
524 * - the key being deleted
525 */
526static XS(XS_pairlist_DELETE)
527{
528 dXSARGS;
529 char *attr;
530 fr_dict_attr_t const *da;
531 fr_pair_t *vp;
532
534 attr = SvPV(ST(1), PL_na);
535
536 da = perl_attr_lookup(pair_data, attr);
537 if (!da) XSRETURN(0);
538 if (!pair_data->vp) XSRETURN(0);
539
540 vp = fr_pair_find_by_da(&pair_data->vp->vp_group, NULL, da);
541
542 if (vp) fr_pair_delete(&pair_data->vp->vp_group, vp);
543
544 XSRETURN(0);
545}
546
547/** Functions to implement subroutines required for a tied array
548 *
549 * Leaf attributes are represented by tied arrays to allow multiple instances.
550 */
551
553{
554 switch(vp->vp_type) {
555 case FR_TYPE_STRING:
556 *value = sv_2mortal(newSVpvn(vp->vp_strvalue, vp->vp_length));
557 break;
558
559 case FR_TYPE_OCTETS:
560 *value = sv_2mortal(newSVpvn((char const *)vp->vp_octets, vp->vp_length));
561 break;
562
563#define PERLUINT(_size) case FR_TYPE_UINT ## _size: \
564 *value = sv_2mortal(newSVuv(vp->vp_uint ## _size)); \
565 break;
566 PERLUINT(8)
567 PERLUINT(16)
568 PERLUINT(32)
569 PERLUINT(64)
570
571#define PERLINT(_size) case FR_TYPE_INT ## _size: \
572 *value = sv_2mortal(newSViv(vp->vp_int ## _size)); \
573 break;
574 PERLINT(8)
575 PERLINT(16)
576 PERLINT(32)
577 PERLINT(64)
578
579 case FR_TYPE_BOOL:
580 *value = sv_2mortal(newSVuv(vp->vp_bool));
581 break;
582
583 case FR_TYPE_FLOAT32:
584 *value = sv_2mortal(newSVnv(vp->vp_float32));
585 break;
586
587 case FR_TYPE_FLOAT64:
588 *value = sv_2mortal(newSVnv(vp->vp_float64));
589 break;
590
591 case FR_TYPE_ETHERNET:
598 case FR_TYPE_IFID:
599 case FR_TYPE_DATE:
601 {
602 char buff[128];
603 ssize_t slen;
604
606 if (slen < 0) {
607 croak("Cannot convert %s to Perl type, insufficient buffer space",
608 fr_type_to_str(vp->vp_type));
609 return -1;
610 }
611
612 *value = sv_2mortal(newSVpv(buff, slen));
613 }
614 break;
615
616 /* Only leaf nodes should be able to call this */
617 default:
618 fr_assert(0);
619 return -1;
620 }
621
622 return 0;
623}
624
625/** Called to retrieve the value of an array entry
626 *
627 * In our case, retrieve the value of a specific instance of a leaf attribute
628 *
629 * The stack contains
630 * - the tied SV
631 * - the index to retrieve
632 *
633 * The magic data will hold the DA of the attribute.
634 */
635static XS(XS_pairs_FETCH)
636{
637 dXSARGS;
638 unsigned int idx = SvUV(ST(1));
639 fr_pair_t *vp = NULL;
641
643
644 parent = pair_data->parent;
645 if (!parent->vp) XSRETURN_UNDEF;
646
647 if (idx == 0) vp = pair_data->vp;
648 if (!vp) vp = fr_pair_find_by_da_idx(&parent->vp->vp_group, pair_data->da, idx);
649 if (!vp) XSRETURN_UNDEF;
650
651 if (perl_value_marshal(vp, &ST(0)) < 0) XSRETURN(0);
652 XSRETURN(1);
653}
654
655/** Build parent structural pairs needed when a leaf node is set
656 *
657 */
659{
660 fr_perl_pair_t *parent = pair_data->parent;
661 if (!parent->vp) {
662 /*
663 * When building parent with idx > 0, it's "parent" is the
664 * first instance of the attribute - so if that's not there
665 * we don't have any.
666 */
667 if (pair_data->idx > 0) {
668 none_exist:
669 croak("Attempt to set instance %d when none exist", pair_data->idx);
670 return -1;
671 }
672 if (fr_perl_pair_parent_build(parent) < 0) return -1;
673 }
674
675 if (pair_data->idx > 0) {
676 unsigned int count;
677
678 if (!parent->parent->vp) goto none_exist;
679 count = fr_pair_count_by_da(&parent->parent->vp->vp_group, pair_data->da);
680 if (count < pair_data->idx) {
681 croak("Attempt to set instance %d when only %d exist", pair_data->idx, count);
682 return -1;
683 }
684 parent = parent->parent;
685 }
686
687 if (fr_pair_append_by_da(parent->vp, &pair_data->vp, &parent->vp->vp_group, pair_data->da) < 0) return -1;
688 return 0;
689}
690
691/** Convert a Perl SV to a pair value.
692 *
693 */
695{
696 char *val;
697 STRLEN len;
698
699 switch (vp->vp_type) {
700 case FR_TYPE_STRING:
701 val = SvPV(value, len);
703 fr_pair_value_bstrndup(vp, val, len, true);
704 break;
705
706 case FR_TYPE_OCTETS:
707 val = SvPV(value, len);
709 fr_pair_value_memdup(vp, (uint8_t const *)val, len, true);
710 break;
711
712#define PERLSETUINT(_size) case FR_TYPE_UINT ## _size: \
713 vp->vp_uint ## _size = SvUV(value); \
714 break;
715 PERLSETUINT(8)
716 PERLSETUINT(16)
717 PERLSETUINT(32)
718 PERLSETUINT(64)
719
720#define PERLSETINT(_size) case FR_TYPE_INT ## _size: \
721 vp->vp_int ## _size = SvIV(value); \
722 break;
723 PERLSETINT(8)
724 PERLSETINT(16)
725 PERLSETINT(32)
726 PERLSETINT(64)
727
728 case FR_TYPE_ETHERNET:
735 case FR_TYPE_IFID:
737 case FR_TYPE_DATE:
738 val = SvPV(value, len);
739 if (fr_pair_value_from_str(vp, val, len, NULL, false) < 0) {
740 croak("Failed populating pair");
741 return -1;
742 }
743 break;
744
745 default:
746 fr_assert(0);
747 break;
748 }
749
750 return 0;
751}
752
753/** Called when an array value is set / updated
754 *
755 * The stack contains
756 * - the tied SV
757 * - the index being updated
758 * - the value being assigned
759 */
760static XS(XS_pairs_STORE)
761{
762 dXSARGS;
763 unsigned int idx = SvUV(ST(1));
764 fr_pair_t *vp;
766
768
769 fr_assert(fr_type_is_leaf(pair_data->da->type));
770
771 parent = pair_data->parent;
772
773 if (!parent->vp) {
774 /*
775 * Trying to set something other than the first instance when
776 * the parent doesn't exist is invalid.
777 */
778 if (idx > 0) {
779 croak("Attempting to set instance %d when none exist", idx);
780 XSRETURN(0);
781 }
782
783 if(fr_perl_pair_parent_build(parent) < 0) XSRETURN(0);
784 }
785
786 vp = fr_pair_find_by_da_idx(&parent->vp->vp_group, pair_data->da, idx);
787 if (!vp) {
788 if (idx > 0) {
789 unsigned int count = fr_pair_count_by_da(&pair_data->parent->vp->vp_group, pair_data->da);
790 if (count < idx) {
791 croak("Attempt to set instance %d when only %d exist", idx, count);
792 XSRETURN(0);
793 }
794 }
795 fr_pair_append_by_da(parent->vp, &vp, &parent->vp->vp_group, pair_data->da);
796 }
797
798 perl_value_unmarshal(vp, ST(2));
799
800 XSRETURN(0);
801}
802
803/** Called when an array entry's existence is tested
804 *
805 */
806static XS(XS_pairs_EXISTS)
807{
808 dXSARGS;
809 unsigned int idx = SvUV(ST(1));
810 fr_pair_t *vp;
812
814
815 parent = pair_data->parent;
816 if (!parent->vp) XSRETURN_NO;
817
818 vp = fr_pair_find_by_da_idx(&parent->vp->vp_group, pair_data->da, idx);
819 if (vp) XSRETURN_YES;
820 XSRETURN_NO;
821}
822
823/** Called when an array entry is deleted
824 *
825 */
826static XS(XS_pairs_DELETE)
827{
828 dXSARGS;
829 unsigned int idx = SvUV(ST(1));
830 fr_pair_t *vp;
832
834
835 parent = pair_data->parent;
836 if (!parent->vp) XSRETURN(0);
837
838 vp = fr_pair_find_by_da_idx(&parent->vp->vp_group, pair_data->da, idx);
839 if (vp) fr_pair_delete(&parent->vp->vp_group, vp);
840 XSRETURN(0);
841}
842
843/** Called when Perl wants the size of a tied array
844 *
845 * The stack contains just the tied SV
846 */
847static XS(XS_pairs_FETCHSIZE)
848{
849 dXSARGS;
851
852 if (!pair_data->parent->vp) XSRETURN_UV(0);
853 XSRETURN_UV(fr_pair_count_by_da(&pair_data->parent->vp->vp_group, pair_data->da));
854}
855
856/** Called when attempting to set the size of an array
857 *
858 * We don't allow expanding the array this way, but will allow deleting pairs
859 *
860 * The stack contains
861 * - the tied SV
862 * - the requested size of the array
863 */
864static XS(XS_pairs_STORESIZE)
865{
866 dXSARGS;
867 unsigned int count, req_size = SvUV(ST(1));
868 fr_pair_t *vp, *prev;
871
872 parent = pair_data->parent;
873 if (!parent->vp) {
874 if (req_size > 0) {
875 croak("Unable to set attribute instance count");
876 }
877 XSRETURN(0);
878 }
879
880 count = fr_pair_count_by_da(&parent->vp->vp_group, pair_data->da);
881 if (req_size > count) {
882 croak("Increasing attribute instance count not supported");
883 XSRETURN(0);
884 }
885
886 /*
887 * As req_size is 1 based and the attribute instance count is
888 * 0 based, searching for instance `req_size` will give the first
889 * pair to delete.
890 */
891 vp = fr_pair_find_by_da_idx(&parent->vp->vp_group, pair_data->da, req_size);
892 while (vp) {
893 prev = fr_pair_list_prev(&parent->vp->vp_group, vp);
894 fr_pair_delete(&parent->vp->vp_group, vp);
895 vp = fr_pair_find_by_da(&parent->vp->vp_group, prev, pair_data->da);
896 }
897 XSRETURN(0);
898}
899
900/** Called when values are pushed on a tied array
901 *
902 * The stack contains
903 * - the tied SV
904 * - one or more values being pushed onto the array
905 */
906static XS(XS_pairs_PUSH)
907{
908 dXSARGS;
909 int i = 1;
910 fr_pair_t *vp;
912
914
915 fr_assert(fr_type_is_leaf(pair_data->da->type));
916
917 parent = pair_data->parent;
918 if (!parent->vp) {
919 if (fr_perl_pair_parent_build(parent) < 0) XSRETURN(0);
920 }
921
922 while (i < items) {
923 fr_pair_append_by_da(parent->vp, &vp, &parent->vp->vp_group, pair_data->da);
924 if (perl_value_unmarshal(vp, ST(i++)) < 0) break;
925 }
926
927 XSRETURN(0);
928}
929
930/** Called when values are popped off a tied array
931 *
932 * The stack contains just the tied SV
933 */
934static XS(XS_pairs_POP)
935{
936 dXSARGS;
937 fr_pair_t *vp;
939
941
942 fr_assert(fr_type_is_leaf(pair_data->da->type));
943
944 parent = pair_data->parent;
945 if (!parent->vp) XSRETURN(0);
946
947 vp = fr_pair_find_last_by_da(&parent->vp->vp_group, NULL, pair_data->da);
948 if (!vp) XSRETURN(0);
949
950 if (perl_value_marshal(vp, &ST(0)) < 0) XSRETURN(0);
951
952 fr_pair_remove(&parent->vp->vp_group, vp);
953 XSRETURN(1);
954}
955
956/** Called when values are "shifted" off a tied array
957 *
958 * The stack contains just the tied SV
959 */
960static XS(XS_pairs_SHIFT)
961{
962 dXSARGS;
963 fr_pair_t *vp;
965
967
968 fr_assert(fr_type_is_leaf(pair_data->da->type));
969
970 parent = pair_data->parent;
971 if (!parent->vp) XSRETURN(0);
972
973 vp = fr_pair_find_by_da(&parent->vp->vp_group, NULL, pair_data->da);
974 if (!vp) XSRETURN(0);
975
976 if (perl_value_marshal(vp, &ST(0)) < 0) XSRETURN(0);
977
978 fr_pair_remove(&parent->vp->vp_group, vp);
979 XSRETURN(1);
980}
981
982/** Called when values are "unshifted" onto a tied array
983 *
984 * The stack contains
985 * - the tied SV
986 * - one or more values being shifted onto the array
987 */
988static XS(XS_pairs_UNSHIFT)
989{
990 dXSARGS;
991 int i = 1;
992 fr_pair_t *vp;
994
996
997 fr_assert(fr_type_is_leaf(pair_data->da->type));
998
999 parent = pair_data->parent;
1000 if (!parent->vp) {
1001 if (fr_perl_pair_parent_build(parent) < 0) XSRETURN(0);
1002 }
1003
1004 while (i < items) {
1005 if (unlikely(fr_pair_prepend_by_da(parent->vp, &vp, &parent->vp->vp_group, pair_data->da) < 0)) {
1006 croak("Failed adding attribute %s", pair_data->da->name);
1007 break;
1008 }
1009 if (perl_value_unmarshal(vp, ST(i++)) < 0) break;
1010 }
1011
1012 XSRETURN(0);
1013}
1014
1015static void xs_init(pTHX)
1016{
1017 char const *file = __FILE__;
1018
1019 /* DynaLoader is a special case */
1020 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1021
1022 newXS("freeradius::log",XS_freeradius_log, "rlm_perl");
1023 newXS("freeradius::xlat",XS_freeradius_xlat, "rlm_perl");
1024
1025 /*
1026 * The freeradiuspairlist package implements functions required
1027 * for a tied hash handling structural attributes.
1028 */
1029 newXS("freeradiuspairlist::FETCH", XS_pairlist_FETCH, "rlm_perl");
1030 newXS("freeradiuspairlist::STORE", XS_pairlist_STORE, "rlm_perl");
1031 newXS("freeradiuspairlist::EXISTS", XS_pairlist_EXISTS, "rlm_perl");
1032 newXS("freeradiuspairlist::FIRSTKEY", XS_pairlist_FIRSTKEY, "rlm_perl");
1033 newXS("freeradiuspairlist::NEXTKEY", XS_pairlist_NEXTKEY, "rlm_perl");
1034 newXS("freeradiuspairlist::DELETE", XS_pairlist_DELETE, "rlm_perl");
1035
1036 /*
1037 * The freeradiuspairs package implements functions required
1038 * for a tied array handling leaf attributes.
1039 */
1040 newXS("freeradiuspairs::FETCH", XS_pairs_FETCH, "rlm_perl");
1041 newXS("freeradiuspairs::STORE", XS_pairs_STORE, "rlm_perl");
1042 newXS("freeradiuspairs::EXISTS", XS_pairs_EXISTS, "rlm_perl");
1043 newXS("freeradiuspairs::DELETE", XS_pairs_DELETE, "rlm_perl");
1044 newXS("freeradiuspairs::FETCHSIZE", XS_pairs_FETCHSIZE, "rlm_perl");
1045 newXS("freeradiuspairs::STORESIZE", XS_pairs_STORESIZE, "rlm_perl");
1046 newXS("freeradiuspairs::PUSH", XS_pairs_PUSH, "rlm_perl");
1047 newXS("freeradiuspairs::POP", XS_pairs_POP, "rlm_perl");
1048 newXS("freeradiuspairs::SHIFT", XS_pairs_SHIFT, "rlm_perl");
1049 newXS("freeradiuspairs::UNSHIFT", XS_pairs_UNSHIFT, "rlm_perl");
1050}
1051
1052/** Convert a list of value boxes to a Perl array for passing to subroutines
1053 *
1054 * The Perl array object should be created before calling this
1055 * to populate it.
1056 *
1057 * @param[in,out] av Perl array object to append values to.
1058 * @param[in] head of VB list.
1059 * @return
1060 * - 0 on success
1061 * - -1 on failure
1062 */
1063static int perl_vblist_to_av(AV *av, fr_value_box_list_t *head) {
1064 fr_value_box_t *vb = NULL;
1065 SV *sv;
1066
1067 while ((vb = fr_value_box_list_next(head, vb))) {
1068 switch (vb->type) {
1069 case FR_TYPE_STRING:
1070 sv = newSVpvn(vb->vb_strvalue, vb->vb_length);
1071 break;
1072
1073 case FR_TYPE_OCTETS:
1074 sv = newSVpvn((char const *)vb->vb_octets, vb->vb_length);
1075 break;
1076
1077 case FR_TYPE_GROUP:
1078 {
1079 AV *sub_av;
1080 sub_av = newAV();
1081 perl_vblist_to_av(sub_av, &vb->vb_group);
1082 sv = newRV_inc((SV *)sub_av);
1083 }
1084 break;
1085 default:
1086 {
1087 char buffer[1024];
1088 ssize_t slen;
1089
1090 slen = fr_value_box_print(&FR_SBUFF_OUT(buffer, sizeof(buffer)), vb, NULL);
1091 if (slen < 0) return -1;
1092 sv = newSVpvn(buffer, (size_t)slen);
1093 }
1094 break;
1095 }
1096 if (!sv) return -1;
1097 if (vb->tainted) SvTAINT(sv);
1098 av_push(av, sv);
1099 }
1100 return 0;
1101}
1102
1103/** Parse a Perl SV and create value boxes, appending to a list
1104 *
1105 * For parsing values passed back from a Perl subroutine
1106 *
1107 * When hashes are returned, first the key is added as a value box then the value
1108 *
1109 * @param[in] ctx to allocate boxes in.
1110 * @param[out] list to append value boxes to.
1111 * @param[in] request being handled - only used for debug messages
1112 * @param[in] sv to parse
1113 * @return
1114 * - 0 on success
1115 * - -1 on failure
1116 */
1117static int perl_sv_to_vblist(TALLOC_CTX *ctx, fr_value_box_list_t *list, request_t *request, SV *sv) {
1118 fr_value_box_t *vb = NULL;
1119 char *tmp;
1120 STRLEN len;
1121 AV *av;
1122 HV *hv;
1123 I32 sv_len, i;
1124 int type;
1125
1126 type = SvTYPE(sv);
1127
1128 switch (type) {
1129 case SVt_IV:
1130 /* Integer or Reference */
1131 if (SvROK(sv)) {
1132 RDEBUG3("Reference returned");
1133 if (perl_sv_to_vblist(ctx, list, request, SvRV(sv)) < 0) return -1;
1134 break;
1135 }
1136 RDEBUG3("Integer returned");
1137 MEM(vb = fr_value_box_alloc(ctx, FR_TYPE_INT32, NULL));
1138 vb->vb_int32 = SvIV(sv);
1139 break;
1140
1141 case SVt_NV:
1142 /* Float */
1143 RDEBUG3("Float returned");
1144 MEM(vb = fr_value_box_alloc(ctx, FR_TYPE_FLOAT64, NULL));
1145 vb->vb_float64 = SvNV(sv);
1146 break;
1147
1148 case SVt_PV:
1149 /* String */
1150 RDEBUG3("String returned");
1151 tmp = SvPVutf8(sv, len);
1152 MEM(vb = fr_value_box_alloc_null(ctx));
1153 if (fr_value_box_bstrndup(vb, vb, NULL, tmp, len, SvTAINTED(sv)) < 0) {
1154 talloc_free(vb);
1155 RPEDEBUG("Failed to allocate %ld for output", len);
1156 return -1;
1157 }
1158 break;
1159
1160 case SVt_PVAV:
1161 /* Array */
1162 {
1163 SV **av_sv;
1164 RDEBUG3("Array returned");
1165 av = (AV*)sv;
1166 sv_len = av_len(av);
1167 for (i = 0; i <= sv_len; i++) {
1168 av_sv = av_fetch(av, i, 0);
1169 if (SvOK(*av_sv)) {
1170 if (perl_sv_to_vblist(ctx, list, request, *av_sv) < 0) return -1;
1171 }
1172 }
1173 }
1174 break;
1175
1176 case SVt_PVHV:
1177 /* Hash */
1178 {
1179 SV *hv_sv;
1180 RDEBUG3("Hash returned");
1181 hv = (HV*)sv;
1182 for (i = hv_iterinit(hv); i > 0; i--) {
1183 hv_sv = hv_iternextsv(hv, &tmp, &sv_len);
1184 /*
1185 * Add key first
1186 */
1187 MEM(vb = fr_value_box_alloc_null(ctx));
1188 if (fr_value_box_bstrndup(vb, vb, NULL, tmp, sv_len, SvTAINTED(hv_sv)) < 0) {
1189 talloc_free(vb);
1190 RPEDEBUG("Failed to allocate %d for output", sv_len);
1191 return -1;
1192 }
1193 fr_value_box_list_insert_tail(list, vb);
1194
1195 /*
1196 * Now process value
1197 */
1198 if (perl_sv_to_vblist(ctx, list, request, hv_sv) < 0) return -1;
1199
1200 }
1201 /*
1202 * Box has already been added to list - return
1203 */
1204 return 0;
1205 }
1206
1207 case SVt_NULL:
1208 break;
1209
1210 default:
1211 RPEDEBUG("Perl returned unsupported data type %d", type);
1212 return -1;
1213
1214 }
1215
1216 if (vb) {
1217 vb->tainted = SvTAINTED(sv);
1218 fr_value_box_list_insert_tail(list, vb);
1219 }
1220
1221 return 0;
1222}
1223
1225 { .required = true, .single = true, .type = FR_TYPE_STRING },
1226 { .variadic = XLAT_ARG_VARIADIC_EMPTY_KEEP, .type = FR_TYPE_VOID },
1228};
1229
1230/** Call perl code using an xlat
1231 *
1232 * @ingroup xlat_functions
1233 */
1234static xlat_action_t perl_xlat(TALLOC_CTX *ctx, fr_dcursor_t *out,
1235 xlat_ctx_t const *xctx,
1236 request_t *request, fr_value_box_list_t *in)
1237{
1239 int count, i;
1241 STRLEN n_a;
1242 fr_value_box_t *func = fr_value_box_list_pop_head(in);
1243 fr_value_box_t *child;
1244 SV *sv;
1245 AV *av;
1246 fr_value_box_list_t list, sub_list;
1247 fr_value_box_t *vb = NULL;
1248
1249 fr_value_box_list_init(&list);
1250 fr_value_box_list_init(&sub_list);
1251
1252 {
1253 dTHXa(t->perl);
1254 PERL_SET_CONTEXT(t->perl);
1255 }
1256
1257 {
1258 ssize_t slen;
1259 fr_sbuff_t *sbuff;
1260
1261 dSP;
1262 ENTER;SAVETMPS;
1263
1264 PUSHMARK(SP);
1265
1266 FR_SBUFF_TALLOC_THREAD_LOCAL(&sbuff, 256, 16384);
1267
1269
1270 fr_assert(arg->type == FR_TYPE_GROUP);
1271 if (fr_value_box_list_empty(&arg->vb_group)) continue;
1272
1273 if (fr_value_box_list_num_elements(&arg->vb_group) == 1) {
1274 child = fr_value_box_list_head(&arg->vb_group);
1275
1276 switch (child->type) {
1277 case FR_TYPE_STRING:
1278 if (child->vb_length == 0) continue;
1279
1280 RDEBUG3("Passing single value %pV", child);
1281 sv = newSVpvn(child->vb_strvalue, child->vb_length);
1282 break;
1283
1284 case FR_TYPE_GROUP:
1285 RDEBUG3("Ignoring nested group");
1286 continue;
1287
1288 default:
1289 /*
1290 * @todo - turn over integers as strings.
1291 */
1292 slen = fr_value_box_print(sbuff, child, NULL);
1293 if (slen <= 0) {
1294 RPEDEBUG("Failed printing sbuff");
1295 continue;
1296 }
1297
1298 RDEBUG3("Passing single value %pV", child);
1299 sv = newSVpvn(fr_sbuff_start(sbuff), fr_sbuff_used(sbuff));
1300 fr_sbuff_set_to_start(sbuff);
1301 break;
1302 }
1303
1304 if (child->tainted) SvTAINT(sv);
1305 XPUSHs(sv_2mortal(sv));
1306 continue;
1307 }
1308
1309 /*
1310 * Multiple child values - create array and pass reference
1311 */
1312 av = newAV();
1313 perl_vblist_to_av(av, &arg->vb_group);
1314 RDEBUG3("Passing list as array %pM", &arg->vb_group);
1315 sv = newRV_inc((SV *)av);
1316 XPUSHs(sv_2mortal(sv));
1317 }
1318
1319 PUTBACK;
1320
1321 count = call_pv(func->vb_strvalue, G_ARRAY | G_EVAL);
1322
1323 SPAGAIN;
1324 if (SvTRUE(ERRSV)) {
1325 REDEBUG("Exit %s", SvPV(ERRSV,n_a));
1326 (void)POPs;
1327 goto cleanup;
1328 }
1329
1330 /*
1331 * As results are popped from a stack, they are in reverse
1332 * sequence. Add to a temporary list and then prepend to
1333 * main list.
1334 */
1335 for (i = 0; i < count; i++) {
1336 sv = POPs;
1337 if (perl_sv_to_vblist(ctx, &sub_list, request, sv) < 0) goto cleanup;
1338 fr_value_box_list_move_head(&list, &sub_list);
1339 }
1340 ret = XLAT_ACTION_DONE;
1341
1342 /*
1343 * Move the assembled list of boxes to the output
1344 */
1345 while ((vb = fr_value_box_list_pop_head(&list))) fr_dcursor_append(out, vb);
1346
1347 cleanup:
1348 PUTBACK;
1349 FREETMPS;
1350 LEAVE;
1351
1352 }
1353
1354 return ret;
1355}
1356
1357/*
1358 * Parse a configuration section, and populate a HV.
1359 * This function is recursively called (allows to have nested hashes.)
1360 */
1361static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
1362{
1363 int indent_section = (lvl + 1) * 4;
1364 int indent_item = (lvl + 2) * 4;
1365
1366 if (!cs || !rad_hv) return;
1367
1368 DEBUG("%*s%s {", indent_section, " ", cf_section_name1(cs));
1369
1370 for (CONF_ITEM *ci = NULL; (ci = cf_item_next(cs, ci)); ) {
1371 /*
1372 * This is a section.
1373 * Create a new HV, store it as a reference in current HV,
1374 * Then recursively call perl_parse_config with this section and the new HV.
1375 */
1376 if (cf_item_is_section(ci)) {
1377 CONF_SECTION *sub_cs = cf_item_to_section(ci);
1378 char const *key = cf_section_name1(sub_cs); /* hash key */
1379 HV *sub_hv;
1380 SV *ref;
1381
1382 if (!key) continue;
1383
1384 if (hv_exists(rad_hv, key, strlen(key))) {
1385 WARN("Ignoring duplicate config section '%s'", key);
1386 continue;
1387 }
1388
1389 sub_hv = newHV();
1390 ref = newRV_inc((SV*) sub_hv);
1391
1392 (void)hv_store(rad_hv, key, strlen(key), ref, 0);
1393
1394 perl_parse_config(sub_cs, lvl + 1, sub_hv);
1395 } else if (cf_item_is_pair(ci)){
1396 CONF_PAIR *cp = cf_item_to_pair(ci);
1397 char const *key = cf_pair_attr(cp); /* hash key */
1398 char const *value = cf_pair_value(cp); /* hash value */
1399
1400 if (!key || !value) continue;
1401
1402 /*
1403 * This is an item.
1404 * Store item attr / value in current HV.
1405 */
1406 if (hv_exists(rad_hv, key, strlen(key))) {
1407 WARN("Ignoring duplicate config item '%s'", key);
1408 continue;
1409 }
1410
1411 (void)hv_store(rad_hv, key, strlen(key), newSVpvn(value, strlen(value)), 0);
1412
1413 DEBUG("%*s%s = %s", indent_item, " ", key, value);
1414 }
1415 }
1416
1417 DEBUG("%*s}", indent_section, " ");
1418}
1419
1420/** Create a Perl tied hash representing a pair list
1421 *
1422 */
1423static void perl_pair_list_tie(HV *parent, HV *frpair_stash, char const *name, fr_pair_t *vp, fr_dict_attr_t const *da)
1424{
1425 HV *list_hv;
1426 SV *list_tie;
1427 fr_perl_pair_t pair_data;
1428
1429 list_hv = newHV();
1430 list_tie = newRV_noinc((SV *)newHV());
1431 sv_bless(list_tie, frpair_stash);
1432 hv_magic(list_hv, (GV *)list_tie, PERL_MAGIC_tied);
1433 SvREFCNT_dec(list_tie);
1434
1435 pair_data = (fr_perl_pair_t) {
1436 .vp = vp,
1437 .da = da
1438 };
1439
1440 sv_magicext((SV *)list_tie, 0, PERL_MAGIC_ext, &rlm_perl_vtbl, (char *)&pair_data, sizeof(pair_data));
1441
1442 (void)hv_store(parent, name, strlen(name), newRV_inc((SV *)list_hv), 0);
1443}
1444
1445/*
1446 * Call the function_name inside the module
1447 * Store all vps in hashes %RAD_CONFIG %RAD_REPLY %RAD_REQUEST
1448 *
1449 */
1450static unlang_action_t CC_HINT(nonnull) mod_perl(unlang_result_t *p_result, module_ctx_t const *mctx, request_t *request)
1451{
1452 rlm_perl_t *inst = talloc_get_type_abort(mctx->mi->data, rlm_perl_t);
1453 perl_call_env_t *func = talloc_get_type_abort(mctx->env_data, perl_call_env_t);
1454 PerlInterpreter *interp = ((rlm_perl_thread_t *)talloc_get_type_abort(mctx->thread, rlm_perl_thread_t))->perl;
1455 int ret=0, count;
1456 STRLEN n_a;
1457
1458 HV *frpair_stash;
1459 HV *fr_packet;
1460
1461 /*
1462 * call_env parsing will have established the function name to call.
1463 */
1465
1466 {
1467 dTHXa(interp);
1468 PERL_SET_CONTEXT(interp);
1469 }
1470
1471 {
1472 dSP;
1473
1474 ENTER;
1475 SAVETMPS;
1476
1477 /* Get the stash for the freeradiuspairlist package */
1478 frpair_stash = gv_stashpv("freeradiuspairlist", GV_ADD);
1479
1480 /* New hash to hold the pair list roots and pass to the Perl subroutine */
1481 fr_packet = newHV();
1482
1483 perl_pair_list_tie(fr_packet, frpair_stash, "request",
1484 fr_pair_list_parent(&request->request_pairs), fr_dict_root(request->proto_dict));
1485 perl_pair_list_tie(fr_packet, frpair_stash, "reply",
1486 fr_pair_list_parent(&request->reply_pairs), fr_dict_root(request->proto_dict));
1487 perl_pair_list_tie(fr_packet, frpair_stash, "control",
1488 fr_pair_list_parent(&request->control_pairs), fr_dict_root(request->proto_dict));
1489 perl_pair_list_tie(fr_packet, frpair_stash, "session-state",
1490 fr_pair_list_parent(&request->session_state_pairs), fr_dict_root(request->proto_dict));
1491
1492 /*
1493 * Store pointer to request structure globally so radiusd::xlat works
1494 */
1495 rlm_perl_request = request;
1496
1497 PUSHMARK(SP);
1498 XPUSHs( sv_2mortal(newRV((SV *)fr_packet)) );
1499 PUTBACK;
1500
1501 count = call_pv(func->func->function_name, G_SCALAR | G_EVAL );
1502
1503 rlm_perl_request = NULL;
1504
1505 SPAGAIN;
1506
1507 if (SvTRUE(ERRSV)) {
1508 REDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n",
1509 inst->module, func->func->function_name, SvPV(ERRSV,n_a));
1510 (void)POPs;
1511 ret = RLM_MODULE_FAIL;
1512 } else if (count == 1) {
1513 ret = POPi;
1514 if (ret >= 100 || ret < 0) {
1515 ret = RLM_MODULE_FAIL;
1516 }
1517 }
1518
1519 PUTBACK;
1520 FREETMPS;
1521 LEAVE;
1522 }
1523
1525}
1526
1528DIAG_OFF(shadow)
1529static void rlm_perl_interp_free(PerlInterpreter *perl)
1530{
1531 void **handles;
1532
1533 {
1534 dTHXa(perl);
1535 PERL_SET_CONTEXT(perl);
1536 }
1537
1538 handles = rlm_perl_get_handles(aTHX);
1539 if (handles) rlm_perl_close_handles(handles);
1540
1541 PL_perl_destruct_level = 2;
1542
1543 PL_origenviron = environ;
1544
1545 /*
1546 * FIXME: This shouldn't happen
1547 *
1548 */
1549 while (PL_scopestack_ix > 1) LEAVE;
1550
1551 perl_destruct(perl);
1552 perl_free(perl);
1553}
1554DIAG_ON(shadow)
1556
1558{
1559 rlm_perl_t *inst = talloc_get_type_abort(mctx->mi->data, rlm_perl_t);
1560 rlm_perl_thread_t *t = talloc_get_type_abort(mctx->thread, rlm_perl_thread_t);
1561 PerlInterpreter *interp;
1562 UV clone_flags = 0;
1563
1564 PERL_SET_CONTEXT(inst->perl);
1565
1566 /*
1567 * Ensure only one thread is cloning an interpreter at a time
1568 * Whilst the documentation of perl_clone() does not say anything
1569 * about this, seg faults have been seen if multiple threads clone
1570 * the same inst->perl at the same time.
1571 */
1572 pthread_mutex_lock(&inst->mutable->mutex);
1573 interp = perl_clone(inst->perl, clone_flags);
1574 pthread_mutex_unlock(&inst->mutable->mutex);
1575 {
1576 dTHXa(interp); /* Sets the current thread's interpreter */
1577 }
1578# if PERL_REVISION >= 5 && PERL_VERSION <8
1579 call_pv("CLONE", 0);
1580# endif
1581 ptr_table_free(PL_ptr_table);
1582 PL_ptr_table = NULL;
1583
1584 PERL_SET_CONTEXT(aTHX);
1586
1587 t->perl = interp; /* Store perl interp for easy freeing later */
1588
1589 return 0;
1590}
1591
1593{
1594 rlm_perl_thread_t *t = talloc_get_type_abort(mctx->thread, rlm_perl_thread_t);
1595
1597
1598 return 0;
1599}
1600
1601/** Check if a given Perl subroutine exists
1602 *
1603 */
1604static bool perl_func_exists(char const *func)
1605{
1606 char *eval_str;
1607 SV *val;
1608
1609 /*
1610 * Perl's "can" method checks if the object contains a subroutine of the given name.
1611 * We expect referenced subroutines to be in the "main" namespace.
1612 */
1613 eval_str = talloc_asprintf(NULL, "(main->can('%s') ? 1 : 0)", func);
1614 val = eval_pv(eval_str, TRUE);
1615 talloc_free(eval_str);
1616 return SvIV(val) ? true : false;
1617}
1618
1619/*
1620 * Do any per-module initialization that is separate to each
1621 * configured instance of the module. e.g. set up connections
1622 * to external databases, read configuration files, set up
1623 * dictionary entries, etc.
1624 *
1625 * If configuration information is given in the config section
1626 * that must be referenced in later calls, store a handle to it
1627 * in *instance otherwise put a null pointer there.
1628 *
1629 * Setup a hashes which we will use later
1630 * parse a module and give it a chance to live
1631 *
1632 */
1633static int mod_instantiate(module_inst_ctx_t const *mctx)
1634{
1635 rlm_perl_t *inst = talloc_get_type_abort(mctx->mi->data, rlm_perl_t);
1636 perl_func_def_t *func = NULL;
1638 CONF_PAIR *cp;
1639 char *pair_name;
1640
1641 CONF_SECTION *conf = mctx->mi->conf;
1642 AV *end_AV;
1643
1644 char const **embed_c; /* Stupid Perl and lack of const consistency */
1645 char **embed;
1646 int ret = 0, argc = 0;
1647 char arg[] = "0";
1648
1649 CONF_SECTION *cs;
1650
1651 /*
1652 * Setup the argument array we pass to the perl interpreter
1653 */
1654 MEM(embed_c = talloc_zero_array(inst, char const *, 4));
1655 memcpy(&embed, &embed_c, sizeof(embed));
1656 embed_c[0] = NULL;
1657 if (inst->perl_flags) {
1658 embed_c[1] = inst->perl_flags;
1659 embed_c[2] = inst->module;
1660 embed_c[3] = arg;
1661 argc = 4;
1662 } else {
1663 embed_c[1] = inst->module;
1664 embed_c[2] = arg;
1665 argc = 3;
1666 }
1667
1668 /*
1669 * Allocate a new perl interpreter to do the parsing
1670 */
1671 if ((inst->perl = perl_alloc()) == NULL) {
1672 ERROR("No memory for allocating new perl interpreter!");
1673 return -1;
1674 }
1675 perl_construct(inst->perl); /* ...and initialise it */
1676
1677 PL_perl_destruct_level = 2;
1678 {
1679 dTHXa(inst->perl);
1680 }
1681 PERL_SET_CONTEXT(inst->perl);
1682
1683#if PERL_REVISION >= 5 && PERL_VERSION >=8
1684 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
1685#endif
1686
1687 ret = perl_parse(inst->perl, xs_init, argc, embed, NULL);
1688
1689 end_AV = PL_endav;
1690 PL_endav = (AV *)NULL;
1691
1692 if (ret) {
1693 ERROR("Perl_parse failed: %s not found or has syntax errors", inst->module);
1694 return -1;
1695 }
1696
1697 /* parse perl configuration sub-section */
1698 cs = cf_section_find(conf, "config", NULL);
1699 if (cs) {
1700 inst->rad_perlconf_hv = get_hv("RAD_PERLCONF", 1);
1701 perl_parse_config(cs, 0, inst->rad_perlconf_hv);
1702 }
1703
1704 inst->perl_parsed = true;
1705 perl_run(inst->perl);
1706
1707 /*
1708 * The call_env parser has found all the places the module is called
1709 * Check for config options which set the subroutine name, falling back to
1710 * automatic subroutine names based on section name.
1711 */
1712 if (!inst->funcs_init) fr_rb_inline_init(&inst->funcs, perl_func_def_t, node, perl_func_def_cmp, NULL);
1713 func = fr_rb_iter_init_inorder(&iter, &inst->funcs);
1714 while (func) {
1715 /*
1716 * Check for func_<name1>_<name2> or func_<name1> config pairs.
1717 */
1718 if (func->name2) {
1719 pair_name = talloc_asprintf(func, "func_%s_%s", func->name1, func->name2);
1720 cp = cf_pair_find(mctx->mi->conf, pair_name);
1721 talloc_free(pair_name);
1722 if (cp) goto found_func;
1723 }
1724 pair_name = talloc_asprintf(func, "func_%s", func->name1);
1725 cp = cf_pair_find(conf, pair_name);
1726 talloc_free(pair_name);
1727 found_func:
1728 if (cp){
1729 func->function_name = cf_pair_value(cp);
1730 if (!perl_func_exists(func->function_name)) {
1731 cf_log_err(cp, "Perl subroutine %s does not exist", func->function_name);
1732 return -1;
1733 }
1734 /*
1735 * If no pair was found, then use <name1>_<name2> or <name1> as the function to call.
1736 */
1737 } else if (func->name2) {
1738 func->function_name = talloc_asprintf(func, "%s_%s", func->name1, func->name2);
1739 if (!perl_func_exists(func->function_name)) {
1741 goto name1_only;
1742 }
1743 } else {
1744 name1_only:
1745 func->function_name = func->name1;
1746 if (!perl_func_exists(func->function_name)) {
1747 cf_log_err(cp, "Perl subroutine %s does not exist", func->function_name);
1748 return -1;
1749 }
1750 }
1751
1752 func = fr_rb_iter_next_inorder(&iter);
1753 }
1754
1755 PL_endav = end_AV;
1756
1757 inst->mutable = talloc(NULL, rlm_perl_mutable_t);
1758 pthread_mutex_init(&inst->mutable->mutex, NULL);
1759
1760 return 0;
1761}
1762
1763/*
1764 * Detach a instance give a chance to a module to make some internal setup ...
1765 */
1766DIAG_OFF(nested-externs)
1767static int mod_detach(module_detach_ctx_t const *mctx)
1768{
1769 rlm_perl_t *inst = talloc_get_type_abort(mctx->mi->data, rlm_perl_t);
1770 int ret = 0, count = 0;
1771
1772
1773 if (inst->perl_parsed) {
1774 dTHXa(inst->perl);
1775 PERL_SET_CONTEXT(inst->perl);
1776 if (inst->rad_perlconf_hv != NULL) hv_undef(inst->rad_perlconf_hv);
1777
1778 if (inst->func_detach) {
1779 dSP; ENTER; SAVETMPS;
1780 PUSHMARK(SP);
1781
1782 count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
1783 SPAGAIN;
1784
1785 if (count == 1) {
1786 ret = POPi;
1787 if (ret >= 100 || ret < 0) {
1788 ret = RLM_MODULE_FAIL;
1789 }
1790 }
1791 PUTBACK;
1792 FREETMPS;
1793 LEAVE;
1794 }
1795 }
1796
1798 talloc_free(inst->mutable);
1799
1800 return ret;
1801}
1802DIAG_ON(nested-externs)
1803
1804static int mod_bootstrap(module_inst_ctx_t const *mctx)
1805{
1806 xlat_t *xlat;
1807
1808 xlat = module_rlm_xlat_register(mctx->mi->boot, mctx, NULL, perl_xlat, FR_TYPE_VOID);
1810
1811 return 0;
1812}
1813
1814static int mod_load(void)
1815{
1816 char const **embed_c; /* Stupid Perl and lack of const consistency */
1817 char **embed;
1818 char **envp = NULL;
1819 int argc = 0;
1820
1821#define LOAD_INFO(_fmt, ...) fr_log(LOG_DST, L_INFO, __FILE__, __LINE__, "rlm_perl - " _fmt, ## __VA_ARGS__)
1822#define LOAD_WARN(_fmt, ...) fr_log_perror(LOG_DST, L_WARN, __FILE__, __LINE__, \
1823 &(fr_log_perror_format_t){ \
1824 .first_prefix = "rlm_perl - ", \
1825 .subsq_prefix = "rlm_perl - ", \
1826 }, \
1827 _fmt, ## __VA_ARGS__)
1828
1829 LOAD_INFO("Perl version: %s", PERL_API_VERSION_STRING);
1830 dependency_version_number_add(NULL, "perl", PERL_API_VERSION_STRING);
1831
1832 /*
1833 * Load perl using RTLD_GLOBAL and dlopen.
1834 * This fixes issues where Perl C extensions
1835 * can't find the symbols they need.
1836 */
1837 perl_dlhandle = dl_open_by_sym("perl_construct", RTLD_NOW | RTLD_GLOBAL);
1838 if (!perl_dlhandle) LOAD_WARN("Failed loading libperl symbols into global symbol table");
1839
1840 /*
1841 * Setup the argument array we pass to the perl interpreter
1842 */
1843 MEM(embed_c = talloc_zero_array(NULL, char const *, 1));
1844 memcpy(&embed, &embed_c, sizeof(embed));
1845 embed_c[0] = NULL;
1846 argc = 1;
1847
1848 PERL_SYS_INIT3(&argc, &embed, &envp);
1849
1850 talloc_free(embed_c);
1851
1852 return 0;
1853}
1854
1855static void mod_unload(void)
1856{
1857 if (perl_dlhandle) dlclose(perl_dlhandle);
1858 PERL_SYS_TERM();
1859}
1860
1861/*
1862 * Restrict automatic Perl function names to lowercase characters, numbers and underscore
1863 * meaning that a module call in `recv Access-Request` will look for `recv_access_request`
1864 */
1865static void perl_func_name_safe(char *name) {
1866 char *p;
1867 size_t i;
1868
1869 p = name;
1870 for (i = 0; i < talloc_array_length(name); i++) {
1871 *p = tolower(*p);
1872 if (!strchr("abcdefghijklmnopqrstuvwxyz1234567890", *p)) *p = '_';
1873 p++;
1874 }
1875}
1876
1877static int perl_func_parse(TALLOC_CTX *ctx, call_env_parsed_head_t *out, UNUSED tmpl_rules_t const *t_rules,
1878 UNUSED CONF_ITEM *ci, call_env_ctx_t const *cec, UNUSED call_env_parser_t const *rule)
1879{
1880 rlm_perl_t *inst = talloc_get_type_abort(cec->mi->data, rlm_perl_t);
1881 call_env_parsed_t *parsed;
1882 perl_func_def_t *func;
1883 void *found;
1884
1885 if (!inst->funcs_init) {
1887 inst->funcs_init = true;
1888 }
1889
1890 MEM(parsed = call_env_parsed_add(ctx, out,
1892 .name = "func",
1893 .flags = CALL_ENV_FLAG_PARSE_ONLY,
1894 .pair = {
1895 .parsed = {
1896 .offset = rule->pair.offset,
1898 }
1899 }
1900 }));
1901
1902 MEM(func = talloc_zero(inst, perl_func_def_t));
1903 func->name1 = talloc_strdup(func, cec->asked->name1);
1905 if (cec->asked->name2) {
1906 func->name2 = talloc_strdup(func, cec->asked->name2);
1908 }
1909 if (fr_rb_find_or_insert(&found, &inst->funcs, func) < 0) {
1910 talloc_free(func);
1911 return -1;
1912 }
1913
1914 /*
1915 * If the function call is already in the tree, use that entry.
1916 */
1917 if (found) {
1918 talloc_free(func);
1919 call_env_parsed_set_data(parsed, found);
1920 } else {
1921 call_env_parsed_set_data(parsed, func);
1922 }
1923 return 0;
1924}
1925
1933
1934/*
1935 * The module name should be the only globally exported symbol.
1936 * That is, everything else should be 'static'.
1937 *
1938 * If the module needs to temporarily modify it's instantiation
1939 * data, the type should be changed to MODULE_TYPE_THREAD_UNSAFE.
1940 * The server will then take care of ensuring that the module
1941 * is single-threaded.
1942 */
1943extern module_rlm_t rlm_perl;
1945 .common = {
1946 .magic = MODULE_MAGIC_INIT,
1947 .name = "perl",
1948 .inst_size = sizeof(rlm_perl_t),
1949
1951 .onload = mod_load,
1952 .unload = mod_unload,
1953 .bootstrap = mod_bootstrap,
1955 .detach = mod_detach,
1956
1957 .thread_inst_size = sizeof(rlm_perl_thread_t),
1958 .thread_instantiate = mod_thread_instantiate,
1959 .thread_detach = mod_thread_detach,
1960 },
1961 .method_group = {
1962 .bindings = (module_method_binding_t[]){
1963 { .section = SECTION_NAME(CF_IDENT_ANY, CF_IDENT_ANY), .method = mod_perl, .method_env = &perl_method_env },
1965 }
1966 }
1967};
unlang_action_t
Returned by unlang_op_t calls, determine the next action of the interpreter.
Definition action.h:35
static int const char char buffer[256]
Definition acutest.h:576
int const char * file
Definition acutest.h:702
log_entry msg
Definition acutest.h:794
#define RCSID(id)
Definition build.h:485
#define DIAG_UNKNOWN_PRAGMAS
Definition build.h:458
#define DIAG_ON(_x)
Definition build.h:460
#define CMP(_a, _b)
Same as CMP_PREFER_SMALLER use when you don't really care about ordering, you just want an ordering.
Definition build.h:112
#define unlikely(_x)
Definition build.h:383
#define UNUSED
Definition build.h:317
#define DIAG_OFF(_x)
Definition build.h:459
call_env_parsed_t * call_env_parsed_add(TALLOC_CTX *ctx, call_env_parsed_head_t *head, call_env_parser_t const *rule)
Allocate a new call_env_parsed_t structure and add it to the list of parsed call envs.
Definition call_env.c:667
void call_env_parsed_set_data(call_env_parsed_t *parsed, void const *data)
Assign data to a call_env_parsed_t.
Definition call_env.c:724
#define CALL_ENV_TERMINATOR
Definition call_env.h:236
#define FR_CALL_ENV_METHOD_OUT(_inst)
Helper macro for populating the size/type fields of a call_env_method_t from the output structure typ...
Definition call_env.h:240
call_env_parser_t const * env
Parsing rules for call method env.
Definition call_env.h:247
section_name_t const * asked
The actual name1/name2 that resolved to a module_method_binding_t.
Definition call_env.h:232
@ CALL_ENV_FLAG_PARSE_ONLY
The result of parsing will not be evaluated at runtime.
Definition call_env.h:85
@ CALL_ENV_FLAG_PARSE_MISSING
If this subsection is missing, still parse it.
Definition call_env.h:88
@ CALL_ENV_PARSE_TYPE_VOID
Output of the parsing phase is undefined (a custom structure).
Definition call_env.h:62
module_instance_t const * mi
Module instance that the callenv is registered to.
Definition call_env.h:229
#define FR_CALL_ENV_SUBSECTION_FUNC(_name, _name2, _flags, _func)
Specify a call_env_parser_t which parses a subsection using a callback function.
Definition call_env.h:412
Per method call config.
Definition call_env.h:180
#define CONF_PARSER_TERMINATOR
Definition cf_parse.h:658
void * data
Pointer to a static variable to write the parsed value to.
Definition cf_parse.h:609
#define FR_CONF_OFFSET(_name, _struct, _field)
conf_parser_t which parses a single CONF_PAIR, writing the result to a field in a struct
Definition cf_parse.h:284
#define FR_CONF_OFFSET_FLAGS(_name, _flags, _struct, _field)
conf_parser_t which parses a single CONF_PAIR, writing the result to a field in a struct
Definition cf_parse.h:272
@ CONF_FLAG_REQUIRED
Error out if no matching CONF_PAIR is found, and no dflt value is set.
Definition cf_parse.h:434
@ CONF_FLAG_FILE_INPUT
File matching value must exist, and must be readable.
Definition cf_parse.h:440
Defines a CONF_PAIR to C data type mapping.
Definition cf_parse.h:595
Common header for all CONF_* types.
Definition cf_priv.h:49
Configuration AVP similar to a fr_pair_t.
Definition cf_priv.h:70
A section grouping multiple CONF_PAIR.
Definition cf_priv.h:101
bool cf_item_is_pair(CONF_ITEM const *ci)
Determine if CONF_ITEM is a CONF_PAIR.
Definition cf_util.c:631
char const * cf_section_name1(CONF_SECTION const *cs)
Return the second identifier of a CONF_SECTION.
Definition cf_util.c:1170
CONF_SECTION * cf_section_find(CONF_SECTION const *cs, char const *name1, char const *name2)
Find a CONF_SECTION with name1 and optionally name2.
Definition cf_util.c:1027
CONF_SECTION * cf_item_to_section(CONF_ITEM const *ci)
Cast a CONF_ITEM to a CONF_SECTION.
Definition cf_util.c:683
CONF_PAIR * cf_pair_find(CONF_SECTION const *cs, char const *attr)
Search for a CONF_PAIR with a specific name.
Definition cf_util.c:1438
bool cf_item_is_section(CONF_ITEM const *ci)
Determine if CONF_ITEM is a CONF_SECTION.
Definition cf_util.c:617
CONF_PAIR * cf_item_to_pair(CONF_ITEM const *ci)
Cast a CONF_ITEM to a CONF_PAIR.
Definition cf_util.c:663
char const * cf_pair_value(CONF_PAIR const *pair)
Return the value of a CONF_PAIR.
Definition cf_util.c:1593
char const * cf_pair_attr(CONF_PAIR const *pair)
Return the attr of a CONF_PAIR.
Definition cf_util.c:1577
#define cf_log_err(_cf, _fmt,...)
Definition cf_util.h:289
#define cf_item_next(_parent, _curr)
Definition cf_util.h:92
#define CF_IDENT_ANY
Definition cf_util.h:78
static int split(char **input, char **output, bool syntax_string)
Definition command.c:393
static void * fr_dcursor_next(fr_dcursor_t *cursor)
Advanced the cursor to the next item.
Definition dcursor.h:290
static int fr_dcursor_append(fr_dcursor_t *cursor, void *v)
Insert a single item at the end of the list.
Definition dcursor.h:408
#define MEM(x)
Definition debug.h:36
int dependency_version_number_add(CONF_SECTION *cs, char const *name, char const *version)
Add a library/server version pair to the main configuration.
Definition dependency.c:152
#define ERROR(fmt,...)
Definition dhcpclient.c:41
#define DEBUG(fmt,...)
Definition dhcpclient.c:39
fr_dict_attr_t const * fr_dict_attr_by_name(fr_dict_attr_err_t *err, fr_dict_attr_t const *parent, char const *attr))
Locate a fr_dict_attr_t by its name.
Definition dict_util.c:3266
fr_dict_attr_t const * fr_dict_root(fr_dict_t const *dict)
Return the root attribute of a dictionary.
Definition dict_util.c:2403
fr_dict_t const * fr_dict_internal(void)
Definition dict_util.c:4654
static fr_slen_t in
Definition dict.h:841
Test enumeration values.
Definition dict_test.h:92
void * dl_open_by_sym(char const *sym_name, int flags)
Utility function to dlopen the library containing a particular symbol.
Definition dl.c:186
#define RTLD_NOW
Definition dl.c:44
#define MODULE_MAGIC_INIT
Stop people using different module/library/server versions together.
Definition dl_module.h:63
static xlat_action_t perl_xlat(TALLOC_CTX *ctx, fr_dcursor_t *out, xlat_ctx_t const *xctx, request_t *request, fr_value_box_list_t *in)
Call perl code using an xlat.
Definition rlm_perl.c:1234
#define RDEBUG3(fmt,...)
Definition log.h:343
#define RPEDEBUG(fmt,...)
Definition log.h:376
talloc_free(reap)
fr_log_t default_log
Definition log.c:292
void fr_log(fr_log_t const *log, fr_log_type_t type, char const *file, int line, char const *fmt,...)
Send a server log message to its destination.
Definition log.c:581
#define ENTER(_x)
Definition machine.h:93
@ FR_TYPE_TIME_DELTA
A period of time measured in nanoseconds.
@ FR_TYPE_FLOAT32
Single precision floating point.
@ FR_TYPE_IPV4_ADDR
32 Bit IPv4 Address.
@ FR_TYPE_ETHERNET
48 Bit Mac-Address.
@ FR_TYPE_IPV6_PREFIX
IPv6 Prefix.
@ FR_TYPE_STRING
String of printable characters.
@ FR_TYPE_DATE
Unix time stamp, always has value >2^31.
@ FR_TYPE_COMBO_IP_PREFIX
IPv4 or IPv6 address prefix depending on length.
@ FR_TYPE_INT32
32 Bit signed integer.
@ FR_TYPE_IPV6_ADDR
128 Bit IPv6 Address.
@ FR_TYPE_IPV4_PREFIX
IPv4 Prefix.
@ FR_TYPE_VOID
User data.
@ FR_TYPE_BOOL
A truth value.
@ FR_TYPE_COMBO_IP_ADDR
IPv4 or IPv6 address depending on length.
@ FR_TYPE_IFID
Interface ID.
@ FR_TYPE_OCTETS
Raw octets.
@ FR_TYPE_GROUP
A grouping of other attributes.
@ FR_TYPE_FLOAT64
Double precision floating point.
long int ssize_t
unsigned char uint8_t
void * env_data
Per call environment data.
Definition module_ctx.h:44
module_instance_t const * mi
Instance of the module being instantiated.
Definition module_ctx.h:42
void * thread
Thread specific instance data.
Definition module_ctx.h:43
void * thread
Thread instance data.
Definition module_ctx.h:67
module_instance_t * mi
Instance of the module being instantiated.
Definition module_ctx.h:51
Temporary structure to hold arguments for module calls.
Definition module_ctx.h:41
Temporary structure to hold arguments for detach calls.
Definition module_ctx.h:56
Temporary structure to hold arguments for instantiation calls.
Definition module_ctx.h:50
Temporary structure to hold arguments for thread_instantiation calls.
Definition module_ctx.h:63
xlat_t * module_rlm_xlat_register(TALLOC_CTX *ctx, module_inst_ctx_t const *mctx, char const *name, xlat_func_t func, fr_type_t return_type)
Definition module_rlm.c:243
module_t common
Common fields presented by all modules.
Definition module_rlm.h:39
fr_pair_t * fr_pair_list_parent(fr_pair_list_t const *list)
Return a pointer to the parent pair which contains this list.
Definition pair.c:960
unsigned int fr_pair_count_by_da(fr_pair_list_t const *list, fr_dict_attr_t const *da)
Return the number of instances of a given da in the specified list.
Definition pair.c:674
int fr_pair_append_by_da(TALLOC_CTX *ctx, fr_pair_t **out, fr_pair_list_t *list, fr_dict_attr_t const *da)
Alloc a new fr_pair_t (and append)
Definition pair.c:1463
int fr_pair_value_memdup(fr_pair_t *vp, uint8_t const *src, size_t len, bool tainted)
Copy data into an "octets" data type.
Definition pair.c:2936
int fr_pair_value_from_str(fr_pair_t *vp, char const *value, size_t inlen, fr_sbuff_unescape_rules_t const *uerules, UNUSED bool tainted)
Convert string value to native attribute value.
Definition pair.c:2590
fr_pair_t * fr_pair_find_by_da(fr_pair_list_t const *list, fr_pair_t const *prev, fr_dict_attr_t const *da)
Find the first pair with a matching da.
Definition pair.c:697
fr_pair_t * fr_pair_find_by_da_idx(fr_pair_list_t const *list, fr_dict_attr_t const *da, unsigned int idx)
Find a pair with a matching da at a given index.
Definition pair.c:745
int fr_pair_value_bstrndup(fr_pair_t *vp, char const *src, size_t len, bool tainted)
Copy data into a "string" type value pair.
Definition pair.c:2786
void fr_pair_value_clear(fr_pair_t *vp)
Free/zero out value (or children) of a given VP.
Definition pair.c:2534
int fr_pair_delete(fr_pair_list_t *list, fr_pair_t *vp)
Remove fr_pair_t from a list and free.
Definition pair.c:1823
int fr_pair_prepend_by_da(TALLOC_CTX *ctx, fr_pair_t **out, fr_pair_list_t *list, fr_dict_attr_t const *da)
Alloc a new fr_pair_t (and prepend)
Definition pair.c:1490
fr_pair_t * fr_pair_find_last_by_da(fr_pair_list_t const *list, fr_pair_t const *prev, fr_dict_attr_t const *da)
Find the last pair with a matching da.
Definition pair.c:721
static const conf_parser_t config[]
Definition base.c:186
#define fr_assert(_expr)
Definition rad_assert.h:38
#define REDEBUG(fmt,...)
Definition radclient.h:52
#define WARN(fmt,...)
Definition radclient.h:47
static bool cleanup
Definition radsniff.c:60
static rs_t * conf
Definition radsniff.c:53
void * fr_rb_iter_init_inorder(fr_rb_iter_inorder_t *iter, fr_rb_tree_t *tree)
Initialise an in-order iterator.
Definition rb.c:824
int fr_rb_find_or_insert(void **found, fr_rb_tree_t *tree, void const *data)
Attempt to find current data in the tree, if it does not exist insert it.
Definition rb.c:598
void * fr_rb_iter_next_inorder(fr_rb_iter_inorder_t *iter)
Return the next node.
Definition rb.c:850
#define fr_rb_inline_init(_tree, _type, _field, _data_cmp, _data_free)
Initialises a red black tree.
Definition rb.h:180
Iterator structure for in-order traversal of an rbtree.
Definition rb.h:321
The main red black tree structure.
Definition rb.h:73
#define RETURN_UNLANG_RCODE(_rcode)
Definition rcode.h:66
@ RLM_MODULE_FAIL
Module failed, don't reply.
Definition rcode.h:42
static int perl_sv_to_vblist(TALLOC_CTX *ctx, fr_value_box_list_t *list, request_t *request, SV *sv)
Parse a Perl SV and create value boxes, appending to a list.
Definition rlm_perl.c:1117
static fr_dict_attr_t const * perl_attr_lookup(fr_perl_pair_t *pair_data, char const *attr)
Helper function for turning hash keys into dictionary attributes.
Definition rlm_perl.c:274
fr_rb_node_t node
Node in tree of function calls.
Definition rlm_perl.c:61
static int mod_detach(module_detach_ctx_t const *mctx)
Definition rlm_perl.c:1767
static int mod_load(void)
Definition rlm_perl.c:1814
PerlInterpreter * perl
Thread specific perl interpreter.
Definition rlm_perl.c:95
static bool perl_func_exists(char const *func)
Check if a given Perl subroutine exists.
Definition rlm_perl.c:1604
HV * rad_perlconf_hv
holds "config" items (perl RAD_PERLCONF hash).
Definition rlm_perl.c:89
#define PERLSETINT(_size)
static XS(XS_freeradius_log)
Definition rlm_perl.c:218
static void perl_func_name_safe(char *name)
Definition rlm_perl.c:1865
static xlat_arg_parser_t const perl_xlat_args[]
Definition rlm_perl.c:1224
char const * func_detach
Function to run when mod_detach is run.
Definition rlm_perl.c:85
char const * function_name
Name of the function being called.
Definition rlm_perl.c:58
#define PERLINT(_size)
#define PERLUINT(_size)
static void ** rlm_perl_get_handles(pTHX)
Definition rlm_perl.c:163
bool perl_parsed
Definition rlm_perl.c:88
fr_perl_pair_t * parent
Parent attribute data.
Definition rlm_perl.c:106
static int perl_value_marshal(fr_pair_t *vp, SV **value)
Functions to implement subroutines required for a tied array.
Definition rlm_perl.c:552
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv)
static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
Definition rlm_perl.c:1361
#define PERLSETUINT(_size)
char const * perl_flags
Definition rlm_perl.c:86
static int mod_bootstrap(module_inst_ctx_t const *mctx)
Definition rlm_perl.c:1804
char * name1
Section name1 where this is called.
Definition rlm_perl.c:59
#define dl_modules
Definition rlm_perl.c:154
module_rlm_t rlm_perl
Definition rlm_perl.c:1944
static void rlm_perl_interp_free(PerlInterpreter *perl)
Definition rlm_perl.c:1529
static int perl_value_unmarshal(fr_pair_t *vp, SV *value)
Convert a Perl SV to a pair value.
Definition rlm_perl.c:694
char const *fr_rb_tree_t funcs
Tree of function calls found by call_env parser.
Definition rlm_perl.c:83
static MGVTBL rlm_perl_vtbl
Definition rlm_perl.c:113
static void mod_unload(void)
Definition rlm_perl.c:1855
static void xs_init(pTHX)
Definition rlm_perl.c:1015
fr_dict_attr_t const * da
Dictionary attribute associated with hash / array.
Definition rlm_perl.c:103
struct fr_perl_pair_s fr_perl_pair_t
Definition rlm_perl.c:101
static int8_t perl_func_def_cmp(void const *one, void const *two)
How to compare two Perl function calls.
Definition rlm_perl.c:133
#define LOAD_WARN(_fmt,...)
static void rlm_perl_close_handles(void **handles)
Definition rlm_perl.c:197
static int mod_thread_instantiate(module_thread_inst_ctx_t const *mctx)
Definition rlm_perl.c:1557
fr_dcursor_t cursor
Cursor used for iterating over the keys of a tied hash.
Definition rlm_perl.c:107
static void perl_pair_list_tie(HV *parent, HV *frpair_stash, char const *name, fr_pair_t *vp, fr_dict_attr_t const *da)
Create a Perl tied hash representing a pair list.
Definition rlm_perl.c:1423
#define GET_PAIR_MAGIC(count)
Convenience macro for fetching C data associated with tied hash / array and validating stack size.
Definition rlm_perl.c:293
unsigned int idx
Instance number.
Definition rlm_perl.c:105
PerlInterpreter * perl
Definition rlm_perl.c:87
static unlang_action_t mod_perl(unlang_result_t *p_result, module_ctx_t const *mctx, request_t *request)
Definition rlm_perl.c:1450
char * name2
Section name2 where this is called.
Definition rlm_perl.c:60
#define dl_librefs
Definition rlm_perl.c:153
static int perl_vblist_to_av(AV *av, fr_value_box_list_t *head)
Convert a list of value boxes to a Perl array for passing to subroutines.
Definition rlm_perl.c:1063
static void * perl_dlhandle
To allow us to load perl's symbols into the global symbol table.
Definition rlm_perl.c:115
#define LOAD_INFO(_fmt,...)
static const conf_parser_t module_config[]
Definition rlm_perl.c:120
static _Thread_local request_t * rlm_perl_request
Definition rlm_perl.c:151
static const call_env_method_t perl_method_env
Definition rlm_perl.c:1926
bool funcs_init
Has the tree been initialised.
Definition rlm_perl.c:84
pthread_mutex_t mutex
Definition rlm_perl.c:69
static int mod_thread_detach(module_thread_inst_ctx_t const *mctx)
Definition rlm_perl.c:1592
static int mod_instantiate(module_inst_ctx_t const *mctx)
Definition rlm_perl.c:1633
fr_pair_t * vp
Real pair associated with the hash / array, if it exists.
Definition rlm_perl.c:104
perl_func_def_t * func
Definition rlm_perl.c:65
static void rlm_perl_clear_handles(pTHX)
Definition rlm_perl.c:155
static int fr_perl_pair_parent_build(fr_perl_pair_t *pair_data)
Build parent structural pairs needed when a leaf node is set.
Definition rlm_perl.c:658
static int perl_func_parse(TALLOC_CTX *ctx, call_env_parsed_head_t *out, UNUSED tmpl_rules_t const *t_rules, UNUSED CONF_ITEM *ci, call_env_ctx_t const *cec, UNUSED call_env_parser_t const *rule)
Definition rlm_perl.c:1877
static char const * name
static int instantiate(module_inst_ctx_t const *mctx)
Definition rlm_rest.c:1297
#define fr_sbuff_start(_sbuff_or_marker)
#define FR_SBUFF_OUT(_start, _len_or_end)
#define fr_sbuff_used(_sbuff_or_marker)
#define FR_SBUFF_TALLOC_THREAD_LOCAL(_out, _init, _max)
#define SECTION_NAME(_name1, _name2)
Define a section name consisting of a verb and a noun.
Definition section.h:40
char const * name2
Second section name. Usually a packet type like 'access-request', 'access-accept',...
Definition section.h:46
char const * name1
First section name. Usually a verb like 'recv', 'send', etc...
Definition section.h:45
CONF_SECTION * conf
Module's instance configuration.
Definition module.h:349
size_t inst_size
Size of the module's instance data.
Definition module.h:212
void * data
Module's instance data.
Definition module.h:291
#define MODULE_BINDING_TERMINATOR
Terminate a module binding list.
Definition module.h:152
Named methods exported by a module.
Definition module.h:174
Optional arguments passed to vp_tmpl functions.
Definition tmpl.h:332
static char buff[sizeof("18446744073709551615")+3]
Definition size_tests.c:41
return count
Definition module.c:155
eap_aka_sim_process_conf_t * inst
fr_aka_sim_id_type_t type
fr_pair_t * vp
Stores an attribute, a value and various bits of other data.
Definition pair.h:68
fr_dict_attr_t const *_CONST da
Dictionary attribute defines the attribute number, vendor and type of the pair.
Definition pair.h:69
#define talloc_get_type_abort_const
Definition talloc.h:287
static int talloc_const_free(void const *ptr)
Free const'd memory.
Definition talloc.h:229
@ T_INVALID
Definition token.h:39
@ T_BARE_WORD
Definition token.h:120
@ XLAT_ARG_VARIADIC_EMPTY_KEEP
Empty argument groups are left alone, and either passed through as empty groups or null boxes.
Definition xlat.h:137
static fr_slen_t head
Definition xlat.h:420
uint8_t required
Argument must be present, and non-empty.
Definition xlat.h:146
#define XLAT_ARG_PARSER_TERMINATOR
Definition xlat.h:170
xlat_action_t
Definition xlat.h:37
@ XLAT_ACTION_FAIL
An xlat function failed.
Definition xlat.h:44
@ XLAT_ACTION_DONE
We're done evaluating this level of nesting.
Definition xlat.h:43
ssize_t xlat_aeval(TALLOC_CTX *ctx, char **out, request_t *request, char const *fmt, xlat_escape_legacy_t escape, void const *escape_ctx))
Definition xlat_eval.c:1819
Definition for a single argument consumend by an xlat function.
Definition xlat.h:145
fr_pair_t * fr_pair_remove(fr_pair_list_t *list, fr_pair_t *vp)
Remove fr_pair_t from a list without freeing.
Definition pair_inline.c:93
ssize_t fr_pair_print_value_quoted(fr_sbuff_t *out, fr_pair_t const *vp, fr_token_t quote)
Print the value of an attribute to a string.
Definition pair_print.c:53
#define fr_pair_dcursor_init(_cursor, _list)
Initialises a special dcursor with callbacks that will maintain the attr sublists correctly.
Definition pair.h:587
fr_pair_t * fr_pair_list_prev(fr_pair_list_t const *list, fr_pair_t const *item))
Get the previous item in a valuepair list before a specific entry.
Definition pair_inline.c:82
static fr_slen_t parent
Definition pair.h:839
#define fr_type_is_group(_x)
Definition types.h:372
#define FR_TYPE_STRUCTURAL
Definition types.h:312
#define fr_type_is_leaf(_x)
Definition types.h:389
static char const * fr_type_to_str(fr_type_t type)
Return a static string containing the type name.
Definition types.h:450
#define FR_TYPE_LEAF
Definition types.h:313
ssize_t fr_value_box_print(fr_sbuff_t *out, fr_value_box_t const *data, fr_sbuff_escape_rules_t const *e_rules)
Print one boxed value to a string.
Definition value.c:5496
int fr_value_box_bstrndup(TALLOC_CTX *ctx, fr_value_box_t *dst, fr_dict_attr_t const *enumv, char const *src, size_t len, bool tainted)
Copy a string to to a fr_value_box_t.
Definition value.c:4379
#define fr_value_box_alloc(_ctx, _type, _enumv)
Allocate a value box of a specific type.
Definition value.h:640
int nonnull(2, 5))
#define fr_value_box_alloc_null(_ctx)
Allocate a value box for later use with a value assignment function.
Definition value.h:651
#define fr_value_box_list_foreach(_list_head, _iter)
Definition value.h:222
static size_t char ** out
Definition value.h:1020
module_ctx_t const * mctx
Synthesised module calling ctx.
Definition xlat_ctx.h:52
An xlat calling ctx.
Definition xlat_ctx.h:49
int xlat_func_args_set(xlat_t *x, xlat_arg_parser_t const args[])
Register the arguments of an xlat.
Definition xlat_func.c:363