← Back to branch summary

~ubuntu-branches/ubuntu/natty/freeradius/natty-updates

« back to all changes in this revision

Viewing changes to src/modules/rlm_perl/rlm_perl.c

  • Committer: Bazaar Package Importer
  • Author(s): Paul Hampson
  • Date: 2006-01-15 13:34:13 UTC
  • mto: (3.1.3 dapper) (4.1.3 sid) (1.1.14 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20060115133413-zo1dslttvdoalqym
Tags: upstream-1.1.0
Import upstream version 1.1.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/modules/rlm_perl/rlm_perl.c
1
1
/*
2
2
 * rlm_perl.c
3
3
 *
4
 
 * Version:    $Id: rlm_perl.c,v 1.13 2004/02/26 19:04:34 aland Exp $
 
4
 * Version:    $Id: rlm_perl.c,v 1.13.4.3 2006/01/10 11:46:24 nbk Exp $
5
5
 *
6
6
 *   This program is free software; you can redistribute it and/or modify
7
7
 *   it under the terms of the GNU General Public License as published by
40
40
#undef INADDR_ANY
41
41
#endif
42
42
 
43
 
#ifdef INADDR_NONE
44
 
#undef INADDR_NONE
45
 
#endif
46
 
 
47
43
#include <EXTERN.h>
48
44
#include <perl.h>
49
45
#include <XSUB.h>
50
46
#include <dlfcn.h>
51
47
#include <semaphore.h>
52
48
 
53
 
static const char rcsid[] = "$Id: rlm_perl.c,v 1.13 2004/02/26 19:04:34 aland Exp $";
54
 
 
 
49
#ifdef __APPLE__
 
50
extern char **environ;
 
51
#endif
 
52
 
 
53
static const char rcsid[] = "$Id: rlm_perl.c,v 1.13.4.3 2006/01/10 11:46:24 nbk Exp $";
 
54
 
 
55
#ifdef USE_ITHREADS
 
56
 
 
57
/*
 
58
 * Pool of Perl's clones (genetically cloned) ;)
 
59
 *
 
60
 */
 
61
typedef struct pool_handle {
 
62
        struct pool_handle      *next;
 
63
        struct pool_handle      *prev;
 
64
        enum {busy, idle}       status;
 
65
        unsigned int            request_count;
 
66
        PerlInterpreter         *clone;
 
67
        perl_mutex              lock;
 
68
} POOL_HANDLE;
 
69
 
 
70
typedef struct PERL_POOL {
 
71
        POOL_HANDLE     *head;
 
72
        POOL_HANDLE     *tail;
 
73
 
 
74
        int             current_clones;
 
75
        int             active_clones;
 
76
        int             max_clones;
 
77
        int             start_clones;
 
78
        int             min_spare_clones;
 
79
        int             max_spare_clones;
 
80
        int             max_request_per_clone;
 
81
        int             cleanup_delay;
 
82
        enum {yes,no}   detach;
 
83
        perl_mutex      mutex;
 
84
        time_t          time_when_last_added;
 
85
} PERL_POOL;
 
86
 
 
87
#endif
55
88
 
56
89
/*
57
90
 *      Define a structure for our module configuration.
74
107
        char    *func_checksimul;
75
108
        char    *func_detach;
76
109
        char    *func_xlat;
 
110
        char    *func_pre_proxy;
 
111
        char    *func_post_proxy;
 
112
        char    *func_post_auth;
77
113
        char    *xlat_name;
78
114
        char    *perl_flags;
 
115
        PerlInterpreter *perl;
 
116
#ifdef USE_ITHREADS
 
117
        PERL_POOL       *perl_pool;
 
118
#endif
79
119
} PERL_INST;
80
120
/*
81
121
 *      A mapping of configuration file names to internal variables.
86
126
 *      to the strdup'd string into 'config.string'.  This gets around
87
127
 *      buffer over-flows.
88
128
 */
89
 
static CONF_PARSER module_config[] = {
 
129
static const CONF_PARSER module_config[] = {
90
130
        { "module",  PW_TYPE_STRING_PTR,
91
131
          offsetof(PERL_INST,module), NULL,  "module"},
92
132
        { "func_authorize", PW_TYPE_STRING_PTR,
103
143
          offsetof(PERL_INST,func_detach), NULL, "detach"},
104
144
        { "func_xlat", PW_TYPE_STRING_PTR,
105
145
          offsetof(PERL_INST,func_xlat), NULL, "xlat"},
 
146
        { "func_pre_proxy", PW_TYPE_STRING_PTR,
 
147
          offsetof(PERL_INST,func_pre_proxy), NULL, "pre_proxy"},
 
148
        { "func_post_proxy", PW_TYPE_STRING_PTR,
 
149
          offsetof(PERL_INST,func_post_proxy), NULL, "post_proxy"},
 
150
        { "func_post_auth", PW_TYPE_STRING_PTR,
 
151
          offsetof(PERL_INST,func_post_auth), NULL, "post_auth"},
106
152
        { "perl_flags", PW_TYPE_STRING_PTR,
107
153
          offsetof(PERL_INST,perl_flags), NULL, NULL},
108
154
        { "func_start_accounting", PW_TYPE_STRING_PTR,
118
164
 */
119
165
EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
120
166
 
 
167
#ifdef USE_ITHREADS
121
168
/*
122
 
 *      We share one perl interpreter among all of the instances
123
 
 *      of this module. And clone it for every thread if we have perl
 
169
 *      We use one perl to clone from it i.e. main boss
 
170
 *      We clone it for every instance if we have perl
124
171
 *      with -Duseithreads compiled in
125
172
 */
126
173
static PerlInterpreter  *interp;
127
174
 
128
 
#ifdef USE_ITHREADS
129
 
 
130
 
/*
131
 
 * Pool of Perl's clones (genetically cloned) ;)
132
 
 *
133
 
 */
134
 
typedef struct pool_handle {
135
 
        struct pool_handle      *next;
136
 
        struct pool_handle      *prev;
137
 
        enum {busy, idle}       status;
138
 
        unsigned int            request_count;
139
 
        PerlInterpreter         *clone;
140
 
} POOL_HANDLE;
141
 
 
142
 
typedef struct PERL_POOL {
143
 
        POOL_HANDLE     *head;
144
 
        POOL_HANDLE     *tail;
145
 
 
146
 
        int             current_clones;
147
 
        int             active_clones;
148
 
        int             max_clones;
149
 
        int             start_clones;
150
 
        int             min_spare_clones;
151
 
        int             max_spare_clones;
152
 
        int             max_request_per_clone;
153
 
        int             cleanup_delay;
154
 
        perl_mutex      mutex;
155
 
        time_t          time_when_last_added;
156
 
} PERL_POOL;
157
 
 
158
 
static PERL_POOL perl_pool;
159
 
 
160
175
static const CONF_PARSER pool_conf[] = {
161
 
        { "max_clones", PW_TYPE_INTEGER, 0, &perl_pool.max_clones,              "32"},
162
 
        { "start_clones",PW_TYPE_INTEGER, 0, &perl_pool.start_clones,           "5"},
163
 
        { "min_spare_clones",PW_TYPE_INTEGER, 0, &perl_pool.min_spare_clones,   "3"},
164
 
        { "max_spare_clones",PW_TYPE_INTEGER, 0, &perl_pool.max_spare_clones,   "3"},
165
 
        { "cleanup_delay",PW_TYPE_INTEGER, 0, &perl_pool.cleanup_delay,         "5"},
166
 
        { "max_request_per_clone",PW_TYPE_INTEGER, 0, &perl_pool.max_request_per_clone, "0"},
 
176
        { "max_clones", PW_TYPE_INTEGER, offsetof(PERL_POOL, max_clones), NULL,         "32"},
 
177
        { "start_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL, start_clones), NULL,              "5"},
 
178
        { "min_spare_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL, min_spare_clones),NULL,       "3"},
 
179
        { "max_spare_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL,max_spare_clones),NULL,        "3"},
 
180
        { "cleanup_delay",PW_TYPE_INTEGER, offsetof(PERL_POOL,cleanup_delay),NULL,              "5"},
 
181
        { "max_request_per_clone",PW_TYPE_INTEGER, offsetof(PERL_POOL,max_request_per_clone),NULL,      "0"},
167
182
        { NULL, -1, 0, NULL, NULL }             /* end the list */
168
183
};
169
184
 
239
254
        free(handles);
240
255
}
241
256
 
242
 
static PerlInterpreter *rlm_perl_clone()
 
257
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
243
258
{
244
259
        PerlInterpreter *clone;
245
 
        UV      clone_flags = CLONEf_KEEP_PTR_TABLE;
246
 
 
247
 
        PERL_SET_CONTEXT(interp);
248
 
 
249
 
        clone = perl_clone(interp, clone_flags);
 
260
        UV      clone_flags = 0;
 
261
 
 
262
        PERL_SET_CONTEXT(perl);
 
263
 
 
264
        clone = perl_clone(perl, clone_flags);
250
265
        {
251
266
                dTHXa(clone);
252
267
        }
253
 
 
 
268
#if PERL_REVISION >= 5 && PERL_VERSION <8
 
269
        call_pv("CLONE",0);
 
270
#endif
254
271
        ptr_table_free(PL_ptr_table);
255
272
        PL_ptr_table = NULL;
256
273
 
302
319
        rlm_perl_close_handles(handles);
303
320
}
304
321
 
305
 
static void delete_pool_handle(POOL_HANDLE *handle)
 
322
static void delete_pool_handle(POOL_HANDLE *handle, PERL_INST *inst)
306
323
{
307
324
        POOL_HANDLE *prev;
308
325
        POOL_HANDLE *next;
311
328
        next = handle->next;
312
329
 
313
330
        if (prev == NULL) {
314
 
                perl_pool.head = next;
 
331
                inst->perl_pool->head = next;
315
332
        } else {
316
333
                prev->next = next;
317
334
        }
318
335
 
319
336
        if (next == NULL) {
320
 
                perl_pool.tail = prev;
 
337
                inst->perl_pool->tail = prev;
321
338
        } else {
322
339
                next->prev = prev;
323
340
        }
324
 
        perl_pool.current_clones--;
 
341
        inst->perl_pool->current_clones--;
 
342
        MUTEX_DESTROY(&handle->lock);
 
343
        free(handle);
325
344
}
326
345
 
327
 
static void move2tail(POOL_HANDLE *handle)
 
346
static void move2tail(POOL_HANDLE *handle, PERL_INST *inst)
328
347
{
329
348
        POOL_HANDLE *prev;
330
349
        POOL_HANDLE *next;
331
350
 
332
 
        if (perl_pool.head == NULL) {
 
351
        if (inst->perl_pool->head == NULL) {
333
352
 
334
353
                handle->prev = NULL;
335
354
                handle->next = NULL;
336
 
                perl_pool.head = handle;
337
 
                perl_pool.tail = handle;
 
355
                inst->perl_pool->head = handle;
 
356
                inst->perl_pool->tail = handle;
338
357
                return;
339
358
        }
340
359
 
341
 
        if (perl_pool.tail == handle) {
 
360
        if (inst->perl_pool->tail == handle) {
342
361
                return;
343
362
        }
344
363
 
352
371
                }
353
372
 
354
373
                if (prev == NULL) {
355
 
                        perl_pool.head = next;
 
374
                        inst->perl_pool->head = next;
356
375
                        next->prev = NULL;
357
376
 
358
377
                } else {
363
382
        }
364
383
 
365
384
        handle->next = NULL;
366
 
        prev = perl_pool.tail;
 
385
        prev = inst->perl_pool->tail;
367
386
 
368
 
        perl_pool.tail = handle;
 
387
        inst->perl_pool->tail = handle;
369
388
        handle->prev = prev;
370
389
        prev->next = handle;
371
390
}
372
391
 
373
392
 
374
 
static POOL_HANDLE *pool_grow () {
 
393
static POOL_HANDLE *pool_grow (PERL_INST *inst) {
375
394
        POOL_HANDLE *handle;
376
395
        time_t  now;
377
396
 
378
 
        if (perl_pool.max_clones == perl_pool.current_clones) {
 
397
        if (inst->perl_pool->max_clones == inst->perl_pool->current_clones) {
 
398
                return NULL;
 
399
        }
 
400
        if (inst->perl_pool->detach == yes ) {
379
401
                return NULL;
380
402
        }
381
403
 
389
411
        handle->prev = NULL;
390
412
        handle->next = NULL;
391
413
        handle->status = idle;
392
 
        handle->clone = rlm_perl_clone();
 
414
        handle->clone = rlm_perl_clone(inst->perl);
393
415
        handle->request_count = 0;
394
 
        perl_pool.current_clones++;
395
 
        move2tail(handle);
 
416
        MUTEX_INIT(&handle->lock);
 
417
        inst->perl_pool->current_clones++;
 
418
        move2tail(handle, inst);
396
419
 
397
420
        now = time(NULL);
398
 
        perl_pool.time_when_last_added = now;
 
421
        inst->perl_pool->time_when_last_added = now;
399
422
 
400
423
        return handle;
401
424
}
402
425
 
403
 
static POOL_HANDLE *pool_pop()
 
426
static POOL_HANDLE *pool_pop(PERL_INST *inst)
404
427
{
405
428
        POOL_HANDLE     *handle;
406
429
        POOL_HANDLE     *found;
409
432
         * Lock the pool and be fast other thread maybe
410
433
         * waiting for us to finish
411
434
         */
412
 
        MUTEX_LOCK(&perl_pool.mutex);
 
435
        MUTEX_LOCK(&inst->perl_pool->mutex);
413
436
 
414
437
        found = NULL;
415
438
 
416
 
        for (handle = perl_pool.head; handle ; handle = tmp) {
 
439
        for (handle = inst->perl_pool->head; handle ; handle = tmp) {
417
440
                tmp = handle->next;
418
441
 
419
442
                if (handle->status == idle){
423
446
        }
424
447
 
425
448
        if (found == NULL) {
426
 
                if (perl_pool.current_clones < perl_pool.max_clones ) {
 
449
                if (inst->perl_pool->current_clones < inst->perl_pool->max_clones ) {
427
450
 
428
 
                        found = pool_grow();
429
 
                        perl_pool.current_clones++;
 
451
                        found = pool_grow(inst);
430
452
 
431
453
                        if (found == NULL) {
432
454
                                radlog(L_ERR,"Cannot grow pool returning");
433
 
                                MUTEX_UNLOCK(&perl_pool.mutex);
 
455
                                MUTEX_UNLOCK(&inst->perl_pool->mutex);
434
456
                                return NULL;
435
457
                        }
436
458
                } else {
437
 
                        radlog(L_ERR,"reached maximum clones %d cannot grow",
438
 
                                        perl_pool.current_clones);
439
 
                        MUTEX_UNLOCK(&perl_pool.mutex);
 
459
                        radlog(L_ERR,"rlm_perl:: reached maximum clones %d cannot grow",
 
460
                                        inst->perl_pool->current_clones);
 
461
                        MUTEX_UNLOCK(&inst->perl_pool->mutex);
440
462
                        return NULL;
441
463
                }
442
464
        }
443
465
 
444
 
        move2tail(found);
 
466
        move2tail(found, inst);
445
467
        found->status = busy;
446
 
        perl_pool.active_clones++;
 
468
        MUTEX_LOCK(&found->lock);
 
469
        inst->perl_pool->active_clones++;
447
470
        found->request_count++;
448
471
        /*
449
472
         * Hurry Up
450
473
         */
451
 
        MUTEX_UNLOCK(&perl_pool.mutex);
 
474
        MUTEX_UNLOCK(&inst->perl_pool->mutex);
452
475
        radlog(L_DBG,"perl_pool: item 0x%lx asigned new request. Handled so far: %d",
453
476
                        (unsigned long) found->clone, found->request_count);
454
477
        return found;
455
478
}
456
 
static int pool_release(POOL_HANDLE *handle) {
 
479
static int pool_release(POOL_HANDLE *handle, PERL_INST *inst) {
457
480
 
458
481
        POOL_HANDLE *tmp, *tmp2;
459
482
        int spare, i, t;
461
484
        /*
462
485
         * Lock it
463
486
         */
464
 
        MUTEX_LOCK(&perl_pool.mutex);
465
 
        handle->status = idle;
466
 
        perl_pool.active_clones--;
467
 
 
468
 
        spare = perl_pool.current_clones - perl_pool.active_clones;
 
487
        MUTEX_LOCK(&inst->perl_pool->mutex);
 
488
 
 
489
        /*
 
490
         * If detach is set then just release the mutex
 
491
         */
 
492
        if (inst->perl_pool->detach == yes ) {
 
493
        handle->status = idle;
 
494
                MUTEX_UNLOCK(&handle->lock);
 
495
                MUTEX_UNLOCK(&inst->perl_pool->mutex);
 
496
                return 0;
 
497
        }
 
498
 
 
499
        MUTEX_UNLOCK(&handle->lock);
 
500
        handle->status = idle;
 
501
        inst->perl_pool->active_clones--;
 
502
 
 
503
        spare = inst->perl_pool->current_clones - inst->perl_pool->active_clones;
469
504
 
470
505
        radlog(L_DBG,"perl_pool total/active/spare [%d/%d/%d]"
471
 
                        , perl_pool.current_clones, perl_pool.active_clones, spare);
 
506
                        , inst->perl_pool->current_clones, inst->perl_pool->active_clones, spare);
472
507
 
473
 
        if (spare < perl_pool.min_spare_clones) {
474
 
                t = perl_pool.min_spare_clones - spare;
 
508
        if (spare < inst->perl_pool->min_spare_clones) {
 
509
                t = inst->perl_pool->min_spare_clones - spare;
475
510
                for (i=0;i<t; i++) {
476
 
                        if ((tmp = pool_grow()) == NULL) {
477
 
                                MUTEX_UNLOCK(&perl_pool.mutex);
 
511
                        if ((tmp = pool_grow(inst)) == NULL) {
 
512
                                MUTEX_UNLOCK(&inst->perl_pool->mutex);
478
513
                                return -1;
479
514
                        }
480
515
                }
481
 
                MUTEX_UNLOCK(&perl_pool.mutex);
 
516
                MUTEX_UNLOCK(&inst->perl_pool->mutex);
482
517
                return 0;
483
518
        }
484
519
        now = time(NULL);
485
 
        if ((now - perl_pool.time_when_last_added) < perl_pool.cleanup_delay) {
486
 
                MUTEX_UNLOCK(&perl_pool.mutex);
 
520
        if ((now - inst->perl_pool->time_when_last_added) < inst->perl_pool->cleanup_delay) {
 
521
                MUTEX_UNLOCK(&inst->perl_pool->mutex);
487
522
                return 0;
488
523
        }
489
 
        if (spare > perl_pool.max_spare_clones) {
490
 
                spare -= perl_pool.max_spare_clones;
491
 
                for (tmp = perl_pool.head; (tmp !=NULL ) && (spare > 0) ; tmp = tmp2) {
 
524
        if (spare > inst->perl_pool->max_spare_clones) {
 
525
                spare -= inst->perl_pool->max_spare_clones;
 
526
                for (tmp = inst->perl_pool->head; (tmp !=NULL ) && (spare > 0) ; tmp = tmp2) {
492
527
                        tmp2 = tmp->next;
493
528
 
494
529
                        if(tmp->status == idle) {
495
530
                                rlm_destroy_perl(tmp->clone);
496
 
                                delete_pool_handle(tmp);
497
 
                                perl_pool.current_clones--;
 
531
                                delete_pool_handle(tmp,inst);
498
532
                                spare--;
499
533
                                break;
500
534
                        }
501
535
                }
502
536
        }
503
537
        /*
 
538
         * If the clone have reached max_request_per_clone clean it.
 
539
         */
 
540
        if (inst->perl_pool->max_request_per_clone > 0 ) {
 
541
                        if (handle->request_count > inst->perl_pool->max_request_per_clone) {
 
542
                                rlm_destroy_perl(handle->clone);
 
543
                                delete_pool_handle(handle,inst);
 
544
                }
 
545
        }
 
546
        /*
504
547
         * Hurry Up :)
505
548
         */
506
 
        MUTEX_UNLOCK(&perl_pool.mutex);
 
549
        MUTEX_UNLOCK(&inst->perl_pool->mutex);
507
550
        return 0;
508
551
}
509
 
static int init_pool (CONF_SECTION *conf) {
 
552
static int init_pool (CONF_SECTION *conf, PERL_INST *inst) {
510
553
        POOL_HANDLE     *handle;
511
554
        int t;
512
 
 
513
 
        MUTEX_INIT(&perl_pool.mutex);
 
555
        PERL_POOL       *pool;
 
556
 
 
557
        pool = rad_malloc(sizeof(PERL_POOL));
 
558
        memset(pool,0,sizeof(PERL_POOL));
 
559
 
 
560
        inst->perl_pool = pool;
 
561
 
 
562
        MUTEX_INIT(&pool->mutex);
514
563
 
515
564
        /*
516
565
         * Read The Config
517
566
         *
518
567
         */
519
568
 
520
 
        cf_section_parse(conf,NULL,pool_conf);
 
569
        cf_section_parse(conf,pool,pool_conf);
 
570
        inst->perl_pool = pool;
 
571
        inst->perl_pool->detach = no;
521
572
 
522
 
        for(t = 0;t < perl_pool.start_clones ;t++){
523
 
                if ((handle = pool_grow()) == NULL) {
 
573
        for(t = 0;t < inst->perl_pool->start_clones ;t++){
 
574
                if ((handle = pool_grow(inst)) == NULL) {
524
575
                        return -1;
525
576
                }
526
577
 
536
587
 *
537
588
 *      Try to avoid putting too much stuff in here - it's better to
538
589
 *      do it in instantiate() where it is not global.
 
590
 *      I use one global interpetator to make things more fastest for
 
591
 *      Threading env I clone new perl from this interp.
539
592
 */
540
593
static int perl_init(void)
541
594
{
 
595
#ifdef USE_ITHREADS
542
596
        if ((interp = perl_alloc()) == NULL) {
543
 
                radlog(L_INFO, "rlm_perl: No memory for allocating new perl !");
 
597
                radlog(L_DBG, "rlm_perl: No memory for allocating new perl !");
544
598
                return -1;
545
599
        }
546
600
 
547
601
        perl_construct(interp);
548
602
        PL_perl_destruct_level = 2;
549
 
 
 
603
#endif
550
604
        return 0;
551
605
 
552
606
}
591
645
 * The xlat function
592
646
 */
593
647
static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out,
594
 
                     int freespace, RADIUS_ESCAPE_STRING func)
 
648
                     size_t freespace, RADIUS_ESCAPE_STRING func)
595
649
{
596
650
 
597
651
        PERL_INST       *inst= (PERL_INST *) instance;
598
652
        PerlInterpreter *perl;
599
 
        char            params[1024], *tmp_ptr, *ptr, *tmp;
600
 
        int             count, ret;
 
653
        char            params[1024], *ptr, *tmp;
 
654
        int             count, ret=0;
601
655
        STRLEN          n_a;
602
 
 
603
 
        perl = interp;
604
 
 
 
656
#ifndef USE_ITHREADS
 
657
        perl = inst->perl;
 
658
#endif
605
659
#ifdef USE_ITHREADS
606
660
        POOL_HANDLE     *handle;
607
661
 
608
 
        if ((handle = pool_pop()) == NULL) {
 
662
        if ((handle = pool_pop(instance)) == NULL) {
609
663
                return 0;
610
664
        }
611
665
 
616
670
        dTHXa(perl);
617
671
        }
618
672
#endif
 
673
        PERL_SET_CONTEXT(perl);
619
674
        {
620
675
        dSP;
621
676
        ENTER;SAVETMPS;
631
686
 
632
687
        PUSHMARK(SP);
633
688
 
634
 
        XPUSHs(sv_2mortal(newSVpv(ptr,0)));
635
 
 
636
 
        while ((tmp_ptr = strtok(NULL, " ")) != NULL) {
637
 
                XPUSHs(sv_2mortal(newSVpv(tmp_ptr,0)));
 
689
        while (ptr != NULL) {
 
690
                XPUSHs(sv_2mortal(newSVpv(ptr,0)));
 
691
                ptr = strtok(NULL, " ");
638
692
        }
639
693
 
640
694
        PUTBACK;
660
714
                FREETMPS ;
661
715
                LEAVE ;
662
716
 
663
 
                if (ret <= freespace)
664
 
                        return ret;
665
717
        }
666
718
        }
667
719
#ifdef USE_ITHREADS
668
 
        pool_release(handle);
 
720
        pool_release(handle, instance);
669
721
#endif
670
 
        return 0;
 
722
        return ret;
671
723
}
672
724
/*
673
725
 *      Do any per-module initialization that is separate to each
687
739
static int perl_instantiate(CONF_SECTION *conf, void **instance)
688
740
{
689
741
        PERL_INST       *inst = (PERL_INST *) instance;
690
 
        HV              *rad_reply_hv = newHV();
691
 
        HV              *rad_check_hv = newHV();
692
 
        HV              *rad_request_hv = newHV();
 
742
        HV              *rad_reply_hv;
 
743
        HV              *rad_check_hv;
 
744
        HV              *rad_request_hv;
 
745
        HV              *rad_request_proxy_hv;
 
746
        HV              *rad_request_proxy_reply_hv;
 
747
        AV              *end_AV;
693
748
 
694
749
        char *embed[4], *xlat_name;
695
750
        int exitstatus = 0, argc=0;
722
777
                argc = 3;
723
778
        }
724
779
 
725
 
        exitstatus = perl_parse(interp, xs_init, argc, embed, NULL);
 
780
#ifdef USE_ITHREADS
 
781
        inst->perl = perl_clone(interp ,CLONEf_KEEP_PTR_TABLE);
 
782
        {
 
783
        dTHXa(inst->perl);
 
784
        }
 
785
        PERL_SET_CONTEXT(inst->perl);
 
786
#else
 
787
        if ((inst->perl = perl_alloc()) == NULL) {
 
788
                radlog(L_ERR, "rlm_perl: No memory for allocating new perl !");
 
789
                return -1;
 
790
        }
 
791
 
 
792
        perl_construct(inst->perl);
 
793
#endif
726
794
 
727
795
#if PERL_REVISION >= 5 && PERL_VERSION >=8
728
796
        PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
729
797
#endif
730
798
 
 
799
        exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL);
 
800
 
 
801
        end_AV = PL_endav;
 
802
        PL_endav = Nullav;
 
803
 
731
804
        if(!exitstatus) {
732
 
                exitstatus = perl_run(interp);
 
805
                exitstatus = perl_run(inst->perl);
733
806
        } else {
734
 
                radlog(L_INFO,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module);
 
807
                radlog(L_ERR,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module);
735
808
                return (-1);
736
809
        }
737
810
 
 
811
        PL_endav = end_AV;
 
812
 
738
813
        newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl.c");
739
814
 
 
815
        rad_reply_hv = newHV();
 
816
        rad_check_hv = newHV();
 
817
        rad_request_hv = newHV();
 
818
        rad_request_proxy_hv = newHV();
 
819
        rad_request_proxy_reply_hv = newHV();
 
820
 
740
821
        rad_reply_hv = get_hv("RAD_REPLY",1);
741
822
        rad_check_hv = get_hv("RAD_CHECK",1);
742
823
        rad_request_hv = get_hv("RAD_REQUEST",1);
 
824
        rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1);
 
825
        rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1);
743
826
 
744
827
        xlat_name = cf_section_name2(conf);
745
828
        if (xlat_name == NULL)
750
833
        }
751
834
 
752
835
#ifdef USE_ITHREADS
753
 
 
754
 
        if ((init_pool(conf)) == -1) {
 
836
        if ((init_pool(conf, inst)) == -1) {
755
837
                radlog(L_ERR,"Couldn't init a pool of perl clones. Exiting");
756
838
                return -1;
757
839
        }
775
857
        char            buffer[1024];
776
858
        int             attr, len;
777
859
 
778
 
        hv_clear(rad_hv);
 
860
        hv_undef(rad_hv);
779
861
        nvp = paircopy(vp);
780
862
 
781
863
        while (nvp != NULL) {
791
873
                                vpn = vpn->next;
792
874
                        }
793
875
                        hv_store(rad_hv, nvp->name, strlen(nvp->name),
794
 
                                        newRV((SV *) av), 0);
 
876
                                        newRV_noinc((SV *) av), 0);
795
877
                } else {
796
878
                        len = vp_prints_value(buffer, sizeof(buffer),
797
879
                                        vpa, FALSE);
815
897
 */
816
898
static int pairadd_sv(VALUE_PAIR **vp, char *key, SV *sv) {
817
899
       char            *val;
818
 
       int             val_len;
819
900
       VALUE_PAIR      *vpp;
820
901
 
821
 
       if ((sv != NULL) && (SvPOK(sv))) {
822
 
               val = SvPV(sv, val_len);
 
902
       if (SvOK(sv)) {
 
903
               val = SvPV_nolen(sv);
823
904
               vpp = pairmake(key, val, T_OP_EQ);
824
905
               if (vpp != NULL) {
825
906
                       pairadd(vp, vpp);
878
959
        HV              *rad_reply_hv;
879
960
        HV              *rad_check_hv;
880
961
        HV              *rad_request_hv;
 
962
        HV              *rad_request_proxy_hv;
 
963
        HV              *rad_request_proxy_reply_hv;
881
964
 
882
965
#ifdef USE_ITHREADS
883
966
        POOL_HANDLE     *handle;
884
967
 
885
 
        if ((handle = pool_pop()) == NULL) {
 
968
        if ((handle = pool_pop(instance)) == NULL) {
886
969
                return RLM_MODULE_FAIL;
887
970
        }
888
971
 
891
974
        dTHXa(handle->clone);
892
975
        PERL_SET_CONTEXT(handle->clone);
893
976
        }
 
977
#else
 
978
        PERL_SET_CONTEXT(inst->perl);
 
979
        radlog(L_DBG,"Using perl at 0x%lx",(unsigned long) inst->perl);
894
980
#endif
895
981
        {
896
982
        dSP;
910
996
        rad_reply_hv = get_hv("RAD_REPLY",1);
911
997
        rad_check_hv = get_hv("RAD_CHECK",1);
912
998
        rad_request_hv = get_hv("RAD_REQUEST",1);
913
 
 
 
999
        rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1);
 
1000
        rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1);
914
1001
 
915
1002
 
916
1003
        perl_store_vps(request->reply->vps, rad_reply_hv);
917
1004
        perl_store_vps(request->config_items, rad_check_hv);
918
1005
        perl_store_vps(request->packet->vps, rad_request_hv);
 
1006
        
 
1007
        if (request->proxy != NULL) {
 
1008
                perl_store_vps(request->proxy->vps, rad_request_proxy_hv);
 
1009
        } else {
 
1010
                hv_undef(rad_request_proxy_hv);
 
1011
        }
 
1012
 
 
1013
        if (request->proxy_reply !=NULL) {
 
1014
                perl_store_vps(request->proxy_reply->vps, rad_request_proxy_reply_hv);
 
1015
        } else {
 
1016
                hv_undef(rad_request_proxy_reply_hv);
 
1017
        }       
 
1018
        
919
1019
        vp = NULL;
920
1020
 
921
1021
 
958
1058
                pairmove(&request->config_items, &vp);
959
1059
                pairfree(&vp);
960
1060
        }
961
 
 
962
 
#if 0
963
 
        /*
964
 
         *      Do we want to allow this?
965
 
         */
966
 
        if ((get_hv_content(rad_request_hv, &vp)) > 0 ) {
967
 
                pairfree(&request->packet->vps);
968
 
                request->packet->vps = vp;
 
1061
        
 
1062
        if ((get_hv_content(rad_request_proxy_reply_hv, &vp)) > 0 && request->proxy_reply != NULL) {
 
1063
                pairfree(&request->proxy_reply->vps);
 
1064
                pairmove(&request->proxy_reply->vps, &vp);
 
1065
                pairfree(&vp);
969
1066
        }
970
 
#endif
971
 
 
972
1067
        }
973
1068
#ifdef USE_ITHREADS
974
 
        pool_release(handle);
 
1069
        pool_release(handle,instance);
975
1070
        radlog(L_DBG,"Unreserve perl at address 0x%lx", (unsigned long) handle->clone);
976
1071
#endif
977
1072
 
1006
1101
        return rlmperl_call(instance, request,
1007
1102
                            ((PERL_INST *)instance)->func_preacct);
1008
1103
}
1009
 
 
1010
 
 
1011
1104
/*
1012
1105
 *      Write accounting information to this modules database.
1013
1106
 */
1014
 
 
1015
1107
static int perl_accounting(void *instance, REQUEST *request)
1016
1108
{
1017
1109
        VALUE_PAIR      *pair;
1056
1148
/*
1057
1149
 *      Check for simultaneouse-use
1058
1150
 */
1059
 
 
1060
1151
static int perl_checksimul(void *instance, REQUEST *request)
1061
1152
{
1062
1153
        return rlmperl_call(instance, request,
1063
1154
                        ((PERL_INST *)instance)->func_checksimul);
1064
1155
}
1065
 
 
 
1156
/*
 
1157
 *      Pre-Proxy request
 
1158
 */
 
1159
static int perl_pre_proxy(void *instance, REQUEST *request)
 
1160
{
 
1161
        return rlmperl_call(instance, request,
 
1162
                        ((PERL_INST *)instance)->func_pre_proxy);
 
1163
}
 
1164
/*
 
1165
 *      Post-Proxy request
 
1166
 */
 
1167
static int perl_post_proxy(void *instance, REQUEST *request)
 
1168
{
 
1169
        return rlmperl_call(instance, request,
 
1170
                        ((PERL_INST *)instance)->func_post_proxy);
 
1171
}
 
1172
/*
 
1173
 *      Pre-Auth request
 
1174
 */
 
1175
static int perl_post_auth(void *instance, REQUEST *request)
 
1176
{
 
1177
        return rlmperl_call(instance, request,
 
1178
                        ((PERL_INST *)instance)->func_post_auth);
 
1179
}
1066
1180
/*
1067
1181
 * Detach a instance give a chance to a module to make some internal setup ...
1068
1182
 */
1072
1186
        int             exitstatus=0,count=0;
1073
1187
 
1074
1188
#ifdef USE_ITHREADS
1075
 
        POOL_HANDLE     *handle;
1076
 
 
1077
 
        for (handle = perl_pool.head; handle; handle = handle->next) {
1078
 
 
1079
 
                radlog(L_INFO,"Detach perl 0x%lx", (unsigned long) handle->clone);
 
1189
        POOL_HANDLE     *handle, *tmp, *tmp2;
 
1190
 
 
1191
        MUTEX_LOCK(&inst->perl_pool->mutex);
 
1192
        inst->perl_pool->detach = yes;
 
1193
        MUTEX_UNLOCK(&inst->perl_pool->mutex);
 
1194
 
 
1195
        for (handle = inst->perl_pool->head; handle != NULL; handle = handle->next) {
 
1196
 
 
1197
                radlog(L_DBG,"Detach perl 0x%lx", (unsigned long) handle->clone);
1080
1198
                /*
1081
1199
                 * Wait until clone becomes idle
1082
 
                 *
1083
1200
                 */
1084
 
                while (handle->status == busy) {
1085
 
                }
 
1201
                MUTEX_LOCK(&handle->lock);
1086
1202
 
1087
1203
                /*
1088
1204
                 * Give a clones chance to run detach function
1091
1207
                dTHXa(handle->clone);
1092
1208
                PERL_SET_CONTEXT(handle->clone);
1093
1209
                {
1094
 
                dSP; PUSHMARK(SP);
 
1210
                dSP; ENTER; SAVETMPS; PUSHMARK(SP);
1095
1211
                count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
1096
1212
                SPAGAIN;
1097
1213
 
1106
1222
                        }
1107
1223
                }
1108
1224
                PUTBACK;
1109
 
                radlog(L_INFO,"detach at 0x%lx returned status %d",
 
1225
                FREETMPS;
 
1226
                LEAVE;
 
1227
                radlog(L_DBG,"detach at 0x%lx returned status %d",
1110
1228
                                (unsigned long) handle->clone, exitstatus);
1111
1229
                }
1112
1230
                }
1113
 
 
 
1231
                MUTEX_UNLOCK(&handle->lock);
1114
1232
        }
1115
1233
        /*
1116
 
         *
1117
 
         * FIXME: For more efficienty we don't
1118
 
         * free entire pool. We only reread config flags thus way
1119
 
         * we can extend pool_size.
1120
 
         *
 
1234
         * Free handles
1121
1235
         */
 
1236
 
 
1237
        for (tmp = inst->perl_pool->head; tmp !=NULL  ; tmp = tmp2) {
 
1238
                tmp2 = tmp->next;
 
1239
                radlog(L_DBG,"rlm_perl:: Destroy perl");
 
1240
                rlm_perl_destruct(tmp->clone);
 
1241
                delete_pool_handle(tmp,inst);
 
1242
        }
 
1243
 
1122
1244
        {
1123
 
        dTHXa(interp);
1124
 
        PERL_SET_CONTEXT(interp);
 
1245
        dTHXa(inst->perl);
1125
1246
#endif /* USE_ITHREADS */
 
1247
        PERL_SET_CONTEXT(inst->perl);
1126
1248
        {
1127
 
        dSP;
 
1249
        dSP; ENTER; SAVETMPS;
1128
1250
        PUSHMARK(SP);
 
1251
 
1129
1252
        count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
1130
1253
        SPAGAIN;
1131
1254
 
1136
1259
                }
1137
1260
        }
1138
1261
        PUTBACK;
 
1262
        FREETMPS;
 
1263
        LEAVE;
1139
1264
        }
1140
1265
#ifdef USE_ITHREADS
1141
1266
        }
1149
1274
        if (inst->func_accounting) free(inst->func_accounting);
1150
1275
        if (inst->func_preacct) free(inst->func_preacct);
1151
1276
        if (inst->func_checksimul) free(inst->func_checksimul);
 
1277
        if (inst->func_pre_proxy) free(inst->func_pre_proxy);
 
1278
        if (inst->func_post_proxy) free(inst->func_post_proxy);
 
1279
        if (inst->func_post_auth) free(inst->func_post_auth);
1152
1280
        if (inst->func_detach) free(inst->func_detach);
1153
1281
 
 
1282
#ifdef USE_ITHREADS
 
1283
        free(inst->perl_pool->head);
 
1284
        free(inst->perl_pool->tail);
 
1285
        MUTEX_DESTROY(&inst->perl_pool->mutex);
 
1286
        free(inst->perl_pool);
 
1287
        rlm_perl_destruct(inst->perl);
 
1288
#else
 
1289
        perl_destruct(inst->perl);
 
1290
        perl_free(inst->perl);
 
1291
#endif
 
1292
 
1154
1293
        free(inst);
1155
1294
        return exitstatus;
1156
1295
}
1157
 
 
1158
1296
/*
1159
1297
 *      The module name should be the only globally exported symbol.
1160
1298
 *      That is, everything else should be 'static'.
1179
1317
                perl_preacct,
1180
1318
                perl_accounting,
1181
1319
                perl_checksimul,        /* check simul */
1182
 
                NULL,                   /* pre-proxy */
1183
 
                NULL,                   /* post-proxy */
1184
 
                NULL                    /* post-auth */
 
1320
                perl_pre_proxy,  /* pre-proxy */
 
1321
                perl_post_proxy,        /* post-proxy */
 
1322
                perl_post_auth    /* post-auth */
1185
1323
        },
1186
1324
        perl_detach,                    /* detach */
1187
1325
        NULL,                           /* destroy */