src/modules/rlm_perl/rlm_perl.c

   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$
  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  */
  25 RCSID("$Id$")
  26
  27 #include <freeradius-devel/radiusd.h>
  28 #include <freeradius-devel/modules.h>
  29 #include <freeradius-devel/rad_assert.h>
  30
  31 #ifdef INADDR_ANY
  32 #  undef INADDR_ANY
  33 #endif
  34 #include <EXTERN.h>
  35 #include <perl.h>
  36 #include <XSUB.h>
  37 #include <dlfcn.h>
  38 #include <semaphore.h>
  39
  40 #ifdef __APPLE__
  41 extern char **environ;
  42 #endif
  43
  44 /*
  45  *      Define a structure for our module configuration.
  46  *
  47  *      These variables do not need to be in a structure, but it's
  48  *      a lot cleaner to do so, and a pointer to the structure can
  49  *      be used as the instance handle.
  50  */
  51 typedef struct rlm_perl_t {
  52         /* Name of the perl module */
  53         char const      *module;
  54
  55         /* Name of the functions for each module method */
  56         char const      *func_authorize;
  57         char const      *func_authenticate;
  58         char const      *func_accounting;
  59         char const      *func_start_accounting;
  60         char const      *func_stop_accounting;
  61         char const      *func_preacct;
  62         char const      *func_checksimul;
  63         char const      *func_detach;
  64         char const      *func_xlat;
  65 #ifdef WITH_PROXY
  66         char const      *func_pre_proxy;
  67         char const      *func_post_proxy;
  68 #endif
  69         char const      *func_post_auth;
  70 #ifdef WITH_COA
  71         char const      *func_recv_coa;
  72         char const      *func_send_coa;
  73 #endif
  74         char const      *xlat_name;
  75         char const      *perl_flags;
  76         PerlInterpreter *perl;
  77         bool            perl_parsed;
  78         pthread_key_t   *thread_key;
  79
  80 #ifdef USE_ITHREADS
  81         pthread_mutex_t clone_mutex;
  82 #endif
  83
  84         HV              *rad_perlconf_hv;       //!< holds "config" items (perl %RAD_PERLCONF hash).
  85
  86 } rlm_perl_t;
  87 /*
  88  *      A mapping of configuration file names to internal variables.
  89  */
  90 #define RLM_PERL_CONF(_x) { "func_" STRINGIFY(_x), PW_TYPE_STRING, \
  91                         offsetof(rlm_perl_t,func_##_x), NULL, STRINGIFY(_x)}
  92
  93 static const CONF_PARSER module_config[] = {
  94         { "module", FR_CONF_OFFSET(PW_TYPE_FILE_INPUT | PW_TYPE_DEPRECATED, rlm_perl_t, module), NULL },
  95         { "filename", FR_CONF_OFFSET(PW_TYPE_FILE_INPUT | PW_TYPE_REQUIRED, rlm_perl_t, module), NULL },
  96
  97         RLM_PERL_CONF(authorize),
  98         RLM_PERL_CONF(authenticate),
  99         RLM_PERL_CONF(post_auth),
 100         RLM_PERL_CONF(accounting),
 101         RLM_PERL_CONF(preacct),
 102         RLM_PERL_CONF(checksimul),
 103         RLM_PERL_CONF(detach),
 104         RLM_PERL_CONF(xlat),
 105
 106 #ifdef WITH_PROXY
 107         RLM_PERL_CONF(pre_proxy),
 108         RLM_PERL_CONF(post_proxy),
 109 #endif
 110 #ifdef WITH_COA
 111         RLM_PERL_CONF(recv_coa),
 112         RLM_PERL_CONF(send_coa),
 113 #endif
 114         { "perl_flags", FR_CONF_OFFSET(PW_TYPE_STRING, rlm_perl_t, perl_flags), NULL },
 115
 116         { "func_start_accounting", FR_CONF_OFFSET(PW_TYPE_STRING, rlm_perl_t, func_start_accounting), NULL },
 117
 118         { "func_stop_accounting", FR_CONF_OFFSET(PW_TYPE_STRING, rlm_perl_t, func_stop_accounting), NULL },
 119
 120         { NULL, -1, 0, NULL, NULL }             /* end the list */
 121 };
 122
 123 /*
 124  * man perlembed
 125  */
 126 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
 127
 128 #ifdef USE_ITHREADS
 129 #  define dl_librefs "DynaLoader::dl_librefs"
 130 #  define dl_modules "DynaLoader::dl_modules"
 131 static void rlm_perl_clear_handles(pTHX)
 132 {
 133         AV *librefs = get_av(dl_librefs, false);
 134         if (librefs) {
 135                 av_clear(librefs);
 136         }
 137 }
 138
 139 static void **rlm_perl_get_handles(pTHX)
 140 {
 141         I32 i;
 142         AV *librefs = get_av(dl_librefs, false);
 143         AV *modules = get_av(dl_modules, false);
 144         void **handles;
 145
 146         if (!librefs) return NULL;
 147
 148         if (!(AvFILL(librefs) >= 0)) {
 149                 return NULL;
 150         }
 151
 152         handles = (void **)rad_malloc(sizeof(void *) * (AvFILL(librefs)+2));
 153
 154         for (i = 0; i <= AvFILL(librefs); i++) {
 155                 void *handle;
 156                 SV *handle_sv = *av_fetch(librefs, i, false);
 157                 if (!handle_sv) {
 158                         ERROR("Could not fetch $%s[%d]!", dl_librefs, (int)i);
 159                         continue;
 160                 }
 161                 handle = (void *)SvIV(handle_sv);
 162
 163                 if (handle) handles[i] = handle;
 164         }
 165
 166         av_clear(modules);
 167         av_clear(librefs);
 168
 169         handles[i] = (void *)0;
 170
 171         return handles;
 172 }
 173
 174 static void rlm_perl_close_handles(void **handles)
 175 {
 176         int i;
 177
 178         if (!handles) {
 179                 return;
 180         }
 181
 182         for (i = 0; handles[i]; i++) {
 183                 DEBUG("Close %p", handles[i]);
 184                 dlclose(handles[i]);
 185         }
 186
 187         free(handles);
 188 }
 189
 190 DIAG_OFF(shadow)
 191 static void rlm_perl_destruct(PerlInterpreter *perl)
 192 {
 193         dTHXa(perl);
 194
 195         PERL_SET_CONTEXT(perl);
 196
 197         PL_perl_destruct_level = 2;
 198
 199         PL_origenviron = environ;
 200
 201
 202         {
 203                 dTHXa(perl);
 204         }
 205         /*
 206          * FIXME: This shouldn't happen
 207          *
 208          */
 209         while (PL_scopestack_ix > 1) {
 210                 LEAVE;
 211         }
 212
 213         perl_destruct(perl);
 214         perl_free(perl);
 215 }
 216 DIAG_ON(shadow)
 217
 218 static void rlm_destroy_perl(PerlInterpreter *perl)
 219 {
 220         void    **handles;
 221
 222         dTHXa(perl);
 223         PERL_SET_CONTEXT(perl);
 224
 225         handles = rlm_perl_get_handles(aTHX);
 226         if (handles) rlm_perl_close_handles(handles);
 227         rlm_perl_destruct(perl);
 228 }
 229
 230 /* Create Key */
 231 static void rlm_perl_make_key(pthread_key_t *key)
 232 {
 233         pthread_key_create(key, (void (*)(void *))rlm_destroy_perl);
 234 }
 235
 236 static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
 237 {
 238         int ret;
 239
 240         PerlInterpreter *interp;
 241         UV clone_flags = 0;
 242
 243         PERL_SET_CONTEXT(perl);
 244
 245         interp = pthread_getspecific(*key);
 246         if (interp) return interp;
 247
 248         interp = perl_clone(perl, clone_flags);
 249         {
 250                 dTHXa(interp);
 251         }
 252 #  if PERL_REVISION >= 5 && PERL_VERSION <8
 253         call_pv("CLONE",0);
 254 #  endif
 255         ptr_table_free(PL_ptr_table);
 256         PL_ptr_table = NULL;
 257
 258         PERL_SET_CONTEXT(aTHX);
 259         rlm_perl_clear_handles(aTHX);
 260
 261         ret = pthread_setspecific(*key, interp);
 262         if (ret != 0) {
 263                 DEBUG("rlm_perl: Failed associating interpretor with thread %s", fr_syserror(ret));
 264
 265                 rlm_perl_destruct(interp);
 266                 return NULL;
 267         }
 268
 269         return interp;
 270 }
 271 #endif
 272
 273 /*
 274  *      This is wrapper for radlog
 275  *      Now users can call radiusd::radlog(level,msg) wich is the same
 276  *      calling radlog from C code.
 277  */
 278 static XS(XS_radiusd_radlog)
 279 {
 280         dXSARGS;
 281         if (items !=2)
 282                 croak("Usage: radiusd::radlog(level, message)");
 283         {
 284                 int     level;
 285                 char    *msg;
 286
 287                 level = (int) SvIV(ST(0));
 288                 msg   = (char *) SvPV(ST(1), PL_na);
 289
 290                 /*
 291                  *      Because 'msg' is a 'char *', we don't want '%s', etc.
 292                  *      in it to give us printf-style vulnerabilities.
 293                  */
 294                 radlog(level, "rlm_perl: %s", msg);
 295         }
 296         XSRETURN_NO;
 297 }
 298
 299 static void xs_init(pTHX)
 300 {
 301         char const *file = __FILE__;
 302
 303         /* DynaLoader is a special case */
 304         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 305
 306         newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl");
 307 }
 308
 309 /*
 310  *      The xlat function
 311  */
 312 static ssize_t perl_xlat(void *instance, REQUEST *request, char const *fmt, char *out, size_t freespace)
 313 {
 314
 315         rlm_perl_t      *inst = (rlm_perl_t *) instance;
 316         char            *tmp;
 317         char const      *p, *q;
 318         int             count;
 319         size_t          ret = 0;
 320         STRLEN          n_a;
 321
 322 #ifdef USE_ITHREADS
 323         PerlInterpreter *interp;
 324
 325         pthread_mutex_lock(&inst->clone_mutex);
 326         interp = rlm_perl_clone(inst->perl, inst->thread_key);
 327         {
 328                 dTHXa(interp);
 329                 PERL_SET_CONTEXT(interp);
 330         }
 331         pthread_mutex_unlock(&inst->clone_mutex);
 332 #else
 333         PERL_SET_CONTEXT(inst->perl);
 334 #endif
 335         {
 336                 dSP;
 337                 ENTER;SAVETMPS;
 338
 339                 PUSHMARK(SP);
 340
 341                 p = q = fmt;
 342                 while (*p == ' ') {
 343                         p++;
 344                         q++;
 345                 }
 346                 while (*q) {
 347                         if (*q == ' ') {
 348                                 XPUSHs(sv_2mortal(newSVpvn(p, q - p)));
 349                                 p = q + 1;
 350
 351                                 /*
 352                                  *      Don't use an empty string
 353                                  */
 354                                 while (*p == ' ') p++;
 355                                 q = p;
 356                         }
 357                         q++;
 358                 }
 359
 360                 /*
 361                  *      And the last bit.
 362                  */
 363                 if (*p) {
 364                         XPUSHs(sv_2mortal(newSVpvn(p, strlen(p))));
 365                 }
 366
 367                 PUTBACK;
 368
 369                 count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
 370
 371                 SPAGAIN;
 372                 if (SvTRUE(ERRSV)) {
 373                         REDEBUG("Exit %s", SvPV(ERRSV,n_a));
 374                         (void)POPs;
 375                 } else if (count > 0) {
 376                         tmp = POPp;
 377                         strlcpy(out, tmp, freespace);
 378                         ret = strlen(out);
 379
 380                         RDEBUG("Len is %zu , out is %s freespace is %zu", ret, out, freespace);
 381                 }
 382
 383                 PUTBACK ;
 384                 FREETMPS ;
 385                 LEAVE ;
 386
 387         }
 388
 389         return ret;
 390 }
 391
 392 /*
 393  *      Parse a configuration section, and populate a HV.
 394  *      This function is recursively called (allows to have nested hashes.)
 395  */
 396 static void perl_parse_config(CONF_SECTION *cs, int lvl, HV *rad_hv)
 397 {
 398         if (!cs || !rad_hv) return;
 399
 400         int indent_section = (lvl + 1) * 4;
 401         int indent_item = (lvl + 2) * 4;
 402
 403         DEBUG("%*s%s {", indent_section, " ", cf_section_name1(cs));
 404
 405         CONF_ITEM *ci = NULL;
 406
 407         while ((ci = cf_item_find_next(cs, ci))) {
 408                 /*
 409                  *  This is a section.
 410                  *  Create a new HV, store it as a reference in current HV,
 411                  *  Then recursively call perl_parse_config with this section and the new HV.
 412                  */
 413                 if (cf_item_is_section(ci)) {
 414                         CONF_SECTION    *sub_cs = cf_item_to_section(ci);
 415                         char const      *key = cf_section_name1(sub_cs); /* hash key */
 416                         HV              *sub_hv;
 417                         SV              *ref;
 418
 419                         if (!key) continue;
 420
 421                         if (hv_exists(rad_hv, key, strlen(key))) {
 422                                 WARN("rlm_perl: Ignoring duplicate config section '%s'", key);
 423                                 continue;
 424                         }
 425
 426                         sub_hv = newHV();
 427                         ref = newRV_inc((SV*) sub_hv);
 428
 429                         (void)hv_store(rad_hv, key, strlen(key), ref, 0);
 430
 431                         perl_parse_config(sub_cs, lvl + 1, sub_hv);
 432                 } else if (cf_item_is_pair(ci)){
 433                         CONF_PAIR       *cp = cf_item_to_pair(ci);
 434                         char const      *key = cf_pair_attr(cp);        /* hash key */
 435                         char const      *value = cf_pair_value(cp);     /* hash value */
 436
 437                         if (!key || !value) continue;
 438
 439                         /*
 440                          *  This is an item.
 441                          *  Store item attr / value in current HV.
 442                          */
 443                         if (hv_exists(rad_hv, key, strlen(key))) {
 444                                 WARN("rlm_perl: Ignoring duplicate config item '%s'", key);
 445                                 continue;
 446                         }
 447
 448                         (void)hv_store(rad_hv, key, strlen(key), newSVpvn(value, strlen(value)), 0);
 449
 450                         DEBUG("%*s%s = %s", indent_item, " ", key, value);
 451                 }
 452         }
 453
 454         DEBUG("%*s}", indent_section, " ");
 455 }
 456
 457 static int mod_bootstrap(CONF_SECTION *conf, void *instance)
 458 {
 459         rlm_perl_t      *inst = instance;
 460
 461         char const      *xlat_name;
 462
 463         xlat_name = cf_section_name2(conf);
 464         if (!xlat_name) xlat_name = cf_section_name1(conf);
 465
 466         xlat_register(xlat_name, perl_xlat, NULL, inst);
 467
 468         return 0;
 469 }
 470
 471 /*
 472  *      Do any per-module initialization that is separate to each
 473  *      configured instance of the module.  e.g. set up connections
 474  *      to external databases, read configuration files, set up
 475  *      dictionary entries, etc.
 476  *
 477  *      If configuration information is given in the config section
 478  *      that must be referenced in later calls, store a handle to it
 479  *      in *instance otherwise put a null pointer there.
 480  *
 481  *      Setup a hashes wich we will use later
 482  *      parse a module and give him a chance to live
 483  *
 484  */
 485 static int mod_instantiate(CONF_SECTION *conf, void *instance)
 486 {
 487         rlm_perl_t      *inst = instance;
 488         AV              *end_AV;
 489
 490         char const      **embed_c;      /* Stupid Perl and lack of const consistency */
 491         char            **embed;
 492         char            **envp = NULL;
 493         int             exitstatus = 0, argc=0;
 494         char            arg[] = "0";
 495
 496         CONF_SECTION    *cs;
 497
 498 #ifdef USE_ITHREADS
 499         /*
 500          *      Create pthread key. This key will be stored in instance
 501          */
 502         pthread_mutex_init(&inst->clone_mutex, NULL);
 503
 504         inst->thread_key = rad_malloc(sizeof(*inst->thread_key));
 505         memset(inst->thread_key,0,sizeof(*inst->thread_key));
 506
 507         rlm_perl_make_key(inst->thread_key);
 508 #endif
 509
 510         /*
 511          *      Setup the argument array we pass to the perl interpreter
 512          */
 513         MEM(embed_c = talloc_zero_array(inst, char const *, 4));
 514         memcpy(&embed, &embed_c, sizeof(embed));
 515         embed_c[0] = NULL;
 516         if (inst->perl_flags) {
 517                 embed_c[1] = inst->perl_flags;
 518                 embed_c[2] = inst->module;
 519                 embed_c[3] = arg;
 520                 argc = 4;
 521         } else {
 522                 embed_c[1] = inst->module;
 523                 embed_c[2] = arg;
 524                 argc = 3;
 525         }
 526
 527         /*
 528          *      Create tweak the server's environment to support
 529          *      perl. Docs say only call this once... Oops.
 530          */
 531         PERL_SYS_INIT3(&argc, &embed, &envp);
 532
 533         /*
 534          *      Allocate a new perl interpreter to do the parsing
 535          */
 536         if ((inst->perl = perl_alloc()) == NULL) {
 537                 ERROR("rlm_perl: No memory for allocating new perl !");
 538                 return -1;
 539         }
 540         perl_construct(inst->perl);     /* ...and initialise it */
 541
 542 #ifdef USE_ITHREADS
 543         PL_perl_destruct_level = 2;
 544
 545         {
 546                 dTHXa(inst->perl);
 547         }
 548         PERL_SET_CONTEXT(inst->perl);
 549 #endif
 550
 551 #if PERL_REVISION >= 5 && PERL_VERSION >=8
 552         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 553 #endif
 554
 555         exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL);
 556
 557         end_AV = PL_endav;
 558         PL_endav = (AV *)NULL;
 559
 560         if (exitstatus) {
 561                 ERROR("rlm_perl: perl_parse failed: %s not found or has syntax errors", inst->module);
 562                 return -1;
 563         }
 564
 565         /* parse perl configuration sub-section */
 566         cs = cf_section_sub_find(conf, "config");
 567         if (cs) {
 568                 inst->rad_perlconf_hv = get_hv("RAD_PERLCONF", 1);
 569                 perl_parse_config(cs, 0, inst->rad_perlconf_hv);
 570         }
 571
 572         inst->perl_parsed = true;
 573         perl_run(inst->perl);
 574
 575         PL_endav = end_AV;
 576
 577         return 0;
 578 }
 579
 580 static void perl_vp_to_svpvn_element(REQUEST *request, AV *av, VALUE_PAIR const *vp,
 581                                      int *i, const char *hash_name, const char *list_name)
 582 {
 583         size_t len;
 584
 585         char buffer[1024];
 586
 587         switch (vp->da->type) {
 588         case PW_TYPE_STRING:
 589                 RDEBUG("$%s{'%s'}[%i] = &%s:%s -> '%s'", hash_name, vp->da->name, *i,
 590                        list_name, vp->da->name, vp->vp_strvalue);
 591                 av_push(av, newSVpvn(vp->vp_strvalue, vp->vp_length));
 592                 break;
 593
 594         default:
 595                 len = vp_prints_value(buffer, sizeof(buffer), vp, 0);
 596                 RDEBUG("$%s{'%s'}[%i] = &%s:%s -> '%s'", hash_name, vp->da->name, *i,
 597                        list_name, vp->da->name, buffer);
 598                 av_push(av, newSVpvn(buffer, truncate_len(len, sizeof(buffer))));
 599                 break;
 600         }
 601         (*i)++;
 602 }
 603
 604 /*
 605  *      get the vps and put them in perl hash
 606  *      If one VP have multiple values it is added as array_ref
 607  *      Example for this is Cisco-AVPair that holds multiple values.
 608  *      Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'}
 609  */
 610 static void perl_store_vps(UNUSED TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, HV *rad_hv,
 611                            const char *hash_name, const char *list_name)
 612 {
 613         VALUE_PAIR *vp;
 614
 615         hv_undef(rad_hv);
 616
 617         vp_cursor_t cursor;
 618
 619         RINDENT();
 620         fr_pair_list_sort(vps, fr_pair_cmp_by_da_tag);
 621         for (vp = fr_cursor_init(&cursor, vps);
 622              vp;
 623              vp = fr_cursor_next(&cursor)) {
 624                 VALUE_PAIR *next;
 625
 626                 char const *name;
 627                 char namebuf[256];
 628                 char buffer[1024];
 629
 630                 size_t len;
 631
 632                 /*
 633                  *      Tagged attributes are added to the hash with name
 634                  *      <attribute>:<tag>, others just use the normal attribute
 635                  *      name as the key.
 636                  */
 637                 if (vp->da->flags.has_tag && (vp->tag != TAG_ANY)) {
 638                         snprintf(namebuf, sizeof(namebuf), "%s:%d", vp->da->name, vp->tag);
 639                         name = namebuf;
 640                 } else {
 641                         name = vp->da->name;
 642                 }
 643
 644                 /*
 645                  *      We've sorted by type, then tag, so attributes of the
 646                  *      same type/tag should follow on from each other.
 647                  */
 648                 if ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)) {
 649                         int i = 0;
 650                         AV *av;
 651
 652                         av = newAV();
 653
 654                         perl_vp_to_svpvn_element(request, av, vp, &i, hash_name, list_name);
 655                         do {
 656                                 perl_vp_to_svpvn_element(request, av, next, &i, hash_name, list_name);
 657                                 fr_cursor_next(&cursor);
 658                         } while ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next));
 659                         (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0);
 660
 661                         continue;
 662                 }
 663
 664                 /*
 665                  *      It's a normal single valued attribute
 666                  */
 667                 switch (vp->da->type) {
 668                 case PW_TYPE_STRING:
 669                         RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name, list_name,
 670                                vp->da->name, vp->vp_strvalue);
 671                         (void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->vp_length), 0);
 672                         break;
 673
 674                 default:
 675                         len = vp_prints_value(buffer, sizeof(buffer), vp, 0);
 676                         RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name,
 677                                list_name, vp->da->name, buffer);
 678                         (void)hv_store(rad_hv, name, strlen(name),
 679                                        newSVpvn(buffer, truncate_len(len, sizeof(buffer))), 0);
 680                         break;
 681                 }
 682         }
 683         REXDENT();
 684 }
 685
 686 /*
 687  *
 688  *     Verify that a Perl SV is a string and save it in FreeRadius
 689  *     Value Pair Format
 690  *
 691  */
 692 static int pairadd_sv(TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, char *key, SV *sv, FR_TOKEN op,
 693                       const char *hash_name, const char *list_name)
 694 {
 695         char            *val;
 696         VALUE_PAIR      *vp;
 697
 698         if (SvOK(sv)) {
 699                 STRLEN len;
 700                 val = SvPV(sv, len);
 701                 vp = fr_pair_make(ctx, vps, key, NULL, op);
 702                 if (!vp) {
 703                 fail:
 704                         REDEBUG("Failed to create pair %s:%s %s %s", list_name, key,
 705                                 fr_int2str(fr_tokens, op, "<INVALID>"), val);
 706                         return -1;
 707                 }
 708
 709                 switch (vp->da->type) {
 710                 case PW_TYPE_STRING:
 711                         fr_pair_value_bstrncpy(vp, val, len);
 712                         break;
 713
 714                 default:
 715                         if (fr_pair_value_from_str(vp, val, len) < 0) goto fail;
 716                 }
 717
 718                 RDEBUG("&%s:%s %s $%s{'%s'} -> '%s'", list_name, key, fr_int2str(fr_tokens, op, "<INVALID>"),
 719                        hash_name, key, val);
 720                 return 0;
 721         }
 722         return -1;
 723 }
 724
 725 /*
 726  *     Gets the content from hashes
 727  */
 728 static int get_hv_content(TALLOC_CTX *ctx, REQUEST *request, HV *my_hv, VALUE_PAIR **vps,
 729                           const char *hash_name, const char *list_name)
 730 {
 731         SV              *res_sv, **av_sv;
 732         AV              *av;
 733         char            *key;
 734         I32             key_len, len, i, j;
 735         int             ret = 0;
 736
 737         *vps = NULL;
 738         for (i = hv_iterinit(my_hv); i > 0; i--) {
 739                 res_sv = hv_iternextsv(my_hv,&key,&key_len);
 740                 if (SvROK(res_sv) && (SvTYPE(SvRV(res_sv)) == SVt_PVAV)) {
 741                         av = (AV*)SvRV(res_sv);
 742                         len = av_len(av);
 743                         for (j = 0; j <= len; j++) {
 744                                 av_sv = av_fetch(av, j, 0);
 745                                 ret = pairadd_sv(ctx, request, vps, key, *av_sv, T_OP_ADD, hash_name, list_name) + ret;
 746                         }
 747                 } else ret = pairadd_sv(ctx, request, vps, key, res_sv, T_OP_EQ, hash_name, list_name) + ret;
 748         }
 749
 750         return ret;
 751 }
 752
 753 /*
 754  *      Call the function_name inside the module
 755  *      Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST
 756  *
 757  */
 758 static int do_perl(void *instance, REQUEST *request, char const *function_name)
 759 {
 760
 761         rlm_perl_t      *inst = instance;
 762         VALUE_PAIR      *vp;
 763         int             exitstatus=0, count;
 764         STRLEN          n_a;
 765
 766         HV              *rad_reply_hv;
 767         HV              *rad_check_hv;
 768         HV              *rad_config_hv;
 769         HV              *rad_request_hv;
 770 #ifdef WITH_PROXY
 771         HV              *rad_request_proxy_hv;
 772         HV              *rad_request_proxy_reply_hv;
 773 #endif
 774
 775         /*
 776          *      Radius has told us to call this function, but none
 777          *      is defined.
 778          */
 779         if (!function_name) return RLM_MODULE_FAIL;
 780
 781 #ifdef USE_ITHREADS
 782         pthread_mutex_lock(&inst->clone_mutex);
 783
 784         PerlInterpreter *interp;
 785
 786         interp = rlm_perl_clone(inst->perl,inst->thread_key);
 787         {
 788                 dTHXa(interp);
 789                 PERL_SET_CONTEXT(interp);
 790         }
 791
 792         pthread_mutex_unlock(&inst->clone_mutex);
 793 #else
 794         PERL_SET_CONTEXT(inst->perl);
 795 #endif
 796
 797         {
 798                 dSP;
 799
 800                 ENTER;
 801                 SAVETMPS;
 802
 803                 rad_reply_hv = get_hv("RAD_REPLY", 1);
 804                 rad_check_hv = get_hv("RAD_CHECK", 1);
 805                 rad_config_hv = get_hv("RAD_CONFIG", 1);
 806                 rad_request_hv = get_hv("RAD_REQUEST", 1);
 807
 808                 perl_store_vps(request->packet, request, &request->packet->vps, rad_request_hv, "RAD_REQUEST", "request");
 809                 perl_store_vps(request->reply, request, &request->reply->vps, rad_reply_hv, "RAD_REPLY", "reply");
 810                 perl_store_vps(request, request, &request->config, rad_check_hv, "RAD_CHECK", "control");
 811                 perl_store_vps(request, request, &request->config, rad_config_hv, "RAD_CONFIG", "control");
 812
 813 #ifdef WITH_PROXY
 814                 rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1);
 815                 rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1);
 816
 817                 if (request->proxy != NULL) {
 818                         perl_store_vps(request->proxy, request, &request->proxy->vps, rad_request_proxy_hv,
 819                                        "RAD_REQUEST_PROXY", "proxy-request");
 820                 } else {
 821                         hv_undef(rad_request_proxy_hv);
 822                 }
 823
 824                 if (request->proxy_reply != NULL) {
 825                         perl_store_vps(request->proxy_reply, request, &request->proxy_reply->vps,
 826                                        rad_request_proxy_reply_hv, "RAD_REQUEST_PROXY_REPLY", "proxy-reply");
 827                 } else {
 828                         hv_undef(rad_request_proxy_reply_hv);
 829                 }
 830 #endif
 831
 832                 PUSHMARK(SP);
 833                 /*
 834                  * This way %RAD_xx can be pushed onto stack as sub parameters.
 835                  * XPUSHs( newRV_noinc((SV *)rad_request_hv) );
 836                  * XPUSHs( newRV_noinc((SV *)rad_reply_hv) );
 837                  * XPUSHs( newRV_noinc((SV *)rad_check_hv) );
 838                  * PUTBACK;
 839                  */
 840
 841                 count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS);
 842
 843                 SPAGAIN;
 844
 845                 if (SvTRUE(ERRSV)) {
 846                         RDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n",
 847                                inst->module, function_name, SvPV(ERRSV,n_a));
 848                         (void)POPs;
 849                 }
 850
 851                 if (count == 1) {
 852                         exitstatus = POPi;
 853                         if (exitstatus >= 100 || exitstatus < 0) {
 854                                 exitstatus = RLM_MODULE_FAIL;
 855                         }
 856                 }
 857
 858
 859                 PUTBACK;
 860                 FREETMPS;
 861                 LEAVE;
 862
 863                 vp = NULL;
 864                 if ((get_hv_content(request->packet, request, rad_request_hv, &vp, "RAD_REQUEST", "request")) == 0) {
 865                         fr_pair_list_free(&request->packet->vps);
 866                         request->packet->vps = vp;
 867                         vp = NULL;
 868
 869                         /*
 870                          *      Update cached copies
 871                          */
 872                         request->username = fr_pair_find_by_num(request->packet->vps, PW_USER_NAME, 0, TAG_ANY);
 873                         request->password = fr_pair_find_by_num(request->packet->vps, PW_USER_PASSWORD, 0, TAG_ANY);
 874                         if (!request->password)
 875                                 request->password = fr_pair_find_by_num(request->packet->vps, PW_CHAP_PASSWORD, 0, TAG_ANY);
 876                 }
 877
 878                 if ((get_hv_content(request->reply, request, rad_reply_hv, &vp, "RAD_REPLY", "reply")) == 0) {
 879                         fr_pair_list_free(&request->reply->vps);
 880                         request->reply->vps = vp;
 881                         vp = NULL;
 882                 }
 883
 884                 if ((get_hv_content(request, request, rad_check_hv, &vp, "RAD_CHECK", "control")) == 0) {
 885                         fr_pair_list_free(&request->config);
 886                         request->config = vp;
 887                         vp = NULL;
 888                 }
 889
 890 #ifdef WITH_PROXY
 891                 if (request->proxy &&
 892                     (get_hv_content(request->proxy, request, rad_request_proxy_hv, &vp,
 893                                     "RAD_REQUEST_PROXY", "proxy-request") == 0)) {
 894                         fr_pair_list_free(&request->proxy->vps);
 895                         request->proxy->vps = vp;
 896                         vp = NULL;
 897                 }
 898
 899                 if (request->proxy_reply &&
 900                     (get_hv_content(request->proxy_reply, request, rad_request_proxy_reply_hv, &vp,
 901                                     "RAD_REQUEST_PROXY_REPLY", "proxy-reply") == 0)) {
 902                         fr_pair_list_free(&request->proxy_reply->vps);
 903                         request->proxy_reply->vps = vp;
 904                         vp = NULL;
 905                 }
 906 #endif
 907
 908         }
 909         return exitstatus;
 910 }
 911
 912 #define RLM_PERL_FUNC(_x) static rlm_rcode_t CC_HINT(nonnull) mod_##_x(void *instance, REQUEST *request) \
 913         {                                                               \
 914                 return do_perl(instance, request,                       \
 915                                ((rlm_perl_t *)instance)->func_##_x); \
 916         }
 917
 918 RLM_PERL_FUNC(authorize)
 919 RLM_PERL_FUNC(authenticate)
 920 RLM_PERL_FUNC(post_auth)
 921
 922 RLM_PERL_FUNC(checksimul)
 923
 924 #ifdef WITH_PROXY
 925 RLM_PERL_FUNC(pre_proxy)
 926 RLM_PERL_FUNC(post_proxy)
 927 #endif
 928
 929 #ifdef WITH_COA
 930 RLM_PERL_FUNC(recv_coa)
 931 RLM_PERL_FUNC(send_coa)
 932 #endif
 933
 934 RLM_PERL_FUNC(preacct)
 935
 936 /*
 937  *      Write accounting information to this modules database.
 938  */
 939 static rlm_rcode_t CC_HINT(nonnull) mod_accounting(void *instance, REQUEST *request)
 940 {
 941         VALUE_PAIR      *pair;
 942         int             acctstatustype=0;
 943
 944         if ((pair = fr_pair_find_by_num(request->packet->vps, PW_ACCT_STATUS_TYPE, 0, TAG_ANY)) != NULL) {
 945                 acctstatustype = pair->vp_integer;
 946         } else {
 947                 RDEBUG("Invalid Accounting Packet");
 948                 return RLM_MODULE_INVALID;
 949         }
 950
 951         switch (acctstatustype) {
 952         case PW_STATUS_START:
 953                 if (((rlm_perl_t *)instance)->func_start_accounting) {
 954                         return do_perl(instance, request,
 955                                        ((rlm_perl_t *)instance)->func_start_accounting);
 956                 } else {
 957                         return do_perl(instance, request,
 958                                        ((rlm_perl_t *)instance)->func_accounting);
 959                 }
 960
 961         case PW_STATUS_STOP:
 962                 if (((rlm_perl_t *)instance)->func_stop_accounting) {
 963                         return do_perl(instance, request,
 964                                        ((rlm_perl_t *)instance)->func_stop_accounting);
 965                 } else {
 966                         return do_perl(instance, request,
 967                                        ((rlm_perl_t *)instance)->func_accounting);
 968                 }
 969
 970         default:
 971                 return do_perl(instance, request,
 972                                ((rlm_perl_t *)instance)->func_accounting);
 973         }
 974 }
 975
 976
 977 /*
 978  * Detach a instance give a chance to a module to make some internal setup ...
 979  */
 980 DIAG_OFF(nested-externs)
 981 static int mod_detach(void *instance)
 982 {
 983         rlm_perl_t      *inst = (rlm_perl_t *) instance;
 984         int             exitstatus = 0, count = 0;
 985
 986         if (inst->rad_perlconf_hv != NULL) hv_undef(inst->rad_perlconf_hv);
 987
 988         if (inst->perl_parsed && inst->func_detach) {
 989                 dTHXa(inst->perl);
 990                 PERL_SET_CONTEXT(inst->perl);
 991                 {
 992                         dSP; ENTER; SAVETMPS;
 993                         PUSHMARK(SP);
 994
 995                         count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
 996                         SPAGAIN;
 997
 998                         if (count == 1) {
 999                                 exitstatus = POPi;
1000                                 if (exitstatus >= 100 || exitstatus < 0) {
1001                                         exitstatus = RLM_MODULE_FAIL;
1002                                 }
1003                         }
1004                         PUTBACK;
1005                         FREETMPS;
1006                         LEAVE;
1007                 }
1008         }
1009
1010 #ifdef USE_ITHREADS
1011         rlm_perl_destruct(inst->perl);
1012         pthread_mutex_destroy(&inst->clone_mutex);
1013 #else
1014         perl_destruct(inst->perl);
1015         perl_free(inst->perl);
1016 #endif
1017
1018         PERL_SYS_TERM();
1019         return exitstatus;
1020 }
1021 DIAG_ON(nested-externs)
1022
1023 /*
1024  *      The module name should be the only globally exported symbol.
1025  *      That is, everything else should be 'static'.
1026  *
1027  *      If the module needs to temporarily modify it's instantiation
1028  *      data, the type should be changed to RLM_TYPE_THREAD_UNSAFE.
1029  *      The server will then take care of ensuring that the module
1030  *      is single-threaded.
1031  */
1032 extern module_t rlm_perl;
1033 module_t rlm_perl = {
1034         .magic          = RLM_MODULE_INIT,
1035         .name           = "perl",
1036 #ifdef USE_ITHREADS
1037         .type           = RLM_TYPE_THREAD_SAFE,
1038 #else
1039         .type           = RLM_TYPE_THREAD_UNSAFE,
1040 #endif
1041         .inst_size      = sizeof(rlm_perl_t),
1042         .config         = module_config,
1043         .bootstrap      = mod_bootstrap,
1044         .instantiate    = mod_instantiate,
1045         .detach         = mod_detach,
1046         .methods = {
1047                 [MOD_AUTHENTICATE]      = mod_authenticate,
1048                 [MOD_AUTHORIZE]         = mod_authorize,
1049                 [MOD_PREACCT]           = mod_preacct,
1050                 [MOD_ACCOUNTING]        = mod_accounting,
1051                 [MOD_SESSION]           = mod_checksimul,
1052 #ifdef WITH_PROXY
1053                 [MOD_PRE_PROXY]         = mod_pre_proxy,
1054                 [MOD_POST_PROXY]        = mod_post_proxy,
1055 #endif
1056                 [MOD_POST_AUTH]         = mod_post_auth,
1057 #ifdef WITH_COA
1058                 [MOD_RECV_COA]          = mod_recv_coa,
1059                 [MOD_SEND_COA]          = mod_send_coa
1060 #endif
1061         },
1062 };