source: perlconfig.c @ 57ad328

Last change on this file since 57ad328 was 57ad328, checked in by Jason Gross <jgross@mit.edu>, 13 years ago
Added support for calling perl subs with various return types
  • Property mode set to 100644
File size: 14.3 KB
Line 
1#define OWL_PERL
2#include "owl.h"
3#include <stdio.h>
4
5extern XS(boot_BarnOwl);
6extern XS(boot_DynaLoader);
7/* extern XS(boot_DBI); */
8
9void owl_perl_xs_init(pTHX) /* noproto */
10{
11  const char *file = __FILE__;
12  dXSUB_SYS;
13  {
14    newXS("BarnOwl::bootstrap", boot_BarnOwl, file);
15    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
16  }
17}
18
19
20CALLER_OWN SV *owl_new_sv(const char * str)
21{
22  SV *ret = newSVpv(str, 0);
23  if (is_utf8_string((const U8 *)str, strlen(str))) {
24    SvUTF8_on(ret);
25  } else {
26    char *escape = owl_escape_highbit(str);
27    owl_function_error("Internal error! Non-UTF-8 string encountered:\n%s", escape);
28    g_free(escape);
29  }
30  return ret;
31}
32
33CALLER_OWN AV *owl_new_av(const GPtrArray *l, SV *(*to_sv)(const void *))
34{
35  AV *ret;
36  int i;
37  void *element;
38
39  ret = newAV();
40
41  for (i = 0; i < l->len; i++) {
42    element = l->pdata[i];
43    av_push(ret, to_sv(element));
44  }
45
46  return ret;
47}
48
49CALLER_OWN HV *owl_new_hv(const owl_dict *d, SV *(*to_sv)(const void *))
50{
51  HV *ret;
52  GPtrArray *keys;
53  const char *key;
54  void *element;
55  int i;
56
57  ret = newHV();
58
59  /* TODO: add an iterator-like interface to owl_dict */
60  keys = owl_dict_get_keys(d);
61  for (i = 0; i < keys->len; i++) {
62    key = keys->pdata[i];
63    element = owl_dict_find_element(d, key);
64    (void)hv_store(ret, key, strlen(key), to_sv(element), 0);
65  }
66  owl_ptr_array_free(keys, g_free);
67
68  return ret;
69}
70
71CALLER_OWN SV *owl_perlconfig_message2hashref(const owl_message *m)
72{
73  HV *h, *stash;
74  SV *hr;
75  const char *type;
76  char *ptr, *utype, *blessas;
77  int i, j;
78  const owl_pair *pair;
79  const owl_filter *wrap;
80
81  if (!m) return &PL_sv_undef;
82  wrap = owl_global_get_filter(&g, "wordwrap");
83  if(!wrap) {
84      owl_function_error("wrap filter is not defined");
85      return &PL_sv_undef;
86  }
87
88  h = newHV();
89
90#define MSG2H(h,field) (void)hv_store(h, #field, strlen(#field),        \
91                                      owl_new_sv(owl_message_get_##field(m)), 0)
92
93  if (owl_message_get_notice(m)) {
94    /* Handle zephyr-specific fields... */
95    AV *av_zfields;
96
97    av_zfields = newAV();
98    j=owl_zephyr_get_num_fields(owl_message_get_notice(m));
99    for (i=0; i<j; i++) {
100      ptr=owl_zephyr_get_field_as_utf8(owl_message_get_notice(m), i+1);
101      av_push(av_zfields, owl_new_sv(ptr));
102      g_free(ptr);
103    }
104    (void)hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
105
106    (void)hv_store(h, "auth", strlen("auth"), 
107                   owl_new_sv(owl_zephyr_get_authstr(owl_message_get_notice(m))),0);
108  }
109
110  for (i = 0; i < m->attributes->len; i++) {
111    pair = m->attributes->pdata[i];
112    (void)hv_store(h, owl_pair_get_key(pair), strlen(owl_pair_get_key(pair)),
113                   owl_new_sv(owl_pair_get_value(pair)),0);
114  }
115 
116  MSG2H(h, type);
117  MSG2H(h, direction);
118  MSG2H(h, class);
119  MSG2H(h, instance);
120  MSG2H(h, sender);
121  MSG2H(h, realm);
122  MSG2H(h, recipient);
123  MSG2H(h, opcode);
124  MSG2H(h, hostname);
125  MSG2H(h, body);
126  MSG2H(h, login);
127  MSG2H(h, zsig);
128  MSG2H(h, zwriteline);
129  if (owl_message_get_header(m)) {
130    MSG2H(h, header); 
131  }
132  (void)hv_store(h, "time", strlen("time"), owl_new_sv(owl_message_get_timestr(m)),0);
133  (void)hv_store(h, "unix_time", strlen("unix_time"), newSViv(m->time), 0);
134  (void)hv_store(h, "id", strlen("id"), newSViv(owl_message_get_id(m)),0);
135  (void)hv_store(h, "deleted", strlen("deleted"), newSViv(owl_message_is_delete(m)),0);
136  (void)hv_store(h, "private", strlen("private"), newSViv(owl_message_is_private(m)),0);
137  (void)hv_store(h, "should_wordwrap",
138                 strlen("should_wordwrap"), newSViv(
139                                                    owl_filter_message_match(wrap, m)),0);
140
141  type = owl_message_get_type(m);
142  if(!type || !*type) type = "generic";
143  utype = g_strdup(type);
144  utype[0] = toupper(type[0]);
145  blessas = g_strdup_printf("BarnOwl::Message::%s", utype);
146
147  hr = newRV_noinc((SV*)h);
148  stash =  gv_stashpv(blessas,0);
149  if(!stash) {
150    owl_function_error("No such class: %s for message type %s", blessas, owl_message_get_type(m));
151    stash = gv_stashpv("BarnOwl::Message", 1);
152  }
153  hr = sv_bless(hr,stash);
154  g_free(utype);
155  g_free(blessas);
156  return hr;
157}
158
159CALLER_OWN SV *owl_perlconfig_curmessage2hashref(void)
160{
161  int curmsg;
162  const owl_view *v;
163  v=owl_global_get_current_view(&g);
164  if (owl_view_get_size(v) < 1) {
165    return &PL_sv_undef;
166  }
167  curmsg=owl_global_get_curmsg(&g);
168  return owl_perlconfig_message2hashref(owl_view_get_element(v, curmsg));
169}
170
171/* XXX TODO: Messages should round-trip properly between
172   message2hashref and hashref2message. Currently we lose
173   zephyr-specific properties stored in the ZNotice_t
174 */
175CALLER_OWN owl_message *owl_perlconfig_hashref2message(SV *msg)
176{
177  owl_message * m;
178  HE * ent;
179  I32 len;
180  const char *key,*val;
181  HV * hash;
182  struct tm tm;
183
184  hash = (HV*)SvRV(msg);
185
186  m = g_new(owl_message, 1);
187  owl_message_init(m);
188
189  hv_iterinit(hash);
190  while((ent = hv_iternext(hash))) {
191    key = hv_iterkey(ent, &len);
192    val = SvPV_nolen(hv_iterval(hash, ent));
193    if(!strcmp(key, "type")) {
194      owl_message_set_type(m, val);
195    } else if(!strcmp(key, "direction")) {
196      owl_message_set_direction(m, owl_message_parse_direction(val));
197    } else if(!strcmp(key, "private")) {
198      SV * v = hv_iterval(hash, ent);
199      if(SvTRUE(v)) {
200        owl_message_set_isprivate(m);
201      }
202    } else if (!strcmp(key, "hostname")) {
203      owl_message_set_hostname(m, val);
204    } else if (!strcmp(key, "zwriteline")) {
205      owl_message_set_zwriteline(m, val);
206    } else if (!strcmp(key, "time")) {
207      g_free(m->timestr);
208      m->timestr = g_strdup(val);
209      strptime(val, "%a %b %d %T %Y", &tm);
210      m->time = mktime(&tm);
211    } else {
212      owl_message_set_attribute(m, key, val);
213    }
214  }
215  if(owl_message_is_type_admin(m)) {
216    if(!owl_message_get_attribute_value(m, "adminheader"))
217      owl_message_set_attribute(m, "adminheader", "");
218  }
219  return m;
220}
221
222/* Calls in a scalar context, passing it a hash reference.
223   If return value is non-null, caller must free. */
224CALLER_OWN char *owl_perlconfig_call_with_message(const char *subname, const owl_message *m)
225{
226  SV *msgref, *rv;
227  char *out = NULL;
228
229  msgref = owl_perlconfig_message2hashref(m);
230
231  OWL_PERL_CALL((call_pv(subname, G_SCALAR|G_EVAL))
232                ,
233                XPUSHs(sv_2mortal(msgref));
234                ,
235                "Perl Error: '%s'"
236                ,
237                false
238                ,
239                false
240                ,
241                rv = POPs;
242                if (rv && SvPOK(rv))
243                  out = g_strdup(SvPV_nolen(rv));
244                );
245  return out;
246}
247
248
249/* Calls a method on a perl object representing a message.
250   If the return value is non-null, the caller must free it.
251 */
252CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv)
253{
254  SV *msgref, *rv;
255  char *out = NULL;
256  int i;
257
258  msgref = owl_perlconfig_message2hashref(m);
259
260  OWL_PERL_CALL(call_method(method, G_SCALAR|G_EVAL)
261                ,
262                XPUSHs(sv_2mortal(msgref));
263                OWL_PERL_PUSH_ARGS(i, argc, argv);
264                ,
265                "Perl Error: '%s'"
266                ,
267                false
268                ,
269                false
270                ,
271                rv = POPs;
272                if (rv && SvPOK(rv))
273                  out = g_strdup(SvPV_nolen(rv));
274                );
275  return out;
276}
277
278/* caller must free result, if not NULL */
279CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
280{
281  int ret;
282  PerlInterpreter *p;
283  char *err;
284  const char *args[4] = {"", "-e", "0;", NULL};
285  AV *inc;
286  char *path;
287
288  /* create and initialize interpreter */
289  PERL_SYS_INIT3(Pargc, Pargv, Penv);
290  p=perl_alloc();
291  owl_global_set_perlinterp(&g, p);
292  perl_construct(p);
293
294  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
295
296  owl_global_set_no_have_config(&g);
297
298  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
299  if (ret || SvTRUE(ERRSV)) {
300    err=g_strdup(SvPV_nolen(ERRSV));
301    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
302    return(err);
303  }
304
305  ret=perl_run(p);
306  if (ret || SvTRUE(ERRSV)) {
307    err=g_strdup(SvPV_nolen(ERRSV));
308    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
309    return(err);
310  }
311
312  owl_global_set_have_config(&g);
313
314  /* create legacy variables */
315  get_sv("BarnOwl::id", TRUE);
316  get_sv("BarnOwl::class", TRUE);
317  get_sv("BarnOwl::instance", TRUE);
318  get_sv("BarnOwl::recipient", TRUE);
319  get_sv("BarnOwl::sender", TRUE);
320  get_sv("BarnOwl::realm", TRUE);
321  get_sv("BarnOwl::opcode", TRUE);
322  get_sv("BarnOwl::zsig", TRUE);
323  get_sv("BarnOwl::msg", TRUE);
324  get_sv("BarnOwl::time", TRUE);
325  get_sv("BarnOwl::host", TRUE);
326  get_av("BarnOwl::fields", TRUE);
327
328  if(file) {
329    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
330    sv_setpv(cfg, file);
331  }
332
333  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
334
335  /* Add the system lib path to @INC */
336  inc = get_av("INC", 0);
337  path = g_build_filename(owl_get_datadir(), "lib", NULL);
338  av_unshift(inc, 1);
339  av_store(inc, 0, owl_new_sv(path));
340  g_free(path);
341
342  eval_pv("use BarnOwl;", FALSE);
343
344  if (SvTRUE(ERRSV)) {
345    err=g_strdup(SvPV_nolen(ERRSV));
346    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
347    return(err);
348  }
349
350  /* check if we have the formatting function */
351  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
352    owl_global_set_config_format(&g, 1);
353  }
354
355  return(NULL);
356}
357
358/* returns whether or not a function exists */
359int owl_perlconfig_is_function(const char *fn) {
360  if (get_cv(fn, FALSE)) return(1);
361  else return(0);
362}
363
364/* caller is responsible for freeing returned string */
365CALLER_OWN char *owl_perlconfig_execute(const char *line)
366{
367  STRLEN len;
368  SV *response;
369  char *out;
370
371  if (!owl_global_have_config(&g)) return NULL;
372
373  ENTER;
374  SAVETMPS;
375  /* execute the subroutine */
376  response = eval_pv(line, FALSE);
377
378  if (SvTRUE(ERRSV)) {
379    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
380    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
381  }
382
383  out = g_strdup(SvPV(response, len));
384  FREETMPS;
385  LEAVE;
386
387  return(out);
388}
389
390void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
391{
392  char *ptr = NULL;
393  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
394    ptr = owl_perlconfig_call_with_message(subname?subname
395                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
396  }
397  g_free(ptr);
398}
399
400/* Called on all new messages; receivemsg is only called on incoming ones */
401void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
402{
403  char *ptr = NULL;
404  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
405    ptr = owl_perlconfig_call_with_message(subname?subname
406                                           :"BarnOwl::Hooks::_new_msg", m);
407  }
408  g_free(ptr);
409}
410
411void owl_perlconfig_new_command(const char *name)
412{
413  OWL_PERL_CALL(call_pv("BarnOwl::Hooks::_new_command", G_VOID|G_EVAL);
414                ,
415                XPUSHs(sv_2mortal(owl_new_sv(name)));
416                ,
417                "Perl Error: '%s'"
418                ,
419                false
420                ,
421                true
422                ,
423                );
424}
425
426CALLER_OWN char *owl_perlconfig_perl_call(const char *method, int argc, const char *const *argv)
427{
428  SV *rv;
429  char *out = NULL;
430  int i;
431  OWL_PERL_CALL(call_pv(method, G_SCALAR|G_EVAL)
432                ,
433                OWL_PERL_PUSH_ARGS(i, argc, argv);
434                ,
435                "Perl Error: '%s'"
436                ,
437                false
438                ,
439                false
440                ,
441                rv = POPs;
442                if (rv && SvPOK(rv))
443                  out = g_strdup(SvPV_nolen(rv));
444                );
445  return out;
446}
447
448int owl_perlconfig_perl_call_int(const char *method, int argc, const char *const *argv)
449{
450  SV *rv;
451  int ret = -1;
452  int i;
453  OWL_PERL_CALL(call_pv(method, G_SCALAR|G_EVAL)
454                ,
455                OWL_PERL_PUSH_ARGS(i, argc, argv);
456                ,
457                "Perl Error: '%s'"
458                ,
459                false
460                ,
461                false
462                ,
463                rv = POPs;
464                if (rv && SvIOK(rv))
465                  ret = SvIV(rv);
466                );
467  return ret;
468}
469
470bool owl_perlconfig_perl_call_bool(const char *method, int argc, const char *const *argv)
471{
472  SV *rv;
473  bool ret = false;
474  int i;
475  OWL_PERL_CALL(call_pv(method, G_SCALAR|G_EVAL)
476                ,
477                OWL_PERL_PUSH_ARGS(i, argc, argv);
478                ,
479                "Perl Error: '%s'"
480                ,
481                false
482                ,
483                false
484                ,
485                rv = POPs;
486                if (rv)
487                  ret = SvTRUE(rv);
488                );
489  return ret;
490}
491
492void owl_perlconfig_perl_call_norv(const char *method, int argc, const char *const *argv)
493{
494  int i;
495  OWL_PERL_CALL(call_pv(method, G_DISCARD|G_EVAL)
496                ,
497                OWL_PERL_PUSH_ARGS(i, argc, argv);
498                ,
499                "Perl Error: '%s'"
500                ,
501                false
502                ,
503                true
504                ,
505                );
506}
507
508/* caller must free the result */
509CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
510{
511  int i;
512  SV* rv;
513  char *out = NULL;
514
515  OWL_PERL_CALL(call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL)
516                ,
517                OWL_PERL_PUSH_ARGS(i, argc, argv);
518                ,
519                "Perl Error: '%s'"
520                ,
521                false
522                ,
523                false
524                ,
525                rv = POPs;
526                if (rv && SvPOK(rv))
527                  out = g_strdup(SvPV_nolen(rv));
528                );
529  return out;
530}
531
532void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
533{
534  SvREFCNT_dec(cmd->cmd_perl);
535}
536
537void owl_perlconfig_edit_callback(owl_editwin *e, bool success)
538{
539  SV *cb = owl_editwin_get_cbdata(e);
540  SV *text = owl_new_sv(owl_editwin_get_text(e));
541
542  if (cb == NULL) {
543    owl_function_error("Perl callback is NULL!");
544    return;
545  }
546
547  OWL_PERL_CALL(call_sv(cb, G_DISCARD|G_EVAL)
548                ,
549                XPUSHs(sv_2mortal(text));
550                XPUSHs(sv_2mortal(newSViv(success)));
551                ,
552                "Perl Error: '%s'"
553                ,
554                false
555                ,
556                true
557                ,
558                );
559}
560
561void owl_perlconfig_dec_refcnt(void *data)
562{
563  SV *v = data;
564  SvREFCNT_dec(v);
565}
Note: See TracBrowser for help on using the repository browser.