source: perlconfig.c @ 0c71c58

Last change on this file since 0c71c58 was 0c71c58, checked in by Jason Gross <jgross@mit.edu>, 13 years ago
Refactor perl calls through a single method I don't know the perl/C interface well enough to figure out the best way to standardize the many variants that we use to call perl code. Perhaps we should standardize the error messages, and put less knobs on the boilerplate macro.
  • Property mode set to 100644
File size: 12.4 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
426/* caller must free the result */
427CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
428{
429  int i;
430  SV* rv;
431  char *out = NULL;
432
433  OWL_PERL_CALL(call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL)
434                ,
435                OWL_PERL_PUSH_ARGS(i, argc, argv);
436                ,
437                "Perl Error: '%s'"
438                ,
439                false
440                ,
441                false
442                ,
443                rv = POPs;
444                if (rv && SvPOK(rv))
445                  out = g_strdup(SvPV_nolen(rv));
446                );
447  return out;
448}
449
450void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
451{
452  SvREFCNT_dec(cmd->cmd_perl);
453}
454
455void owl_perlconfig_edit_callback(owl_editwin *e, bool success)
456{
457  SV *cb = owl_editwin_get_cbdata(e);
458  SV *text = owl_new_sv(owl_editwin_get_text(e));
459
460  if (cb == NULL) {
461    owl_function_error("Perl callback is NULL!");
462    return;
463  }
464
465  OWL_PERL_CALL(call_sv(cb, G_DISCARD|G_EVAL)
466                ,
467                XPUSHs(sv_2mortal(text));
468                XPUSHs(sv_2mortal(newSViv(success)));
469                ,
470                "Perl Error: '%s'"
471                ,
472                false
473                ,
474                true
475                ,
476                );
477}
478
479void owl_perlconfig_dec_refcnt(void *data)
480{
481  SV *v = data;
482  SvREFCNT_dec(v);
483}
Note: See TracBrowser for help on using the repository browser.