Mercurial > pidgin3 / file comparison

comparison: libpurple/plugins/perl/perl-common.c

libpurple/plugins/perl/perl-common.c

changeset 15435
4b933b06d75e
parent 14779
1b71da367f56
child 15884
4de1981757fc
equal deleted inserted replaced
15434:94dcf9e39d66 15435:4b933b06d75e
1 #include "debug.h"
2 #include "value.h"
3
4 #include "perl-common.h"
5
6 extern PerlInterpreter *my_perl;
7
8 static GHashTable *object_stashes = NULL;
9
10 void gaim_perl_normalize_script_name(char *name)
11 {
12 char *c;
13
14 c = strrchr(name, '.');
15
16 if (c != NULL)
17 *c = '\0';
18
19 for (c = name; *c != '\0'; c++) {
20 if (*c != '_' && !g_ascii_isalnum(*c))
21 *c = '_';
22 }
23 }
24
25 static int
26 magic_free_object(pTHX_ SV *sv, MAGIC *mg)
27 {
28 sv_setiv(sv, 0);
29
30 return 0;
31 }
32
33 static MGVTBL vtbl_free_object =
34 {
35 NULL, NULL, NULL, NULL, magic_free_object, NULL, NULL
36 };
37
38 static SV *
39 create_sv_ptr(void *object)
40 {
41 SV *sv;
42
43 sv = newSViv((IV)object);
44
45 sv_magic(sv, NULL, '~', NULL, 0);
46
47 SvMAGIC(sv)->mg_private = 0x1551; /* HF */
48 SvMAGIC(sv)->mg_virtual = &vtbl_free_object;
49
50 return sv;
51 }
52
53 SV *
54 newSVGChar(const char *str)
55 {
56 SV *sv;
57
58 if (str == NULL)
59 return &PL_sv_undef;
60
61 sv = newSVpv(str, 0);
62 SvUTF8_on(sv);
63
64 return sv;
65 }
66
67 SV *
68 gaim_perl_bless_object(void *object, const char *stash_name)
69 {
70 HV *stash;
71 HV *hv;
72
73 if (object == NULL)
74 return NULL;
75
76 if (object_stashes == NULL) {
77 object_stashes = g_hash_table_new(g_direct_hash, g_direct_equal);
78 }
79
80 stash = gv_stashpv(stash_name, 1);
81
82 hv = newHV();
83 hv_store(hv, "_gaim", 5, create_sv_ptr(object), 0);
84
85 return sv_bless(newRV_noinc((SV *)hv), stash);
86 }
87
88 gboolean
89 gaim_perl_is_ref_object(SV *o)
90 {
91 SV **sv;
92 HV *hv;
93
94 hv = hvref(o);
95
96 if (hv != NULL) {
97 sv = hv_fetch(hv, "_gaim", 5, 0);
98
99 if (sv != NULL)
100 return TRUE;
101 }
102
103 return FALSE;
104 }
105
106 void *
107 gaim_perl_ref_object(SV *o)
108 {
109 SV **sv;
110 HV *hv;
111 void *p;
112
113 if (o == NULL)
114 return NULL;
115
116 hv = hvref(o);
117
118 if (hv == NULL)
119 return NULL;
120
121 sv = hv_fetch(hv, "_gaim", 5, 0);
122
123 if (sv == NULL)
124 croak("variable is damaged");
125
126 p = GINT_TO_POINTER(SvIV(*sv));
127
128 return p;
129 }
130
131 /*
132 2003/02/06: execute_perl modified by Mark Doliner <mark@kingant.net>
133 Pass parameters by pushing them onto the stack rather than
134 passing an array of strings. This way, perl scripts can
135 modify the parameters and we can get the changed values
136 and then shoot ourselves. I mean, uh, use them.
137
138 2001/06/14: execute_perl replaced by Martin Persson <mep@passagen.se>
139 previous use of perl_eval leaked memory, replaced with
140 a version that uses perl_call instead
141
142 30/11/2002: execute_perl modified by Eric Timme <timothy@voidnet.com>
143 args changed to char** so that we can have preparsed
144 arguments again, and many headaches ensued! This essentially
145 means we replaced one hacked method with a messier hacked
146 method out of perceived necessity. Formerly execute_perl
147 required a single char_ptr, and it would insert it into an
148 array of character pointers and NULL terminate the new array.
149 Now we have to pass in pre-terminated character pointer arrays
150 to accomodate functions that want to pass in multiple arguments.
151
152 Previously arguments were preparsed because an argument list
153 was constructed in the form 'arg one','arg two' and was
154 executed via a call like &funcname(arglist) (see .59.x), so
155 the arglist was magically pre-parsed because of the method.
156 With Martin Persson's change to perl_call we now need to
157 use a null terminated list of character pointers for arguments
158 if we wish them to be parsed. Lacking a better way to allow
159 for both single arguments and many I created a NULL terminated
160 array in every function that called execute_perl and passed
161 that list into the function. In the former version a single
162 character pointer was passed in, and was placed into an array
163 of character pointers with two elements, with a NULL element
164 tacked onto the back, but this method no longer seemed prudent.
165
166 Enhancements in the future might be to get rid of pre-declaring
167 the array sizes? I am not comfortable enough with this
168 subject to attempt it myself and hope it to stand the test
169 of time.
170 */
171 int
172 execute_perl(const char *function, int argc, char **args)
173 {
174 int count = 0, i, ret_value = 1;
175 SV *sv_args[argc];
176 STRLEN na;
177 dSP;
178 PERL_SET_CONTEXT(my_perl);
179 /*
180 * Set up the perl environment, push arguments onto the
181 * perl stack, then call the given function
182 */
183 SPAGAIN;
184 ENTER;
185 SAVETMPS;
186 PUSHMARK(sp);
187
188 for (i = 0; i < argc; i++) {
189 if (args[i]) {
190 sv_args[i] = sv_2mortal(newSVpv(args[i], 0));
191 XPUSHs(sv_args[i]);
192 }
193 }
194
195 PUTBACK;
196 PERL_SET_CONTEXT(my_perl);
197 count = call_pv(function, G_EVAL | G_SCALAR);
198 SPAGAIN;
199
200 /*
201 * Check for "die," make sure we have 1 argument, and set our
202 * return value.
203 */
204 if (SvTRUE(ERRSV)) {
205 gaim_debug(GAIM_DEBUG_ERROR, "perl",
206 "Perl function %s exited abnormally: %s\n",
207 function, SvPV(ERRSV, na));
208 POPs;
209 } else if (count != 1) {
210 /*
211 * This should NEVER happen. G_SCALAR ensures that we WILL
212 * have 1 parameter.
213 */
214 gaim_debug(GAIM_DEBUG_ERROR, "perl",
215 "Perl error from %s: expected 1 return value, "
216 "but got %d\n", function, count);
217 } else
218 ret_value = POPi;
219
220 /* Check for changed arguments */
221 for (i = 0; i < argc; i++) {
222 if (args[i] && strcmp(args[i], SvPVX(sv_args[i]))) {
223 /*
224 * Shizzel. So the perl script changed one of the parameters,
225 * and we want this change to affect the original parameters.
226 * args[i] is just a temporary little list of pointers. We don't
227 * want to free args[i] here because the new parameter doesn't
228 * overwrite the data that args[i] points to. That is done by
229 * the function that called execute_perl. I'm not explaining this
230 * very well. See, it's aggregate... Oh, but if 2 perl scripts
231 * both modify the data, _that's_ a memleak. This is really kind
232 * of hackish. I should fix it. Look how long this comment is.
233 * Holy crap.
234 */
235 args[i] = g_strdup(SvPV(sv_args[i], na));
236 }
237 }
238
239 PUTBACK;
240 FREETMPS;
241 LEAVE;
242
243 return ret_value;
244 }
245
246 #if 0
247 gboolean
248 gaim_perl_value_from_sv(GaimValue *value, SV *sv)
249 {
250 switch (gaim_value_get_type(value))
251 {
252 case GAIM_TYPE_CHAR:
253 if ((tmp = SvGChar(sv)) != NULL)
254 gaim_value_set_char(value, tmp[0]);
255 else
256 return FALSE;
257 break;
258
259 case GAIM_TYPE_UCHAR:
260 if ((tmp = SvPV_nolen(sv)) != NULL)
261 gaim_value_set_uchar(value, tmp[0]);
262 else
263 return FALSE;
264 break;
265
266 case GAIM_TYPE_BOOLEAN:
267 gaim_value_set_boolean(value, SvTRUE(sv));
268 break;
269
270 case GAIM_TYPE_INT:
271 gaim_value_set_int(value, SvIV(sv));
272 break;
273
274 case GAIM_TYPE_UINT:
275 gaim_value_set_uint(value, SvIV(sv));
276 break;
277
278 case GAIM_TYPE_LONG:
279 gaim_value_set_long(value, SvIV(sv));
280 break;
281
282 case GAIM_TYPE_ULONG:
283 gaim_value_set_ulong(value, SvIV(sv));
284 break;
285
286 case GAIM_TYPE_INT64:
287 gaim_value_set_int64(value, SvIV(sv));
288 break;
289
290 case GAIM_TYPE_UINT64:
291 gaim_value_set_uint64(value, SvIV(sv));
292 break;
293
294 case GAIM_TYPE_STRING:
295 gaim_value_set_string(value, SvGChar(sv));
296 break;
297
298 case GAIM_TYPE_POINTER:
299 gaim_value_set_pointer(value, (void *)SvIV(sv));
300 break;
301
302 case GAIM_TYPE_BOXED:
303 if (!strcmp(gaim_value_get_specific_type(value), "SV"))
304 gaim_value_set_boxed(value, (sv == &PL_sv_undef ? NULL : sv));
305 else
306 gaim_value_set_boxed(value, sv);
307 break;
308
309 default:
310 return FALSE;
311 }
312
313 return TRUE;
314 }
315
316 SV *
317 gaim_perl_sv_from_value(const GaimValue *value, va_list list)
318 {
319 switch (gaim_value_get_type(value))
320 {
321 case GAIM_TYPE_BOOLEAN:
322 return newSViv(gaim_value_get_boolean(value));
323 break;
324
325 case GAIM_TYPE_INT:
326 return newSViv(gaim_value_get_int(value));
327 break;
328
329 case GAIM_TYPE_UINT:
330 return newSVuv(gaim_value_get_uint(value));
331 break;
332
333 case GAIM_TYPE_LONG:
334 return newSViv(gaim_value_get_long(value));
335 break;
336
337 case GAIM_TYPE_ULONG:
338 return newSVuv(gaim_value_get_ulong(value));
339 break;
340
341 case GAIM_TYPE_INT64:
342 return newSViv(gaim_value_get_int64(value));
343 break;
344
345 case GAIM_TYPE_UINT64:
346 return newSVuv(gaim_value_get_int64(value));
347 break;
348
349 case GAIM_TYPE_STRING:
350 return newSVGChar(gaim_value_get_string(value));
351 break;
352
353 case GAIM_TYPE_POINTER:
354 return newSViv((IV)gaim_value_get_pointer(value));
355 break;
356
357 case GAIM_TYPE_BOXED:
358 if (!strcmp(gaim_value_get_specific_type(value), "SV"))
359 {
360 SV *sv = (SV *)gaim_perl_get_boxed(value);
361
362 return (sv == NULL ? &PL_sv_undef : sv);
363 }
364
365 /* Uh.. I dunno. Try this? */
366 return sv_2mortal(gaim_perl_bless_object(
367 gaim_perl_get_boxed(value),
368 gaim_value_get_specific_type(value)));
369
370 default:
371 return FALSE;
372 }
373
374 return TRUE;
375 }
376 #endif
377
378 void *
379 gaim_perl_data_from_sv(GaimValue *value, SV *sv)
380 {
381 STRLEN na;
382
383 switch (gaim_value_get_type(value)) {
384 case GAIM_TYPE_BOOLEAN: return (void *)SvIV(sv);
385 case GAIM_TYPE_INT: return (void *)SvIV(sv);
386 case GAIM_TYPE_UINT: return (void *)SvUV(sv);
387 case GAIM_TYPE_LONG: return (void *)SvIV(sv);
388 case GAIM_TYPE_ULONG: return (void *)SvUV(sv);
389 case GAIM_TYPE_INT64: return (void *)SvIV(sv);
390 case GAIM_TYPE_UINT64: return (void *)SvUV(sv);
391 case GAIM_TYPE_STRING: return g_strdup((void *)SvPV(sv, na));
392 case GAIM_TYPE_POINTER: return (void *)SvIV(sv);
393 case GAIM_TYPE_BOXED: return (void *)SvIV(sv);
394
395 default:
396 return NULL;
397 }
398
399 return NULL;
400 }
401
402 static SV *
403 gaim_perl_sv_from_subtype(const GaimValue *value, void *arg)
404 {
405 const char *stash = NULL;
406
407 switch (gaim_value_get_subtype(value)) {
408 case GAIM_SUBTYPE_ACCOUNT:
409 stash = "Gaim::Account";
410 break;
411 case GAIM_SUBTYPE_BLIST:
412 stash = "Gaim::BuddyList";
413 break;
414 case GAIM_SUBTYPE_BLIST_BUDDY:
415 stash = "Gaim::BuddyList::Buddy";
416 break;
417 case GAIM_SUBTYPE_BLIST_GROUP:
418 stash = "Gaim::BuddyList::Group";
419 break;
420 case GAIM_SUBTYPE_BLIST_CHAT:
421 stash = "Gaim::BuddyList::Chat";
422 break;
423 case GAIM_SUBTYPE_BUDDY_ICON:
424 stash = "Gaim::Buddy::Icon";
425 break;
426 case GAIM_SUBTYPE_CONNECTION:
427 stash = "Gaim::Connection";
428 break;
429 case GAIM_SUBTYPE_CONVERSATION:
430 stash = "Gaim::Conversation";
431 break;
432 case GAIM_SUBTYPE_PLUGIN:
433 stash = "Gaim::Plugin";
434 break;
435 case GAIM_SUBTYPE_BLIST_NODE:
436 stash = "Gaim::BuddyList::Node";
437 break;
438 case GAIM_SUBTYPE_CIPHER:
439 stash = "Gaim::Cipher";
440 break;
441 case GAIM_SUBTYPE_STATUS:
442 stash = "Gaim::Status";
443 break;
444 case GAIM_SUBTYPE_LOG:
445 stash = "Gaim::Log";
446 break;
447 case GAIM_SUBTYPE_XFER:
448 stash = "Gaim::Xfer";
449 break;
450 case GAIM_SUBTYPE_XMLNODE:
451 stash = "Gaim::XMLNode";
452 break;
453
454 default:
455 stash = "Gaim"; /* ? */
456 }
457
458 return sv_2mortal(gaim_perl_bless_object(arg, stash));
459 }
460
461 SV *
462 gaim_perl_sv_from_vargs(const GaimValue *value, va_list *args, void ***copy_arg)
463 {
464 if (gaim_value_is_outgoing(value)) {
465 switch (gaim_value_get_type(value)) {
466 case GAIM_TYPE_SUBTYPE:
467 if ((*copy_arg = va_arg(*args, void **)) == NULL)
468 return &PL_sv_undef;
469
470 return gaim_perl_sv_from_subtype(value, *(void **)*copy_arg);
471
472 case GAIM_TYPE_BOOLEAN:
473 if ((*copy_arg = (void *)va_arg(*args, gboolean *)) == NULL)
474 return &PL_sv_undef;
475
476 return newSViv(*(gboolean *)*copy_arg);
477
478 case GAIM_TYPE_INT:
479 if ((*copy_arg = (void *)va_arg(*args, int *)) == NULL)
480 return &PL_sv_undef;
481
482 return newSViv(*(int *)*copy_arg);
483
484 case GAIM_TYPE_UINT:
485 if ((*copy_arg = (void *)va_arg(*args, unsigned int *)) == NULL)
486 return &PL_sv_undef;
487
488 return newSVuv(*(unsigned int *)*copy_arg);
489
490 case GAIM_TYPE_LONG:
491 if ((*copy_arg = (void *)va_arg(*args, long *)) == NULL)
492 return &PL_sv_undef;
493
494 return newSViv(*(long *)*copy_arg);
495
496 case GAIM_TYPE_ULONG:
497 if ((*copy_arg = (void *)va_arg(*args,
498 unsigned long *)) == NULL)
499 return &PL_sv_undef;
500
501 return newSVuv(*(unsigned long *)*copy_arg);
502
503 case GAIM_TYPE_INT64:
504 if ((*copy_arg = (void *)va_arg(*args, gint64 *)) == NULL)
505 return &PL_sv_undef;
506
507 return newSViv(*(gint64 *)*copy_arg);
508
509 case GAIM_TYPE_UINT64:
510 if ((*copy_arg = (void *)va_arg(*args, guint64 *)) == NULL)
511 return &PL_sv_undef;
512
513 return newSVuv(*(guint64 *)*copy_arg);
514
515 case GAIM_TYPE_STRING:
516 if ((*copy_arg = (void *)va_arg(*args, char **)) == NULL)
517 return &PL_sv_undef;
518
519 return newSVGChar(*(char **)*copy_arg);
520
521 case GAIM_TYPE_POINTER:
522 if ((*copy_arg = va_arg(*args, void **)) == NULL)
523 return &PL_sv_undef;
524
525 return newSViv((IV)*(void **)*copy_arg);
526
527 case GAIM_TYPE_BOXED:
528 /* Uh.. I dunno. Try this? */
529 if ((*copy_arg = va_arg(*args, void **)) == NULL)
530 return &PL_sv_undef;
531
532 return sv_2mortal(gaim_perl_bless_object(
533 *(void **)*copy_arg,
534 gaim_value_get_specific_type(value)));
535
536 default:
537 /* If this happens, things are going to get screwed up... */
538 return NULL;
539 }
540 } else {
541 switch (gaim_value_get_type(value)) {
542 case GAIM_TYPE_SUBTYPE:
543 if ((*copy_arg = va_arg(*args, void *)) == NULL)
544 return &PL_sv_undef;
545
546 return gaim_perl_sv_from_subtype(value, *copy_arg);
547
548 case GAIM_TYPE_BOOLEAN:
549 *copy_arg = GINT_TO_POINTER( va_arg(*args, gboolean) );
550
551 return newSViv((gboolean)GPOINTER_TO_INT(*copy_arg));
552
553 case GAIM_TYPE_INT:
554 *copy_arg = GINT_TO_POINTER( va_arg(*args, int) );
555
556 return newSViv(GPOINTER_TO_INT(*copy_arg));
557
558 case GAIM_TYPE_UINT:
559 *copy_arg = GUINT_TO_POINTER(va_arg(*args, unsigned int));
560
561 return newSVuv(GPOINTER_TO_UINT(*copy_arg));
562
563 case GAIM_TYPE_LONG:
564 *copy_arg = (void *)va_arg(*args, long);
565
566 return newSViv((long)*copy_arg);
567
568 case GAIM_TYPE_ULONG:
569 *copy_arg = (void *)va_arg(*args, unsigned long);
570
571 return newSVuv((unsigned long)*copy_arg);
572
573 case GAIM_TYPE_INT64:
574 #if 0
575 /* XXX This yells and complains. */
576 *copy_arg = va_arg(*args, gint64);
577
578 return newSViv(*copy_arg);
579 #endif
580 break;
581
582 case GAIM_TYPE_UINT64:
583 /* XXX This also yells and complains. */
584 #if 0
585 *copy_arg = (void *)va_arg(*args, guint64);
586
587 return newSVuv(*copy_arg);
588 #endif
589 break;
590
591 case GAIM_TYPE_STRING:
592 if ((*copy_arg = (void *)va_arg(*args, char *)) == NULL)
593 return &PL_sv_undef;
594
595 return newSVGChar((char *)*copy_arg);
596
597 case GAIM_TYPE_POINTER:
598 if ((*copy_arg = (void *)va_arg(*args, void *)) == NULL)
599 return &PL_sv_undef;
600
601 return newSViv((IV)*copy_arg);
602
603 case GAIM_TYPE_BOXED:
604 /* Uh.. I dunno. Try this? */
605 if ((*copy_arg = (void *)va_arg(*args, void *)) == NULL)
606 return &PL_sv_undef;
607
608 return sv_2mortal(gaim_perl_bless_object(*copy_arg,
609 gaim_value_get_specific_type(value)));
610
611 default:
612 /* If this happens, things are going to get screwed up... */
613 return NULL;
614 }
615 }
616
617 return NULL;
618 }

Mercurial Repository: pidgin3

mercurial