app_perl: converted to the new module interface
[sip-router] / src / modules / app_perl / app_perl_mod.c
1 /*
2  * Perl module for Kamailio
3  *
4  * Copyright (C) 2006 Collax GmbH
5  *                    (Bastian Friedrich <bastian.friedrich@collax.com>)
6  *
7  * This file is part of Kamailio, a free SIP server.
8  *
9  * Kamailio is free software; you can redistribute it and/or modify
10  * it under the terms of the GNU General Public License as published by
11  * the Free Software Foundation; either version 2 of the License, or
12  * (at your option) any later version
13  *
14  * Kamailio is distributed in the hope that it will be useful,
15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17  * GNU General Public License for more details.
18  *
19  * You should have received a copy of the GNU General Public License
20  * along with this program; if not, write to the Free Software
21  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
22  *
23  */
24
25 #define DEFAULTMODULE "Kamailio"
26 #define MAX_LIB_PATHS 10
27
28 #include <stdio.h>
29 #include <stdlib.h>
30 #include <string.h>
31 #include <dlfcn.h>
32 #include <sys/time.h>
33
34 #include "../../core/sr_module.h"
35 #include "../../core/mem/mem.h"
36 #include "../../core/mem/shm_mem.h"
37 #include "../../modules/rr/api.h"
38 #include "../../modules/sl/sl.h"
39
40 #include "../../core/rpc.h"
41 #include "../../core/rpc_lookup.h"
42
43 /* lock_ops.h defines union semun, perl does not need to redefine it */
44 #ifdef USE_SYSV_SEM
45 # define HAS_UNION_SEMUN
46 #endif
47
48 #include "perlfunc.h"
49 #include "app_perl_mod.h"
50
51 /* #include "perlxsi.h" function is in here... */
52
53 MODULE_VERSION
54
55 /* Full path to the script including executed functions */
56 char *filename = NULL;
57
58 /* Path to an arbitrary directory where the Kamailio Perl modules are
59  * installed */
60 char *modpath = NULL;
61
62 /* Function to be called before perl interpreter instance is destroyed
63  * when attempting reinit */
64 static char *perl_destroy_func = NULL;
65
66 /* Allow unsafe module functions - functions with fixups. This will create
67  * memory leaks, the variable thus is not documented! */
68 int unsafemodfnc = 0;
69
70 /* number of execution cycles after which perl interpreter is reset */
71 int _ap_reset_cycles_init = 0;
72 int _ap_exec_cycles = 0;
73 int *_ap_reset_cycles = 0;
74
75 /* Reference to the running Perl interpreter instance */
76 PerlInterpreter *my_perl = NULL;
77
78 /** SL API structure */
79 sl_api_t slb;
80
81 static int ap_init_rpc(void);
82
83 /*
84  * Module destroy function prototype
85  */
86 static void destroy(void);
87
88 /* environment pointer needed to init perl interpreter */
89 extern char **environ;
90
91 /*
92  * Module initialization function prototype
93  */
94 static int mod_init(void);
95
96
97 /*
98  * Exported functions
99  */
100 static cmd_export_t cmds[] = {
101         { "perl_exec_simple", (cmd_function)perl_exec_simple1, 1,  NULL, 0,
102                                                              REQUEST_ROUTE | FAILURE_ROUTE
103                                                            | ONREPLY_ROUTE | BRANCH_ROUTE },
104         { "perl_exec_simple", (cmd_function)perl_exec_simple2, 2,  NULL, 0,
105                                                              REQUEST_ROUTE | FAILURE_ROUTE
106                                                            | ONREPLY_ROUTE | BRANCH_ROUTE },
107         { "perl_exec", (cmd_function)perl_exec1, 1,  NULL, 0,
108                                                              REQUEST_ROUTE | FAILURE_ROUTE
109                                                            | ONREPLY_ROUTE | BRANCH_ROUTE },
110         { "perl_exec", (cmd_function)perl_exec2, 2, NULL, 0,
111                                                              REQUEST_ROUTE | FAILURE_ROUTE
112                                                            | ONREPLY_ROUTE | BRANCH_ROUTE },
113         { 0, 0, 0, 0, 0, 0 }
114 };
115
116
117 /*
118  * Exported parameters
119  */
120 static param_export_t params[] = {
121         {"filename", PARAM_STRING, &filename},
122         {"modpath", PARAM_STRING, &modpath},
123         {"unsafemodfnc", INT_PARAM, &unsafemodfnc},
124         {"reset_cycles", INT_PARAM, &_ap_reset_cycles_init},
125         {"perl_destroy_func",  PARAM_STRING, &perl_destroy_func},
126         { 0, 0, 0 }
127 };
128
129
130 /*
131  * Module info
132  */
133
134 #ifndef RTLD_NOW
135 /* for openbsd */
136 #define RTLD_NOW DL_LAZY
137 #endif
138
139 #ifndef RTLD_GLOBAL
140 /* Unsupported! */
141 #define RTLD_GLOBAL 0
142 #endif
143
144 /*
145  * Module interface
146  */
147 struct module_exports _app_perl_exports = {
148         "app_perl",
149         RTLD_NOW | RTLD_GLOBAL,
150         cmds,       /* Exported functions */
151         params,     /* Exported parameters */
152         0,          /* exported RPC methods */
153         0,          /* exported pseudo-variables */
154         0,          /* response function */
155         mod_init,   /* module initialization function */
156         0,          /* child initialization function */
157         destroy    /* destroy function */
158 };
159
160
161
162 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
163 EXTERN_C void boot_Kamailio(pTHX_ CV* cv);
164
165
166 /*
167  * This is output by perl -MExtUtils::Embed -e xsinit
168  * and complemented by the Kamailio bootstrapping
169  */
170 EXTERN_C void xs_init(pTHX) {
171         char *file = __FILE__;
172         dXSUB_SYS;
173
174         newXS("Kamailio::bootstrap", boot_Kamailio, file);
175
176         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
177 }
178
179
180 /*
181  * Initialize the perl interpreter.
182  * This might later be used to reinit the module.
183  */
184 PerlInterpreter *parser_init(void) {
185         int argc = 0;
186         char *argv[MAX_LIB_PATHS + 3];
187         PerlInterpreter *new_perl = NULL;
188         char *entry, *stop, *end;
189         int modpathset_start = 0;
190         int modpathset_end = 0;
191         int i;
192         int pr;
193
194         new_perl = perl_alloc();
195
196         if (!new_perl) {
197                 LM_ERR("could not allocate perl.\n");
198                 return NULL;
199         }
200
201         perl_construct(new_perl);
202
203         argv[0] = ""; argc++; /* First param _needs_ to be empty */
204         
205          /* Possible Include path extension by modparam */
206         if (modpath && (strlen(modpath) > 0)) {
207                 modpathset_start = argc;
208
209                 entry = modpath;
210                 stop = modpath + strlen(modpath);
211                 for (end = modpath; end <= stop; end++) {
212                         if ( (end[0] == ':') || (end[0] == '\0') ) {
213                                 end[0] = '\0';
214                                 if (argc > MAX_LIB_PATHS) {
215                                         LM_ERR("too many lib paths, skipping lib path: '%s'\n", entry);
216                                 } else {
217                                         LM_INFO("setting lib path: '%s'\n", entry);
218                                         argv[argc] = pkg_malloc(strlen(entry)+20);
219                                         if (!argv[argc]) {
220                                                 LM_ERR("not enough pkg mem\n");
221                                                 return NULL;
222                                         }
223                                         sprintf(argv[argc], "-I%s", entry);
224                                         modpathset_end = argc;
225                                         argc++;
226                                 }
227                                 entry = end + 1;
228                         }
229                 }
230         }
231
232         argv[argc] = "-M"DEFAULTMODULE; argc++; /* Always "use" Kamailio.pm */
233
234         argv[argc] = filename; /* The script itself */
235         argc++;
236
237         pr=perl_parse(new_perl, xs_init, argc, argv, NULL);
238         if (pr) {
239                 LM_ERR("failed to load perl file \"%s\" with code %d.\n", argv[argc-1], pr);
240                 if (modpathset_start) {
241                         for (i = modpathset_start; i <= modpathset_end; i++) {
242                                 pkg_free(argv[i]);
243                         }
244                 }
245                 return NULL;
246         } else {
247                 LM_INFO("successfully loaded perl file \"%s\"\n", argv[argc-1]);
248         }
249
250         if (modpathset_start) {
251                 for (i = modpathset_start; i <= modpathset_end; i++) {
252                         pkg_free(argv[i]);
253                 }
254         }
255         perl_run(new_perl);
256
257         return new_perl;
258
259 }
260
261 /*
262  *
263  */
264 int unload_perl(PerlInterpreter *p) {
265         perl_destruct(p);
266         perl_free(p);
267
268         return 0;
269 }
270
271
272 /*
273  * reload function.
274  * Reinitializes the interpreter. Works, but execution for _all_
275  * children is difficult.
276  */
277 int perl_reload(void)
278 {
279
280         PerlInterpreter *new_perl;
281
282         new_perl = parser_init();
283
284         if (new_perl) {
285                 unload_perl(my_perl);
286                 my_perl = new_perl;
287 #ifdef PERL_EXIT_DESTRUCT_END
288                 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
289 #else
290 #warning Perl 5.8.x should be used. Please upgrade.
291 #warning This binary will be unsupported.
292                 PL_exit_flags |= PERL_EXIT_EXPECTED;
293 #endif
294                 return 0;
295         } else {
296                 return -1;
297         }
298
299 }
300
301
302 /*
303  * mod_init
304  * Called by kamailio at init time
305  */
306 static int mod_init(void) {
307
308         int argc = 1;
309         char *argt[] = { MOD_NAME, NULL };
310         char **argv;
311         struct timeval t1;
312         struct timeval t2;
313
314         if(ap_init_rpc()<0) {
315                 LM_ERR("failed to register RPC commands\n");
316                 return -1;
317         }
318
319         if (!filename) {
320                 LM_ERR("insufficient module parameters. Module not loaded.\n");
321                 return -1;
322         }
323
324         /* bind the SL API */
325         if (sl_load_api(&slb)!=0) {
326                 LM_ERR("cannot bind to SL API\n");
327                 return -1;
328         }
329
330         _ap_reset_cycles = shm_malloc(sizeof(int));
331         if(_ap_reset_cycles == NULL) {
332                 LM_ERR("no more shared memory\n");
333                 return -1;
334         }
335         *_ap_reset_cycles = _ap_reset_cycles_init;
336
337         argv = argt;
338         PERL_SYS_INIT3(&argc, &argv, &environ);
339
340         gettimeofday(&t1, NULL);
341         my_perl = parser_init();
342         gettimeofday(&t2, NULL);
343
344         if (my_perl==NULL)
345                 goto error;
346
347         LM_INFO("perl interpreter has been initialized (%d.%06d => %d.%06d)\n",
348                                 (int)t1.tv_sec, (int)t1.tv_usec,
349                                 (int)t2.tv_sec, (int)t2.tv_usec);
350
351 #ifdef PERL_EXIT_DESTRUCT_END
352         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
353 #else
354         PL_exit_flags |= PERL_EXIT_EXPECTED;
355 #endif
356         return 0;
357
358 error:
359         if(_ap_reset_cycles!=NULL)
360                 shm_free(_ap_reset_cycles);
361         _ap_reset_cycles = NULL;
362         return -1;
363 }
364
365 /*
366  * destroy
367  * called by kamailio at exit time
368  */
369 static void destroy(void)
370 {
371         if(_ap_reset_cycles!=NULL)
372                 shm_free(_ap_reset_cycles);
373         _ap_reset_cycles = NULL;
374
375         if(my_perl==NULL)
376                 return;
377         unload_perl(my_perl);
378         PERL_SYS_TERM();
379         my_perl = NULL;
380 }
381
382
383 /**
384  * count executions and rest interpreter
385  *
386  */
387 int app_perl_reset_interpreter(void)
388 {
389         struct timeval t1;
390         struct timeval t2;
391         char *args[] = { NULL };
392
393         if(*_ap_reset_cycles==0)
394                 return 0;
395
396         _ap_exec_cycles++;
397         LM_DBG("perl interpreter exec cycle [%d/%d]\n",
398                                 _ap_exec_cycles, *_ap_reset_cycles);
399
400         if(_ap_exec_cycles<=*_ap_reset_cycles)
401                 return 0;
402
403         if(perl_destroy_func)
404                 call_argv(perl_destroy_func, G_DISCARD | G_NOARGS, args);
405
406         gettimeofday(&t1, NULL);
407         if (perl_reload()<0) {
408                 LM_ERR("perl interpreter cannot be reset [%d/%d]\n",
409                                 _ap_exec_cycles, *_ap_reset_cycles);
410                 return -1;
411         }
412         gettimeofday(&t2, NULL);
413
414         LM_INFO("perl interpreter has been reset [%d/%d] (%d.%06d => %d.%06d)\n",
415                                 _ap_exec_cycles, *_ap_reset_cycles,
416                                 (int)t1.tv_sec, (int)t1.tv_usec,
417                                 (int)t2.tv_sec, (int)t2.tv_usec);
418         _ap_exec_cycles = 0;
419
420         return 0;
421 }
422
423 /*** RPC implementation ***/
424
425 static const char* app_perl_rpc_set_reset_cycles_doc[3] = {
426         "Set the value for reset_cycles",
427         "Has one parmeter with int value",
428         0
429 };
430
431
432 /*
433  * RPC command to set the value for reset_cycles
434  */
435 static void app_perl_rpc_set_reset_cycles(rpc_t* rpc, void* ctx)
436 {
437         int rsv;
438
439         if(rpc->scan(ctx, "d", &rsv)<1)
440         {
441                 rpc->fault(ctx, 500, "Invalid Parameters");
442                 return;
443         }
444         if(rsv<=0)
445                 rsv = 0;
446
447         LM_DBG("new reset cycle value is %d\n", rsv);
448
449         *_ap_reset_cycles = rsv;
450
451         return;
452 }
453
454 static const char* app_perl_rpc_get_reset_cycles_doc[2] = {
455         "Get the value for reset_cycles",
456         0
457 };
458
459
460 /*
461  * RPC command to set the value for reset_cycles
462  */
463 static void app_perl_rpc_get_reset_cycles(rpc_t* rpc, void* ctx)
464 {
465         int rsv;
466         void* th;
467
468         rsv = *_ap_reset_cycles;
469
470         /* add entry node */
471         if (rpc->add(ctx, "{", &th) < 0)
472         {
473                 rpc->fault(ctx, 500, "Internal error root reply");
474                 return;
475         }
476
477         if(rpc->struct_add(th, "d", "reset_cycles", rsv)<0)
478         {
479                 rpc->fault(ctx, 500, "Internal error adding reset cycles");
480                 return;
481         }
482         LM_DBG("reset cycle value is %d\n", rsv);
483
484         return;
485 }
486
487
488 rpc_export_t app_perl_rpc_cmds[] = {
489         {"app_perl.set_reset_cycles", app_perl_rpc_set_reset_cycles,
490                 app_perl_rpc_set_reset_cycles_doc,   0},
491         {"app_perl.get_reset_cycles", app_perl_rpc_get_reset_cycles,
492                 app_perl_rpc_get_reset_cycles_doc,   0},
493         {0, 0, 0, 0}
494 };
495
496 /**
497  * register RPC commands
498  */
499 static int ap_init_rpc(void)
500 {
501         if (rpc_register_array(app_perl_rpc_cmds)!=0)
502         {
503                 LM_ERR("failed to register RPC commands\n");
504                 return -1;
505         }
506         return 0;
507 }