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
purple_perl_normalize_script_name(char * name)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
magic_free_object(pTHX_ SV * sv,MAGIC * mg)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 0, 0, 0, 0, magic_free_object, 0, 0
36 #if PERL_API_REVISION > 5 || (PERL_API_REVISION == 5 && PERL_API_VERSION >= 10)
37 , 0
38 #endif
39 };
40
41 static SV *
create_sv_ptr(void * object)42 create_sv_ptr(void *object)
43 {
44 SV *sv;
45
46 sv = newSViv((IV)object);
47
48 sv_magic(sv, NULL, '~', NULL, 0);
49
50 SvMAGIC(sv)->mg_private = 0x1551; /* HF */
51 SvMAGIC(sv)->mg_virtual = &vtbl_free_object;
52
53 return sv;
54 }
55
56 SV *
newSVGChar(const char * str)57 newSVGChar(const char *str)
58 {
59 SV *sv;
60
61 if (str == NULL)
62 return &PL_sv_undef;
63
64 sv = newSVpv(str, 0);
65 SvUTF8_on(sv);
66
67 return sv;
68 }
69
70 SV *
purple_perl_bless_object(void * object,const char * stash_name)71 purple_perl_bless_object(void *object, const char *stash_name)
72 {
73 HV *stash;
74 HV *hv;
75
76 if (object == NULL)
77 return NULL;
78
79 if (object_stashes == NULL) {
80 object_stashes = g_hash_table_new(g_direct_hash, g_direct_equal);
81 }
82
83 stash = gv_stashpv(stash_name, 1);
84
85 hv = newHV();
86 if (hv_store(hv, "_purple", 7, create_sv_ptr(object), 0) == NULL)
87 purple_debug_error("perl", "hv_store failed\n");
88
89 return sv_bless(newRV_noinc((SV *)hv), stash);
90 }
91
92 gboolean
purple_perl_is_ref_object(SV * o)93 purple_perl_is_ref_object(SV *o)
94 {
95 SV **sv;
96 HV *hv;
97
98 hv = hvref(o);
99
100 if (hv != NULL) {
101 sv = hv_fetch(hv, "_purple", 7, 0);
102
103 if (sv != NULL)
104 return TRUE;
105 }
106
107 return FALSE;
108 }
109
110 void *
purple_perl_ref_object(SV * o)111 purple_perl_ref_object(SV *o)
112 {
113 SV **sv;
114 HV *hv;
115 void *p;
116
117 if (o == NULL)
118 return NULL;
119
120 hv = hvref(o);
121
122 if (hv == NULL)
123 return NULL;
124
125 sv = hv_fetch(hv, "_purple", 7, 0);
126
127 if (sv == NULL)
128 croak("variable is damaged");
129
130 p = GINT_TO_POINTER(SvIV(*sv));
131
132 return p;
133 }
134
135 /*
136 2003/02/06: execute_perl modified by Mark Doliner <mark@kingant.net>
137 Pass parameters by pushing them onto the stack rather than
138 passing an array of strings. This way, perl scripts can
139 modify the parameters and we can get the changed values
140 and then shoot ourselves. I mean, uh, use them.
141
142 2001/06/14: execute_perl replaced by Martin Persson <mep@passagen.se>
143 previous use of perl_eval leaked memory, replaced with
144 a version that uses perl_call instead
145
146 30/11/2002: execute_perl modified by Eric Timme <timothy@voidnet.com>
147 args changed to char** so that we can have preparsed
148 arguments again, and many headaches ensued! This essentially
149 means we replaced one hacked method with a messier hacked
150 method out of perceived necessity. Formerly execute_perl
151 required a single char_ptr, and it would insert it into an
152 array of character pointers and NULL terminate the new array.
153 Now we have to pass in pre-terminated character pointer arrays
154 to accomodate functions that want to pass in multiple arguments.
155
156 Previously arguments were preparsed because an argument list
157 was constructed in the form 'arg one','arg two' and was
158 executed via a call like &funcname(arglist) (see .59.x), so
159 the arglist was magically pre-parsed because of the method.
160 With Martin Persson's change to perl_call we now need to
161 use a null terminated list of character pointers for arguments
162 if we wish them to be parsed. Lacking a better way to allow
163 for both single arguments and many I created a NULL terminated
164 array in every function that called execute_perl and passed
165 that list into the function. In the former version a single
166 character pointer was passed in, and was placed into an array
167 of character pointers with two elements, with a NULL element
168 tacked onto the back, but this method no longer seemed prudent.
169
170 Enhancements in the future might be to get rid of pre-declaring
171 the array sizes? I am not comfortable enough with this
172 subject to attempt it myself and hope it to stand the test
173 of time.
174 */
175 int
execute_perl(const char * function,int argc,char ** args)176 execute_perl(const char *function, int argc, char **args)
177 {
178 int count = 0, i, ret_value = 1;
179 SV *sv_args[argc];
180 dSP;
181 PERL_SET_CONTEXT(my_perl);
182 /*
183 * Set up the perl environment, push arguments onto the
184 * perl stack, then call the given function
185 */
186 SPAGAIN;
187 ENTER;
188 SAVETMPS;
189 PUSHMARK(sp);
190
191 for (i = 0; i < argc; i++) {
192 if (args[i]) {
193 sv_args[i] = sv_2mortal(newSVpv(args[i], 0));
194 XPUSHs(sv_args[i]);
195 } else
196 sv_args[i] = NULL;
197 }
198
199 PUTBACK;
200 PERL_SET_CONTEXT(my_perl);
201 count = call_pv(function, G_EVAL | G_SCALAR);
202 SPAGAIN;
203
204 /*
205 * Check for "die," make sure we have 1 argument, and set our
206 * return value.
207 */
208 if (SvTRUE(ERRSV)) {
209 purple_debug(PURPLE_DEBUG_ERROR, "perl",
210 "Perl function %s exited abnormally: %s\n",
211 function, SvPVutf8_nolen(ERRSV));
212 (void)POPs;
213 } else if (count != 1) {
214 /*
215 * This should NEVER happen. G_SCALAR ensures that we WILL
216 * have 1 parameter.
217 */
218 purple_debug(PURPLE_DEBUG_ERROR, "perl",
219 "Perl error from %s: expected 1 return value, "
220 "but got %d\n", function, count);
221 } else
222 ret_value = POPi;
223
224 /* Check for changed arguments */
225 for (i = 0; i < argc; i++) {
226 if (args[i] && !purple_strequal(args[i], SvPVX(sv_args[i]))) {
227 /*
228 * Shizzel. So the perl script changed one of the parameters,
229 * and we want this change to affect the original parameters.
230 * args[i] is just a temporary little list of pointers. We don't
231 * want to free args[i] here because the new parameter doesn't
232 * overwrite the data that args[i] points to. That is done by
233 * the function that called execute_perl. I'm not explaining this
234 * very well. See, it's aggregate... Oh, but if 2 perl scripts
235 * both modify the data, _that's_ a memleak. This is really kind
236 * of hackish. I should fix it. Look how long this comment is.
237 * Holy crap.
238 */
239 args[i] = g_strdup(SvPVutf8_nolen(sv_args[i]));
240 }
241 }
242
243 PUTBACK;
244 FREETMPS;
245 LEAVE;
246
247 return ret_value;
248 }
249
250 #if 0
251 gboolean
252 purple_perl_value_from_sv(PurpleValue *value, SV *sv)
253 {
254 switch (purple_value_get_type(value))
255 {
256 case PURPLE_TYPE_CHAR:
257 if ((tmp = SvGChar(sv)) != NULL)
258 purple_value_set_char(value, tmp[0]);
259 else
260 return FALSE;
261 break;
262
263 case PURPLE_TYPE_UCHAR:
264 if ((tmp = SvPV_nolen(sv)) != NULL)
265 purple_value_set_uchar(value, tmp[0]);
266 else
267 return FALSE;
268 break;
269
270 case PURPLE_TYPE_BOOLEAN:
271 purple_value_set_boolean(value, SvTRUE(sv));
272 break;
273
274 case PURPLE_TYPE_INT:
275 purple_value_set_int(value, SvIV(sv));
276 break;
277
278 case PURPLE_TYPE_UINT:
279 purple_value_set_uint(value, SvIV(sv));
280 break;
281
282 case PURPLE_TYPE_LONG:
283 purple_value_set_long(value, SvIV(sv));
284 break;
285
286 case PURPLE_TYPE_ULONG:
287 purple_value_set_ulong(value, SvIV(sv));
288 break;
289
290 case PURPLE_TYPE_INT64:
291 purple_value_set_int64(value, SvIV(sv));
292 break;
293
294 case PURPLE_TYPE_UINT64:
295 purple_value_set_uint64(value, SvIV(sv));
296 break;
297
298 case PURPLE_TYPE_STRING:
299 purple_value_set_string(value, SvGChar(sv));
300 break;
301
302 case PURPLE_TYPE_POINTER:
303 purple_value_set_pointer(value, (void *)SvIV(sv));
304 break;
305
306 case PURPLE_TYPE_BOXED:
307 if (purple_strequal(purple_value_get_specific_type(value), "SV"))
308 purple_value_set_boxed(value, (sv == &PL_sv_undef ? NULL : sv));
309 else
310 purple_value_set_boxed(value, sv);
311 break;
312
313 default:
314 return FALSE;
315 }
316
317 return TRUE;
318 }
319
320 SV *
321 purple_perl_sv_from_value(const PurpleValue *value, va_list list)
322 {
323 switch (purple_value_get_type(value))
324 {
325 case PURPLE_TYPE_BOOLEAN:
326 return newSViv(purple_value_get_boolean(value));
327 break;
328
329 case PURPLE_TYPE_INT:
330 return newSViv(purple_value_get_int(value));
331 break;
332
333 case PURPLE_TYPE_UINT:
334 return newSVuv(purple_value_get_uint(value));
335 break;
336
337 case PURPLE_TYPE_LONG:
338 return newSViv(purple_value_get_long(value));
339 break;
340
341 case PURPLE_TYPE_ULONG:
342 return newSVuv(purple_value_get_ulong(value));
343 break;
344
345 case PURPLE_TYPE_INT64:
346 return newSViv(purple_value_get_int64(value));
347 break;
348
349 case PURPLE_TYPE_UINT64:
350 return newSVuv(purple_value_get_int64(value));
351 break;
352
353 case PURPLE_TYPE_STRING:
354 return newSVGChar(purple_value_get_string(value));
355 break;
356
357 case PURPLE_TYPE_POINTER:
358 return newSViv((IV)purple_value_get_pointer(value));
359 break;
360
361 case PURPLE_TYPE_BOXED:
362 if (purple_strequal(purple_value_get_specific_type(value), "SV"))
363 {
364 SV *sv = (SV *)purple_perl_get_boxed(value);
365
366 return (sv == NULL ? &PL_sv_undef : sv);
367 }
368
369 /* Uh.. I dunno. Try this? */
370 return sv_2mortal(purple_perl_bless_object(
371 purple_perl_get_boxed(value),
372 purple_value_get_specific_type(value)));
373
374 default:
375 return FALSE;
376 }
377
378 return TRUE;
379 }
380 #endif
381
382 void *
purple_perl_data_from_sv(PurpleValue * value,SV * sv)383 purple_perl_data_from_sv(PurpleValue *value, SV *sv)
384 {
385
386 switch (purple_value_get_type(value)) {
387 case PURPLE_TYPE_BOOLEAN: return (void *)SvIV(sv);
388 case PURPLE_TYPE_INT: return (void *)SvIV(sv);
389 case PURPLE_TYPE_UINT: return (void *)SvUV(sv);
390 case PURPLE_TYPE_LONG: return (void *)SvIV(sv);
391 case PURPLE_TYPE_ULONG: return (void *)SvUV(sv);
392 case PURPLE_TYPE_INT64: return (void *)SvIV(sv);
393 case PURPLE_TYPE_UINT64: return (void *)SvUV(sv);
394 case PURPLE_TYPE_STRING: return g_strdup(SvPVutf8_nolen(sv));
395 case PURPLE_TYPE_POINTER: return (void *)SvIV(sv);
396 case PURPLE_TYPE_BOXED: return (void *)SvIV(sv);
397
398 default:
399 return NULL;
400 }
401
402 return NULL;
403 }
404
405 static SV *
purple_perl_sv_from_subtype(const PurpleValue * value,void * arg)406 purple_perl_sv_from_subtype(const PurpleValue *value, void *arg)
407 {
408 const char *stash = "Purple"; /* ? */
409
410 switch (purple_value_get_subtype(value)) {
411 case PURPLE_SUBTYPE_ACCOUNT:
412 stash = "Purple::Account";
413 break;
414 case PURPLE_SUBTYPE_BLIST:
415 stash = "Purple::BuddyList";
416 break;
417 case PURPLE_SUBTYPE_BLIST_BUDDY:
418 stash = "Purple::BuddyList::Buddy";
419 break;
420 case PURPLE_SUBTYPE_BLIST_GROUP:
421 stash = "Purple::BuddyList::Group";
422 break;
423 case PURPLE_SUBTYPE_BLIST_CHAT:
424 stash = "Purple::BuddyList::Chat";
425 break;
426 case PURPLE_SUBTYPE_BUDDY_ICON:
427 stash = "Purple::Buddy::Icon";
428 break;
429 case PURPLE_SUBTYPE_CONNECTION:
430 stash = "Purple::Connection";
431 break;
432 case PURPLE_SUBTYPE_CONVERSATION:
433 stash = "Purple::Conversation";
434 break;
435 case PURPLE_SUBTYPE_PLUGIN:
436 stash = "Purple::Plugin";
437 break;
438 case PURPLE_SUBTYPE_BLIST_NODE:
439 stash = "Purple::BuddyList::Node";
440 break;
441 case PURPLE_SUBTYPE_CIPHER:
442 stash = "Purple::Cipher";
443 break;
444 case PURPLE_SUBTYPE_STATUS:
445 stash = "Purple::Status";
446 break;
447 case PURPLE_SUBTYPE_SAVEDSTATUS:
448 stash = "Purple::SavedStatus";
449 break;
450 case PURPLE_SUBTYPE_LOG:
451 stash = "Purple::Log";
452 break;
453 case PURPLE_SUBTYPE_XFER:
454 stash = "Purple::Xfer";
455 break;
456 case PURPLE_SUBTYPE_XMLNODE:
457 stash = "Purple::XMLNode";
458 break;
459 case PURPLE_SUBTYPE_USERINFO:
460 stash = "Purple::NotifyUserInfo";
461 break;
462 case PURPLE_SUBTYPE_STORED_IMAGE:
463 stash = "Purple::StoredImage";
464 break;
465 case PURPLE_SUBTYPE_CERTIFICATEPOOL:
466 stash = "Purple::Certificate::Pool";
467 break;
468 case PURPLE_SUBTYPE_UNKNOWN:
469 stash = "Purple::Unknown";
470 break;
471 }
472
473 return sv_2mortal(purple_perl_bless_object(arg, stash));
474 }
475
476 SV *
purple_perl_sv_from_vargs(const PurpleValue * value,va_list * args,void *** copy_arg)477 purple_perl_sv_from_vargs(const PurpleValue *value, va_list *args, void ***copy_arg)
478 {
479 if (purple_value_is_outgoing(value)) {
480 switch (purple_value_get_type(value)) {
481 case PURPLE_TYPE_SUBTYPE:
482 if ((*copy_arg = va_arg(*args, void **)) == NULL)
483 return &PL_sv_undef;
484
485 return purple_perl_sv_from_subtype(value, *(void **)*copy_arg);
486
487 case PURPLE_TYPE_BOOLEAN:
488 if ((*copy_arg = (void *)va_arg(*args, gboolean *)) == NULL)
489 return &PL_sv_undef;
490
491 return newSViv(*(gboolean *)*copy_arg);
492
493 case PURPLE_TYPE_INT:
494 if ((*copy_arg = (void *)va_arg(*args, int *)) == NULL)
495 return &PL_sv_undef;
496
497 return newSViv(*(int *)*copy_arg);
498
499 case PURPLE_TYPE_UINT:
500 if ((*copy_arg = (void *)va_arg(*args, unsigned int *)) == NULL)
501 return &PL_sv_undef;
502
503 return newSVuv(*(unsigned int *)*copy_arg);
504
505 case PURPLE_TYPE_LONG:
506 if ((*copy_arg = (void *)va_arg(*args, long *)) == NULL)
507 return &PL_sv_undef;
508
509 return newSViv(*(long *)*copy_arg);
510
511 case PURPLE_TYPE_ULONG:
512 if ((*copy_arg = (void *)va_arg(*args,
513 unsigned long *)) == NULL)
514 return &PL_sv_undef;
515
516 return newSVuv(*(unsigned long *)*copy_arg);
517
518 case PURPLE_TYPE_INT64:
519 if ((*copy_arg = (void *)va_arg(*args, gint64 *)) == NULL)
520 return &PL_sv_undef;
521
522 return newSViv(*(gint64 *)*copy_arg);
523
524 case PURPLE_TYPE_UINT64:
525 if ((*copy_arg = (void *)va_arg(*args, guint64 *)) == NULL)
526 return &PL_sv_undef;
527
528 return newSVuv(*(guint64 *)*copy_arg);
529
530 case PURPLE_TYPE_STRING:
531 if ((*copy_arg = (void *)va_arg(*args, char **)) == NULL)
532 return &PL_sv_undef;
533
534 return newSVGChar(*(char **)*copy_arg);
535
536 case PURPLE_TYPE_POINTER:
537 if ((*copy_arg = va_arg(*args, void **)) == NULL)
538 return &PL_sv_undef;
539
540 return newSViv((IV)*(void **)*copy_arg);
541
542 case PURPLE_TYPE_BOXED:
543 /* Uh.. I dunno. Try this? */
544 if ((*copy_arg = va_arg(*args, void **)) == NULL)
545 return &PL_sv_undef;
546
547 return sv_2mortal(purple_perl_bless_object(
548 *(void **)*copy_arg,
549 purple_value_get_specific_type(value)));
550
551 default:
552 /* If this happens, things are going to get screwed up... */
553 return NULL;
554 }
555 } else {
556 switch (purple_value_get_type(value)) {
557 case PURPLE_TYPE_SUBTYPE:
558 if ((*copy_arg = va_arg(*args, void *)) == NULL)
559 return &PL_sv_undef;
560
561 return purple_perl_sv_from_subtype(value, *copy_arg);
562
563 case PURPLE_TYPE_BOOLEAN:
564 *copy_arg = GINT_TO_POINTER( va_arg(*args, gboolean) );
565
566 return newSViv((gboolean)GPOINTER_TO_INT(*copy_arg));
567
568 case PURPLE_TYPE_INT:
569 *copy_arg = GINT_TO_POINTER( va_arg(*args, int) );
570
571 return newSViv(GPOINTER_TO_INT(*copy_arg));
572
573 case PURPLE_TYPE_UINT:
574 *copy_arg = GUINT_TO_POINTER(va_arg(*args, unsigned int));
575
576 return newSVuv(GPOINTER_TO_UINT(*copy_arg));
577
578 case PURPLE_TYPE_LONG:
579 *copy_arg = (void *)va_arg(*args, long);
580
581 return newSViv((long)*copy_arg);
582
583 case PURPLE_TYPE_ULONG:
584 *copy_arg = (void *)va_arg(*args, unsigned long);
585
586 return newSVuv((unsigned long)*copy_arg);
587
588 case PURPLE_TYPE_INT64:
589 #if 0
590 /* XXX This yells and complains. */
591 *copy_arg = va_arg(*args, gint64);
592
593 return newSViv(*copy_arg);
594 #endif
595 break;
596
597 case PURPLE_TYPE_UINT64:
598 /* XXX This also yells and complains. */
599 #if 0
600 *copy_arg = (void *)va_arg(*args, guint64);
601
602 return newSVuv(*copy_arg);
603 #endif
604 break;
605
606 case PURPLE_TYPE_STRING:
607 if ((*copy_arg = (void *)va_arg(*args, char *)) == NULL)
608 return &PL_sv_undef;
609
610 return newSVGChar((char *)*copy_arg);
611
612 case PURPLE_TYPE_POINTER:
613 if ((*copy_arg = (void *)va_arg(*args, void *)) == NULL)
614 return &PL_sv_undef;
615
616 return newSViv((IV)*copy_arg);
617
618 case PURPLE_TYPE_BOXED:
619 /* Uh.. I dunno. Try this? */
620 if ((*copy_arg = (void *)va_arg(*args, void *)) == NULL)
621 return &PL_sv_undef;
622
623 return sv_2mortal(purple_perl_bless_object(*copy_arg,
624 purple_value_get_specific_type(value)));
625
626 default:
627 /* If this happens, things are going to get screwed up... */
628 return NULL;
629 }
630 }
631
632 return NULL;
633 }
634
purple_perl_sv_from_fun(PurplePlugin * plugin,SV * callback)635 SV *purple_perl_sv_from_fun(PurplePlugin *plugin, SV *callback)
636 {
637 SV *sv = NULL;
638
639 if (SvTYPE(callback) == SVt_RV) {
640 SV *cbsv = SvRV(callback);
641
642 if (SvTYPE(cbsv) == SVt_PVCV) {
643 sv = newSVsv(callback);
644 }
645 } else if (SvTYPE(callback) == SVt_PV) {
646 PurplePerlScript *gps;
647
648 gps = (PurplePerlScript *)PURPLE_PLUGIN_LOADER_INFO(plugin);
649 sv = newSVpvf("%s::%s", gps->package, SvPV_nolen(callback));
650 } else {
651 purple_debug_warning("perl", "Callback not a valid type, only strings and coderefs allowed.\n");
652 }
653
654 return sv;
655 }
656
657