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