source: perlconfig.c @ 92ffd89

release-1.10
Last change on this file since 92ffd89 was 92ffd89, checked in by Jason Gross <jgross@mit.edu>, 11 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: 13.0 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  const char *f;
78  int i;
79  const owl_pair *pair;
80  const owl_filter *wrap;
81
82  if (!m) return &PL_sv_undef;
83  wrap = owl_global_get_filter(&g, "wordwrap");
84  if(!wrap) {
85      owl_function_error("wrap filter is not defined");
86      return &PL_sv_undef;
87  }
88
89  h = newHV();
90
91#define MSG2H(h,field) (void)hv_store(h, #field, strlen(#field),        \
92                                      owl_new_sv(owl_message_get_##field(m)), 0)
93
94  if (owl_message_is_type_zephyr(m) && owl_message_is_direction_in(m)) {
95    /* Handle zephyr-specific fields... */
96    AV *av_zfields = newAV();
97    if (owl_message_get_notice(m)) {
98      for (f = owl_zephyr_first_raw_field(owl_message_get_notice(m)); f != NULL;
99           f = owl_zephyr_next_raw_field(owl_message_get_notice(m), f)) {
100        ptr = owl_zephyr_field_as_utf8(owl_message_get_notice(m), f);
101        av_push(av_zfields, owl_new_sv(ptr));
102        g_free(ptr);
103      }
104      (void)hv_store(h, "auth", strlen("auth"),
105                     owl_new_sv(owl_zephyr_get_authstr(owl_message_get_notice(m))), 0);
106    } else {
107      /* Incoming zephyrs without a ZNotice_t are pseudo-logins. To appease
108       * existing styles, put in bogus 'auth' and 'fields' keys. */
109      (void)hv_store(h, "auth", strlen("auth"), owl_new_sv("NO"), 0);
110    }
111    (void)hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
112  }
113
114  for (i = 0; i < m->attributes->len; i++) {
115    pair = m->attributes->pdata[i];
116    (void)hv_store(h, owl_pair_get_key(pair), strlen(owl_pair_get_key(pair)),
117                   owl_new_sv(owl_pair_get_value(pair)),0);
118  }
119 
120  MSG2H(h, type);
121  MSG2H(h, direction);
122  MSG2H(h, class);
123  MSG2H(h, instance);
124  MSG2H(h, sender);
125  MSG2H(h, realm);
126  MSG2H(h, recipient);
127  MSG2H(h, opcode);
128  MSG2H(h, hostname);
129  MSG2H(h, body);
130  MSG2H(h, login);
131  MSG2H(h, zsig);
132  MSG2H(h, zwriteline);
133  if (owl_message_get_header(m)) {
134    MSG2H(h, header); 
135  }
136  (void)hv_store(h, "time", strlen("time"), owl_new_sv(owl_message_get_timestr(m)),0);
137  (void)hv_store(h, "unix_time", strlen("unix_time"), newSViv(m->time), 0);
138  (void)hv_store(h, "id", strlen("id"), newSViv(owl_message_get_id(m)),0);
139  (void)hv_store(h, "deleted", strlen("deleted"), newSViv(owl_message_is_delete(m)),0);
140  (void)hv_store(h, "private", strlen("private"), newSViv(owl_message_is_private(m)),0);
141  (void)hv_store(h, "should_wordwrap",
142                 strlen("should_wordwrap"), newSViv(
143                                                    owl_filter_message_match(wrap, m)),0);
144
145  type = owl_message_get_type(m);
146  if(!type || !*type) type = "generic";
147  utype = g_strdup(type);
148  utype[0] = toupper(type[0]);
149  blessas = g_strdup_printf("BarnOwl::Message::%s", utype);
150
151  hr = newRV_noinc((SV*)h);
152  stash =  gv_stashpv(blessas,0);
153  if(!stash) {
154    owl_function_error("No such class: %s for message type %s", blessas, owl_message_get_type(m));
155    stash = gv_stashpv("BarnOwl::Message", 1);
156  }
157  hr = sv_bless(hr,stash);
158  g_free(utype);
159  g_free(blessas);
160  return hr;
161}
162
163CALLER_OWN SV *owl_perlconfig_curmessage2hashref(void)
164{
165  int curmsg;
166  const owl_view *v;
167  v=owl_global_get_current_view(&g);
168  if (owl_view_get_size(v) < 1) {
169    return &PL_sv_undef;
170  }
171  curmsg=owl_global_get_curmsg(&g);
172  return owl_perlconfig_message2hashref(owl_view_get_element(v, curmsg));
173}
174
175/* XXX TODO: Messages should round-trip properly between
176   message2hashref and hashref2message. Currently we lose
177   zephyr-specific properties stored in the ZNotice_t
178 */
179CALLER_OWN owl_message *owl_perlconfig_hashref2message(SV *msg)
180{
181  owl_message * m;
182  HE * ent;
183  I32 len;
184  const char *key,*val;
185  HV * hash;
186  struct tm tm;
187
188  hash = (HV*)SvRV(msg);
189
190  m = g_new(owl_message, 1);
191  owl_message_init(m);
192
193  hv_iterinit(hash);
194  while((ent = hv_iternext(hash))) {
195    key = hv_iterkey(ent, &len);
196    val = SvPV_nolen(hv_iterval(hash, ent));
197    if(!strcmp(key, "type")) {
198      owl_message_set_type(m, val);
199    } else if(!strcmp(key, "direction")) {
200      owl_message_set_direction(m, owl_message_parse_direction(val));
201    } else if(!strcmp(key, "private")) {
202      SV * v = hv_iterval(hash, ent);
203      if(SvTRUE(v)) {
204        owl_message_set_isprivate(m);
205      }
206    } else if (!strcmp(key, "hostname")) {
207      owl_message_set_hostname(m, val);
208    } else if (!strcmp(key, "zwriteline")) {
209      owl_message_set_zwriteline(m, val);
210    } else if (!strcmp(key, "time")) {
211      g_free(m->timestr);
212      m->timestr = g_strdup(val);
213      strptime(val, "%a %b %d %T %Y", &tm);
214      m->time = mktime(&tm);
215    } else {
216      owl_message_set_attribute(m, key, val);
217    }
218  }
219  if(owl_message_is_type_admin(m)) {
220    if(!owl_message_get_attribute_value(m, "adminheader"))
221      owl_message_set_attribute(m, "adminheader", "");
222  }
223  return m;
224}
225
226/* Calls in a scalar context, passing it a hash reference.
227   If return value is non-null, caller must free. */
228CALLER_OWN char *owl_perlconfig_call_with_message(const char *subname, const owl_message *m)
229{
230  SV *msgref, *rv;
231  char *out = NULL;
232
233  msgref = owl_perlconfig_message2hashref(m);
234
235  OWL_PERL_CALL((call_pv(subname, G_SCALAR|G_EVAL))
236                ,
237                XPUSHs(sv_2mortal(msgref));
238                ,
239                "Perl Error: '%s'"
240                ,
241                false
242                ,
243                false
244                ,
245                rv = POPs;
246                if (rv && SvPOK(rv))
247                  out = g_strdup(SvPV_nolen(rv));
248                );
249  return out;
250}
251
252
253/* Calls a method on a perl object representing a message.
254   If the return value is non-null, the caller must free it.
255 */
256CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv)
257{
258  SV *msgref, *rv;
259  char *out = NULL;
260  int i;
261
262  msgref = owl_perlconfig_message2hashref(m);
263
264  OWL_PERL_CALL(call_method(method, G_SCALAR|G_EVAL)
265                ,
266                XPUSHs(sv_2mortal(msgref));
267                OWL_PERL_PUSH_ARGS(i, argc, argv);
268                ,
269                "Perl Error: '%s'"
270                ,
271                false
272                ,
273                false
274                ,
275                rv = POPs;
276                if (rv && SvPOK(rv))
277                  out = g_strdup(SvPV_nolen(rv));
278                );
279  return out;
280}
281
282/* caller must free result, if not NULL */
283CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
284{
285  int ret;
286  PerlInterpreter *p;
287  char *err;
288  const char *args[4] = {"", "-e", "0;", NULL};
289  const char *dlerr;
290  AV *inc;
291  char *path;
292
293  /* create and initialize interpreter */
294  PERL_SYS_INIT3(Pargc, Pargv, Penv);
295  p=perl_alloc();
296  owl_global_set_perlinterp(&g, p);
297  perl_construct(p);
298
299  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
300
301  owl_global_set_no_have_config(&g);
302
303  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
304  if (ret || SvTRUE(ERRSV)) {
305    err=g_strdup(SvPV_nolen(ERRSV));
306    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
307    return(err);
308  }
309
310  ret=perl_run(p);
311  if (ret || SvTRUE(ERRSV)) {
312    err=g_strdup(SvPV_nolen(ERRSV));
313    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
314    return(err);
315  }
316
317  owl_global_set_have_config(&g);
318
319  /* create legacy variables */
320  get_sv("BarnOwl::id", TRUE);
321  get_sv("BarnOwl::class", TRUE);
322  get_sv("BarnOwl::instance", TRUE);
323  get_sv("BarnOwl::recipient", TRUE);
324  get_sv("BarnOwl::sender", TRUE);
325  get_sv("BarnOwl::realm", TRUE);
326  get_sv("BarnOwl::opcode", TRUE);
327  get_sv("BarnOwl::zsig", TRUE);
328  get_sv("BarnOwl::msg", TRUE);
329  get_sv("BarnOwl::time", TRUE);
330  get_sv("BarnOwl::host", TRUE);
331  get_av("BarnOwl::fields", TRUE);
332
333  if(file) {
334    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
335    sv_setpv(cfg, file);
336  }
337
338  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
339
340  /* Add the system lib path to @INC */
341  inc = get_av("INC", 0);
342  path = g_build_filename(owl_get_datadir(), "lib", NULL);
343  av_unshift(inc, 1);
344  av_store(inc, 0, owl_new_sv(path));
345  g_free(path);
346
347  /* Load up perl-Glib. */
348  eval_pv("use Glib;", FALSE);
349
350  /* Now, before BarnOwl tries to use them, get the relevant function pointers out. */
351  dlerr = owl_closure_init();
352  if (dlerr) {
353    return g_strdup(dlerr);
354  }
355
356  /* And now it's safe to import BarnOwl. */
357  eval_pv("use BarnOwl;", FALSE);
358
359  if (SvTRUE(ERRSV)) {
360    err=g_strdup(SvPV_nolen(ERRSV));
361    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
362    return(err);
363  }
364
365  /* check if we have the formatting function */
366  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
367    owl_global_set_config_format(&g, 1);
368  }
369
370  return(NULL);
371}
372
373/* returns whether or not a function exists */
374int owl_perlconfig_is_function(const char *fn) {
375  if (get_cv(fn, FALSE)) return(1);
376  else return(0);
377}
378
379/* caller is responsible for freeing returned string */
380CALLER_OWN char *owl_perlconfig_execute(const char *line)
381{
382  STRLEN len;
383  SV *response;
384  char *out;
385
386  if (!owl_global_have_config(&g)) return NULL;
387
388  ENTER;
389  SAVETMPS;
390  /* execute the subroutine */
391  response = eval_pv(line, FALSE);
392
393  if (SvTRUE(ERRSV)) {
394    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
395    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
396  }
397
398  out = g_strdup(SvPV(response, len));
399  FREETMPS;
400  LEAVE;
401
402  return(out);
403}
404
405void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
406{
407  char *ptr = NULL;
408  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
409    ptr = owl_perlconfig_call_with_message(subname?subname
410                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
411  }
412  g_free(ptr);
413}
414
415/* Called on all new messages; receivemsg is only called on incoming ones */
416void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
417{
418  char *ptr = NULL;
419  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
420    ptr = owl_perlconfig_call_with_message(subname?subname
421                                           :"BarnOwl::Hooks::_new_msg", m);
422  }
423  g_free(ptr);
424}
425
426void owl_perlconfig_new_command(const char *name)
427{
428  OWL_PERL_CALL(call_pv("BarnOwl::Hooks::_new_command", G_VOID|G_EVAL);
429                ,
430                XPUSHs(sv_2mortal(owl_new_sv(name)));
431                ,
432                "Perl Error: '%s'"
433                ,
434                false
435                ,
436                true
437                ,
438                );
439}
440
441/* caller must free the result */
442CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
443{
444  int i;
445  SV* rv;
446  char *out = NULL;
447
448  OWL_PERL_CALL(call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL)
449                ,
450                OWL_PERL_PUSH_ARGS(i, argc, argv);
451                ,
452                "Perl Error: '%s'"
453                ,
454                false
455                ,
456                false
457                ,
458                rv = POPs;
459                if (rv && SvPOK(rv))
460                  out = g_strdup(SvPV_nolen(rv));
461                );
462  return out;
463}
464
465void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
466{
467  SvREFCNT_dec(cmd->cmd_perl);
468}
469
470void owl_perlconfig_edit_callback(owl_editwin *e, bool success)
471{
472  SV *cb = owl_editwin_get_cbdata(e);
473  SV *text = owl_new_sv(owl_editwin_get_text(e));
474
475  if (cb == NULL) {
476    owl_function_error("Perl callback is NULL!");
477    return;
478  }
479
480  OWL_PERL_CALL(call_sv(cb, G_DISCARD|G_EVAL)
481                ,
482                XPUSHs(sv_2mortal(text));
483                XPUSHs(sv_2mortal(newSViv(success)));
484                ,
485                "Perl Error: '%s'"
486                ,
487                false
488                ,
489                true
490                ,
491                );
492}
493
494void owl_perlconfig_dec_refcnt(void *data)
495{
496  SV *v = data;
497  SvREFCNT_dec(v);
498}
Note: See TracBrowser for help on using the repository browser.