Mercurial > pidgin3 / file comparison

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

libpurple/plugins/perl/perl-common.c

branch
cpw.khc.msnp14
changeset 20478
46933dc62880
parent 20472
6a6d2ef151e6
parent 15884
4de1981757fc
child 20481
65485e2ed8a3
equal deleted inserted replaced
20476:198222e01a7d 20478:46933dc62880
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 purple_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 purple_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, "_purple", 5, create_sv_ptr(object), 0);
84
85 return sv_bless(newRV_noinc((SV *)hv), stash);
86 }
87
88 gboolean
89 purple_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, "_purple", 5, 0);
98
99 if (sv != NULL)
100 return TRUE;
101 }
102
103 return FALSE;
104 }
105
106 void *
107 purple_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, "_purple", 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 purple_debug(PURPLE_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 purple_debug(PURPLE_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 purple_perl_value_from_sv(PurpleValue *value, SV *sv)
249 {
250 switch (purple_value_get_type(value))
251 {
252 case PURPLE_TYPE_CHAR:
253 if ((tmp = SvGChar(sv)) != NULL)
254 purple_value_set_char(value, tmp[0]);
255 else
256 return FALSE;
257 break;
258
259 case PURPLE_TYPE_UCHAR:
260 if ((tmp = SvPV_nolen(sv)) != NULL)
261 purple_value_set_uchar(value, tmp[0]);
262 else
263 return FALSE;
264 break;
265
266 case PURPLE_TYPE_BOOLEAN:
267 purple_value_set_boolean(value, SvTRUE(sv));
268 break;
269
270 case PURPLE_TYPE_INT:
271 purple_value_set_int(value, SvIV(sv));
272 break;
273
274 case PURPLE_TYPE_UINT:
275 purple_value_set_uint(value, SvIV(sv));
276 break;
277
278 case PURPLE_TYPE_LONG:
279 purple_value_set_long(value, SvIV(sv));
280 break;
281
282 case PURPLE_TYPE_ULONG:
283 purple_value_set_ulong(value, SvIV(sv));
284 break;
285
286 case PURPLE_TYPE_INT64:
287 purple_value_set_int64(value, SvIV(sv));
288 break;
289
290 case PURPLE_TYPE_UINT64:
291 purple_value_set_uint64(value, SvIV(sv));
292 break;
293
294 case PURPLE_TYPE_STRING:
295 purple_value_set_string(value, SvGChar(sv));
296 break;
297
298 case PURPLE_TYPE_POINTER:
299 purple_value_set_pointer(value, (void *)SvIV(sv));
300 break;
301
302 case PURPLE_TYPE_BOXED:
303 if (!strcmp(purple_value_get_specific_type(value), "SV"))
304 purple_value_set_boxed(value, (sv == &PL_sv_undef ? NULL : sv));
305 else
306 purple_value_set_boxed(value, sv);
307 break;
308
309 default:
310 return FALSE;
311 }
312
313 return TRUE;
314 }
315
316 SV *
317 purple_perl_sv_from_value(const PurpleValue *value, va_list list)
318 {
319 switch (purple_value_get_type(value))
320 {
321 case PURPLE_TYPE_BOOLEAN:
322 return newSViv(purple_value_get_boolean(value));
323 break;
324
325 case PURPLE_TYPE_INT:
326 return newSViv(purple_value_get_int(value));
327 break;
328
329 case PURPLE_TYPE_UINT:
330 return newSVuv(purple_value_get_uint(value));
331 break;
332
333 case PURPLE_TYPE_LONG:
334 return newSViv(purple_value_get_long(value));
335 break;
336
337 case PURPLE_TYPE_ULONG:
338 return newSVuv(purple_value_get_ulong(value));
339 break;
340
341 case PURPLE_TYPE_INT64:
342 return newSViv(purple_value_get_int64(value));
343 break;
344
345 case PURPLE_TYPE_UINT64:
346 return newSVuv(purple_value_get_int64(value));
347 break;
348
349 case PURPLE_TYPE_STRING:
350 return newSVGChar(purple_value_get_string(value));
351 break;
352
353 case PURPLE_TYPE_POINTER:
354 return newSViv((IV)purple_value_get_pointer(value));
355 break;
356
357 case PURPLE_TYPE_BOXED:
358 if (!strcmp(purple_value_get_specific_type(value), "SV"))
359 {
360 SV *sv = (SV *)purple_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(purple_perl_bless_object(
367 purple_perl_get_boxed(value),
368 purple_value_get_specific_type(value)));
369
370 default:
371 return FALSE;
372 }
373
374 return TRUE;
375 }
376 #endif
377
378 void *
379 purple_perl_data_from_sv(PurpleValue *value, SV *sv)
380 {
381 STRLEN na;
382
383 switch (purple_value_get_type(value)) {
384 case PURPLE_TYPE_BOOLEAN: return (void *)SvIV(sv);
385 case PURPLE_TYPE_INT: return (void *)SvIV(sv);
386 case PURPLE_TYPE_UINT: return (void *)SvUV(sv);
387 case PURPLE_TYPE_LONG: return (void *)SvIV(sv);
388 case PURPLE_TYPE_ULONG: return (void *)SvUV(sv);
389 case PURPLE_TYPE_INT64: return (void *)SvIV(sv);
390 case PURPLE_TYPE_UINT64: return (void *)SvUV(sv);
391 case PURPLE_TYPE_STRING: return g_strdup((void *)SvPV(sv, na));
392 case PURPLE_TYPE_POINTER: return (void *)SvIV(sv);
393 case PURPLE_TYPE_BOXED: return (void *)SvIV(sv);
394
395 default:
396 return NULL;
397 }
398
399 return NULL;
400 }
401
402 static SV *
403 purple_perl_sv_from_subtype(const PurpleValue *value, void *arg)
404 {
405 const char *stash = NULL;
406
407 switch (purple_value_get_subtype(value)) {
408 case PURPLE_SUBTYPE_ACCOUNT:
409 stash = "Purple::Account";
410 break;
411 case PURPLE_SUBTYPE_BLIST:
412 stash = "Purple::BuddyList";
413 break;
414 case PURPLE_SUBTYPE_BLIST_BUDDY:
415 stash = "Purple::BuddyList::Buddy";
416 break;
417 case PURPLE_SUBTYPE_BLIST_GROUP:
418 stash = "Purple::BuddyList::Group";
419 break;
420 case PURPLE_SUBTYPE_BLIST_CHAT:
421 stash = "Purple::BuddyList::Chat";
422 break;
423 case PURPLE_SUBTYPE_BUDDY_ICON:
424 stash = "Purple::Buddy::Icon";
425 break;
426 case PURPLE_SUBTYPE_CONNECTION:
427 stash = "Purple::Connection";
428 break;
429 case PURPLE_SUBTYPE_CONVERSATION:
430 stash = "Purple::Conversation";
431 break;
432 case PURPLE_SUBTYPE_PLUGIN:
433 stash = "Purple::Plugin";
434 break;
435 case PURPLE_SUBTYPE_BLIST_NODE:
436 stash = "Purple::BuddyList::Node";
437 break;
438 case PURPLE_SUBTYPE_CIPHER:
439 stash = "Purple::Cipher";
440 break;
441 case PURPLE_SUBTYPE_STATUS:
442 stash = "Purple::Status";
443 break;
444 case PURPLE_SUBTYPE_LOG:
445 stash = "Purple::Log";
446 break;
447 case PURPLE_SUBTYPE_XFER:
448 stash = "Purple::Xfer";
449 break;
450 case PURPLE_SUBTYPE_XMLNODE:
451 stash = "Purple::XMLNode";
452 break;
453
454 default:
455 stash = "Purple"; /* ? */
456 }
457
458 return sv_2mortal(purple_perl_bless_object(arg, stash));
459 }
460
461 SV *
462 purple_perl_sv_from_vargs(const PurpleValue *value, va_list *args, void ***copy_arg)
463 {
464 if (purple_value_is_outgoing(value)) {
465 switch (purple_value_get_type(value)) {
466 case PURPLE_TYPE_SUBTYPE:
467 if ((*copy_arg = va_arg(*args, void **)) == NULL)
468 return &PL_sv_undef;
469
470 return purple_perl_sv_from_subtype(value, *(void **)*copy_arg);
471
472 case PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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(purple_perl_bless_object(
533 *(void **)*copy_arg,
534 purple_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 (purple_value_get_type(value)) {
542 case PURPLE_TYPE_SUBTYPE:
543 if ((*copy_arg = va_arg(*args, void *)) == NULL)
544 return &PL_sv_undef;
545
546 return purple_perl_sv_from_subtype(value, *copy_arg);
547
548 case PURPLE_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 PURPLE_TYPE_INT:
554 *copy_arg = GINT_TO_POINTER( va_arg(*args, int) );
555
556 return newSViv(GPOINTER_TO_INT(*copy_arg));
557
558 case PURPLE_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 PURPLE_TYPE_LONG:
564 *copy_arg = (void *)va_arg(*args, long);
565
566 return newSViv((long)*copy_arg);
567
568 case PURPLE_TYPE_ULONG:
569 *copy_arg = (void *)va_arg(*args, unsigned long);
570
571 return newSVuv((unsigned long)*copy_arg);
572
573 case PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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 PURPLE_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(purple_perl_bless_object(*copy_arg,
609 purple_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