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