00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020 #ifndef lint
00021 static const char rcsid[] = "$Id: perlscript.c,v 1.33 2007-04-14 15:21:13 sven Exp $";
00022 #endif
00023
00024 #ifdef DEBUG
00025 # undef DEBUG
00026 #endif
00027
00028 #include <stdio.h>
00029 #include <stdlib.h>
00030 #include <EXTERN.h>
00031 #include <perl.h>
00032 #include <XSUB.h>
00033 #undef _
00034 #include <eggdrop/eggdrop.h>
00035
00036 static PerlInterpreter *ginterp;
00037
00038 static XS(my_command_handler);
00039 static SV *c_to_perl_var(script_var_t *v);
00040 static int perl_to_c_var(SV *sv, script_var_t *var, int type);
00041 static int my_perl_cb_delete(event_owner_t *owner, void *me);
00042
00043 static int my_load_script(void *ignore, char *fname);
00044 static int my_link_var(void *ignore, script_linked_var_t *linked_var);
00045 static int my_unlink_var(void *ignore, script_linked_var_t *linked_var);
00046 static int my_create_command(void *ignore, script_raw_command_t *info);
00047 static int my_delete_command(void *ignore, script_raw_command_t *info);
00048 static int my_get_arg(void *ignore, script_args_t *args, int num, script_var_t *var, int type);
00049
00050 script_module_t my_script_interface = {
00051 "Perl", NULL,
00052 my_load_script,
00053 my_link_var, my_unlink_var,
00054 my_create_command, my_delete_command,
00055 my_get_arg
00056 };
00057
00058 event_owner_t perl_owner = {
00059 "perlscript", 0,
00060 0, 0,
00061 my_perl_cb_delete
00062 };
00063
00064 typedef struct {
00065 SV **sp;
00066 SV **mark;
00067 I32 ax;
00068 I32 items;
00069 } my_args_data_t;
00070
00071
00072 extern int log_error(char *msg);
00073
00074 static int my_load_script(void *ignore, char *fname)
00075 {
00076 FILE *fp;
00077 char *data;
00078 int size, len;
00079
00080
00081 len = strlen(fname);
00082 if (len < 3 || fname[len-1] != 'l' || fname[len-2] != 'p' || fname[len-3] != '.') {
00083
00084 return(0);
00085 }
00086
00087 fp = fopen(fname, "r");
00088 if (!fp) return (0);
00089 fseek(fp, 0, SEEK_END);
00090 size = ftell(fp);
00091 data = (char *)malloc(size + 1);
00092 fseek(fp, 0, SEEK_SET);
00093 fread(data, size, 1, fp);
00094 data[size] = 0;
00095 fclose(fp);
00096 eval_pv(data, TRUE);
00097 if (SvTRUE(ERRSV)) {
00098 char *msg;
00099 int len;
00100
00101 msg = SvPV(ERRSV, len);
00102 log_error(msg);
00103 }
00104 free(data);
00105 return(0);
00106 }
00107
00108 static void set_linked_var(script_linked_var_t *linked_var, SV *sv, script_var_t *val)
00109 {
00110 SV *newsv;
00111 script_var_t var;
00112
00113 if (!val || !val->type) {
00114 var.type = linked_var->type & SCRIPT_TYPE_MASK;
00115 var.len = -1;
00116 var.value = *(void **)linked_var->value;
00117 val = &var;
00118 }
00119
00120 newsv = c_to_perl_var(val);
00121 sv_setsv(sv, newsv);
00122 SvREFCNT_dec(newsv);
00123 }
00124
00125 static int linked_var_get(pTHX_ SV *sv, MAGIC *mg)
00126 {
00127 script_linked_var_t *linked_var = (script_linked_var_t *)mg->mg_ptr;
00128
00129 if (linked_var->callbacks && linked_var->callbacks->on_read) {
00130 script_var_t newvalue = {0};
00131 int r = (linked_var->callbacks->on_read)(linked_var, &newvalue);
00132 if (r) return(r);
00133 set_linked_var(linked_var, sv, &newvalue);
00134 }
00135 else set_linked_var(linked_var, sv, NULL);
00136 return(0);
00137 }
00138
00139 static int linked_var_set(pTHX_ SV *sv, MAGIC *mg)
00140 {
00141 script_linked_var_t *linked_var = (script_linked_var_t *)mg->mg_ptr;
00142 script_var_t newvalue = {0};
00143
00144 perl_to_c_var(sv, &newvalue, linked_var->type);
00145 script_linked_var_on_write(linked_var, &newvalue);
00146 return(0);
00147 }
00148
00149
00150 static int my_link_var(void *ignore, script_linked_var_t *linked_var)
00151 {
00152 MAGIC *mg;
00153 SV *sv;
00154 char *name;
00155
00156
00157 if (linked_var->class && strlen(linked_var->class)) name = egg_mprintf("%s::%s", linked_var->class, linked_var->name);
00158 else name = strdup(linked_var->name);
00159
00160
00161 sv = get_sv(name, TRUE);
00162 free(name);
00163
00164
00165 set_linked_var(linked_var, sv, NULL);
00166
00167
00168
00169
00170
00171 sv_magic(sv, NULL, 'U', (char *)linked_var, sizeof(*linked_var));
00172
00173
00174 mg = mg_find(sv, 'U');
00175 mg->mg_virtual = (MGVTBL *)calloc(1, sizeof(MGVTBL));
00176 mg->mg_virtual->svt_get = linked_var_get;
00177 mg->mg_virtual->svt_set = linked_var_set;
00178
00179 return(0);
00180 }
00181
00182 static int my_unlink_var(void *ignore, script_linked_var_t *linked_var)
00183 {
00184 MAGIC *mg;
00185 SV *sv;
00186 char *name;
00187
00188
00189 if (linked_var->class && strlen(linked_var->class)) name = egg_mprintf("%s::%s", linked_var->class, linked_var->name);
00190 else name = strdup(linked_var->name);
00191
00192
00193 sv = get_sv(name, FALSE);
00194 free(name);
00195
00196 if (!sv) return(0);
00197
00198 mg = mg_find(sv, 'U');
00199 free(mg->mg_virtual);
00200 mg->mg_virtual = NULL;
00201
00202 mg_free(sv);
00203 mg_clear(sv);
00204 SvREFCNT_dec(sv);
00205
00206 return(0);
00207 }
00208
00209 static int my_perl_callbacker(script_callback_t *me, ...)
00210 {
00211 int retval, i, n, count;
00212 script_var_t var;
00213 SV *cmd, *arg;
00214 va_list va;
00215 dSP;
00216
00217 ENTER;
00218 SAVETMPS;
00219 PUSHMARK(SP);
00220
00221 if (me->syntax) n = strlen(me->syntax);
00222 else n = 0;
00223 va_start(va, me);
00224 for (i = 0; i < n; i++) {
00225 var.type = me->syntax[i];
00226 if (var.type == SCRIPT_INTEGER || var.type == SCRIPT_UNSIGNED) var.value = (void *) (va_arg(va, int));
00227 else var.value = va_arg(va, void *);
00228 var.len = -1;
00229 arg = c_to_perl_var(&var);
00230 XPUSHs(sv_2mortal(arg));
00231 }
00232 va_end(va);
00233 PUTBACK;
00234
00235 cmd = me->callback_data;
00236 SvREFCNT_inc(cmd);
00237
00238 count = call_sv(cmd, G_EVAL|G_SCALAR);
00239 SvREFCNT_dec(cmd);
00240
00241 SPAGAIN;
00242
00243 if (SvTRUE(ERRSV)) {
00244 char *msg;
00245 int len;
00246
00247 msg = SvPV(ERRSV, len);
00248 retval = POPi;
00249 log_error(msg);
00250 }
00251 else if (count > 0) {
00252 retval = POPi;
00253 }
00254 else retval = 0;
00255
00256 PUTBACK;
00257 FREETMPS;
00258 LEAVE;
00259
00260 return(retval);
00261 }
00262
00263 static int my_perl_cb_delete(event_owner_t *owner, void *data)
00264 {
00265 script_callback_t *me = data;
00266
00267 if (me->syntax) free(me->syntax);
00268 if (me->name) free(me->name);
00269 sv_2mortal((SV *)me->callback_data);
00270 SvREFCNT_dec((SV *)me->callback_data);
00271 free(me);
00272 return(0);
00273 }
00274
00275 static int my_create_command(void *ignore, script_raw_command_t *info)
00276 {
00277 char *cmdname;
00278 CV *cv;
00279
00280 if (info->class && strlen(info->class)) {
00281 cmdname = egg_mprintf("%s_%s", info->class, info->name);
00282 }
00283 else {
00284 cmdname = strdup(info->name);
00285 }
00286 cv = newXS(cmdname, my_command_handler, "eggdrop");
00287 XSANY.any_ptr = info;
00288 free(cmdname);
00289
00290 return(0);
00291 }
00292
00293 static int my_delete_command(void *ignore, script_raw_command_t *info)
00294 {
00295
00296 return(0);
00297 }
00298
00299 static SV *c_to_perl_var(script_var_t *v)
00300 {
00301 SV *result;
00302
00303 if (v->type & SCRIPT_ARRAY) {
00304 AV *array;
00305 SV *element;
00306 int i;
00307
00308 array = newAV();
00309 if ((v->type & SCRIPT_TYPE_MASK) == SCRIPT_VAR) {
00310 script_var_t **v_list;
00311
00312 v_list = (script_var_t **)v->value;
00313 for (i = 0; i < v->len; i++) {
00314 element = c_to_perl_var(v_list[i]);
00315 av_push(array, element);
00316 }
00317 }
00318 else {
00319 script_var_t v_sub;
00320 void **values;
00321
00322 v_sub.type = v->type & (~SCRIPT_ARRAY);
00323 values = (void **)v->value;
00324 for (i = 0; i < v->len; i++) {
00325 v_sub.value = values[i];
00326 v_sub.len = -1;
00327 element = c_to_perl_var(&v_sub);
00328 av_push(array, element);
00329 }
00330 }
00331 if (v->type & SCRIPT_FREE) free(v->value);
00332 if (v->type & SCRIPT_FREE_VAR) free(v);
00333 result = newRV_noinc((SV *)array);
00334 return(result);
00335 }
00336
00337 switch (v->type & SCRIPT_TYPE_MASK) {
00338 case SCRIPT_INTEGER:
00339 case SCRIPT_UNSIGNED:
00340 result = newSViv((int) v->value);
00341 break;
00342 case SCRIPT_STRING: {
00343 char *str = v->value;
00344
00345 if (!str) str = "";
00346 if (v->len == -1) v->len = strlen(str);
00347 result = newSVpv(str, v->len);
00348 if (v->value && v->type & SCRIPT_FREE) free(v->value);
00349 break;
00350 }
00351 case SCRIPT_BYTES: {
00352 byte_array_t *bytes = v->value;
00353
00354 result = newSVpv(bytes->bytes, bytes->len);
00355 if (bytes->do_free) free(bytes->bytes);
00356 if (v->type & SCRIPT_FREE) free(bytes);
00357 break;
00358 }
00359 case SCRIPT_POINTER: {
00360 char str[32];
00361 int str_len;
00362
00363 sprintf(str, "#%u", (unsigned int) v->value);
00364 str_len = strlen(str);
00365 result = newSVpv(str, str_len);
00366 break;
00367 }
00368 case SCRIPT_USER: {
00369 char *handle;
00370 int str_len;
00371 user_t *u = v->value;
00372
00373 handle = u->handle;
00374
00375 str_len = strlen(handle);
00376 result = newSVpv(handle, str_len);
00377 break;
00378 }
00379 case SCRIPT_PARTIER: {
00380 partymember_t *p = v->value;
00381
00382 if (p) result = newSVpv(p->full_id_name, strlen(p->full_id_name));
00383 else result = newSVpv("*", 1);
00384 break;
00385 }
00386 default:
00387 result = &PL_sv_undef;
00388 }
00389 return(result);
00390 }
00391
00392 static int perl_to_c_var(SV *sv, script_var_t *var, int type)
00393 {
00394 int len;
00395
00396 var->type = type;
00397 var->len = -1;
00398 var->value = NULL;
00399
00400 switch (type) {
00401 case SCRIPT_BYTES:
00402 case SCRIPT_STRING: {
00403 var->value = SvPV(sv, len);
00404 break;
00405 }
00406 case SCRIPT_UNSIGNED:
00407 case SCRIPT_INTEGER: {
00408 var->value = (void *)SvIV(sv);
00409 break;
00410 }
00411 case SCRIPT_CALLBACK: {
00412 script_callback_t *cback;
00413 char *name;
00414
00415 cback = (script_callback_t *)calloc(1, sizeof(*cback));
00416 cback->callback = (Function) my_perl_callbacker;
00417 name = SvPV(sv, len);
00418 cback->name = strdup(name);
00419 cback->callback_data = newSVsv(sv);
00420 cback->owner = &perl_owner;
00421
00422 var->value = cback;
00423 break;
00424 }
00425 case SCRIPT_PARTIER: {
00426 var->value = partymember_lookup(SvPV(sv, len), NULL, -1);
00427 break;
00428 }
00429 case SCRIPT_USER: {
00430 user_t *u;
00431 char *handle;
00432
00433 handle = SvPV(sv, len);
00434 if (handle) u = user_lookup_by_handle(handle);
00435 else u = NULL;
00436 var->value = u;
00437 break;
00438 }
00439 default:
00440 return(1);
00441 }
00442 return(0);
00443 }
00444
00445 static XS(my_command_handler)
00446 {
00447 dXSARGS;
00448
00449
00450
00451 script_raw_command_t *cmd = (script_raw_command_t *) XSANY.any_ptr;
00452 script_var_t retval;
00453 SV *result = NULL;
00454 script_args_t args;
00455 my_args_data_t argdata;
00456
00457 argdata.mark = mark;
00458 argdata.sp = sp;
00459 argdata.ax = ax;
00460 argdata.items = items;
00461 args.module = &my_script_interface;
00462 args.client_data = &argdata;
00463 args.len = items;
00464
00465 retval.type = 0;
00466 retval.value = NULL;
00467 retval.len = -1;
00468
00469 cmd->callback(cmd->client_data, &args, &retval);
00470
00471
00472
00473 result = c_to_perl_var(&retval);
00474
00475 if (result) {
00476 XSprePUSH;
00477 PUSHs(result);
00478 XSRETURN(1);
00479 }
00480 else {
00481 XSRETURN_EMPTY;
00482 }
00483 }
00484
00485 static int my_get_arg(void *ignore, script_args_t *args, int num, script_var_t *var, int type)
00486 {
00487 my_args_data_t *argdata;
00488 register SV **sp;
00489 register SV **mark;
00490 I32 ax;
00491 I32 items;
00492
00493 argdata = (my_args_data_t *)args->client_data;
00494 sp = argdata->sp;
00495 mark = argdata->mark;
00496 ax = argdata->ax;
00497 items = argdata->items;
00498
00499 if (num >= items) return(-1);
00500
00501 return perl_to_c_var(ST(num), var, type);
00502 }
00503
00504 char *real_perl_cmd(char *text)
00505 {
00506 SV *result;
00507 char *msg, *retval;
00508 int len;
00509
00510 result = eval_pv(text, FALSE);
00511 if (SvTRUE(ERRSV)) {
00512 msg = SvPV(ERRSV, len);
00513 retval = egg_mprintf("Perl error: %s", msg);
00514 }
00515 else {
00516 msg = SvPV(result, len);
00517 retval = egg_mprintf("Perl result: %s\n", msg);
00518 }
00519
00520 return(retval);
00521 }
00522
00523 static void init_xs_stuff()
00524 {
00525 extern void boot_DynaLoader();
00526 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, "eggdrop");
00527 }
00528
00529 int perlscript_init()
00530 {
00531 char *embedding[] = {"", "-e", "0"};
00532
00533 ginterp = perl_alloc();
00534 perl_construct(ginterp);
00535 perl_parse(ginterp, init_xs_stuff, 3, embedding, NULL);
00536 return(0);
00537 }
00538
00539 int perlscript_destroy()
00540 {
00541 PL_perl_destruct_level = 1;
00542 perl_destruct(ginterp);
00543 perl_free(ginterp);
00544 return(0);
00545 }