source: perlconfig.c @ a223b6b

release-1.10
Last change on this file since a223b6b was e5210c9, checked in by David Benjamin <davidben@mit.edu>, 12 years ago
dlsym the functions we need after use Glib and before use BarnOwl After use Glib so the library is loaded. Before use BarnOwl so we try to use them before they're available.
  • Property mode set to 100644
File size: 13.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  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  dSP ;
231  int count;
232  SV *msgref, *srv;
233  char *out;
234 
235  ENTER ;
236  SAVETMPS;
237 
238  PUSHMARK(SP) ;
239  msgref = owl_perlconfig_message2hashref(m);
240  XPUSHs(sv_2mortal(msgref));
241  PUTBACK ;
242 
243  count = call_pv(subname, G_SCALAR|G_EVAL);
244 
245  SPAGAIN ;
246
247  if (SvTRUE(ERRSV)) {
248    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
249    /* and clear the error */
250    sv_setsv (ERRSV, &PL_sv_undef);
251  }
252
253  if (count != 1) {
254    fprintf(stderr, "bad perl!  no biscuit!  returned wrong count!\n");
255    abort();
256  }
257
258  srv = POPs;
259
260  if (srv) {
261    out = g_strdup(SvPV_nolen(srv));
262  } else {
263    out = NULL;
264  }
265 
266  PUTBACK ;
267  FREETMPS ;
268  LEAVE ;
269
270  return out;
271}
272
273
274/* Calls a method on a perl object representing a message.
275   If the return value is non-null, the caller must free it.
276 */
277CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv)
278{
279  dSP;
280  unsigned int count, i;
281  SV *msgref, *srv;
282  char *out;
283
284  msgref = owl_perlconfig_message2hashref(m);
285
286  ENTER;
287  SAVETMPS;
288
289  PUSHMARK(SP);
290  XPUSHs(sv_2mortal(msgref));
291  for(i=0;i<argc;i++) {
292    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
293  }
294  PUTBACK;
295
296  count = call_method(method, G_SCALAR|G_EVAL);
297
298  SPAGAIN;
299
300  if(count != 1) {
301    fprintf(stderr, "perl returned wrong count %u\n", count);
302    abort();
303  }
304
305  if (SvTRUE(ERRSV)) {
306    owl_function_error("Error: '%s'", SvPV_nolen(ERRSV));
307    /* and clear the error */
308    sv_setsv (ERRSV, &PL_sv_undef);
309  }
310
311  srv = POPs;
312
313  if (srv) {
314    out = g_strdup(SvPV_nolen(srv));
315  } else {
316    out = NULL;
317  }
318
319  PUTBACK;
320  FREETMPS;
321  LEAVE;
322
323  return out;
324}
325
326/* caller must free result, if not NULL */
327CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
328{
329  int ret;
330  PerlInterpreter *p;
331  char *err;
332  const char *args[4] = {"", "-e", "0;", NULL};
333  const char *dlerr;
334  AV *inc;
335  char *path;
336
337  /* create and initialize interpreter */
338  PERL_SYS_INIT3(Pargc, Pargv, Penv);
339  p=perl_alloc();
340  owl_global_set_perlinterp(&g, p);
341  perl_construct(p);
342
343  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
344
345  owl_global_set_no_have_config(&g);
346
347  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
348  if (ret || SvTRUE(ERRSV)) {
349    err=g_strdup(SvPV_nolen(ERRSV));
350    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
351    return(err);
352  }
353
354  ret=perl_run(p);
355  if (ret || SvTRUE(ERRSV)) {
356    err=g_strdup(SvPV_nolen(ERRSV));
357    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
358    return(err);
359  }
360
361  owl_global_set_have_config(&g);
362
363  /* create legacy variables */
364  get_sv("BarnOwl::id", TRUE);
365  get_sv("BarnOwl::class", TRUE);
366  get_sv("BarnOwl::instance", TRUE);
367  get_sv("BarnOwl::recipient", TRUE);
368  get_sv("BarnOwl::sender", TRUE);
369  get_sv("BarnOwl::realm", TRUE);
370  get_sv("BarnOwl::opcode", TRUE);
371  get_sv("BarnOwl::zsig", TRUE);
372  get_sv("BarnOwl::msg", TRUE);
373  get_sv("BarnOwl::time", TRUE);
374  get_sv("BarnOwl::host", TRUE);
375  get_av("BarnOwl::fields", TRUE);
376
377  if(file) {
378    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
379    sv_setpv(cfg, file);
380  }
381
382  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
383
384  /* Add the system lib path to @INC */
385  inc = get_av("INC", 0);
386  path = g_build_filename(owl_get_datadir(), "lib", NULL);
387  av_unshift(inc, 1);
388  av_store(inc, 0, owl_new_sv(path));
389  g_free(path);
390
391  /* Load up perl-Glib. */
392  eval_pv("use Glib;", FALSE);
393
394  /* Now, before BarnOwl tries to use them, get the relevant function pointers out. */
395  dlerr = owl_closure_init();
396  if (dlerr) {
397    return g_strdup(dlerr);
398  }
399
400  /* And now it's safe to import BarnOwl. */
401  eval_pv("use BarnOwl;", FALSE);
402
403  if (SvTRUE(ERRSV)) {
404    err=g_strdup(SvPV_nolen(ERRSV));
405    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
406    return(err);
407  }
408
409  /* check if we have the formatting function */
410  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
411    owl_global_set_config_format(&g, 1);
412  }
413
414  return(NULL);
415}
416
417/* returns whether or not a function exists */
418int owl_perlconfig_is_function(const char *fn) {
419  if (get_cv(fn, FALSE)) return(1);
420  else return(0);
421}
422
423/* caller is responsible for freeing returned string */
424CALLER_OWN char *owl_perlconfig_execute(const char *line)
425{
426  STRLEN len;
427  SV *response;
428  char *out;
429
430  if (!owl_global_have_config(&g)) return NULL;
431
432  ENTER;
433  SAVETMPS;
434  /* execute the subroutine */
435  response = eval_pv(line, FALSE);
436
437  if (SvTRUE(ERRSV)) {
438    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
439    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
440  }
441
442  out = g_strdup(SvPV(response, len));
443  FREETMPS;
444  LEAVE;
445
446  return(out);
447}
448
449void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
450{
451  char *ptr = NULL;
452  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
453    ptr = owl_perlconfig_call_with_message(subname?subname
454                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
455  }
456  g_free(ptr);
457}
458
459/* Called on all new messages; receivemsg is only called on incoming ones */
460void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
461{
462  char *ptr = NULL;
463  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
464    ptr = owl_perlconfig_call_with_message(subname?subname
465                                           :"BarnOwl::Hooks::_new_msg", m);
466  }
467  g_free(ptr);
468}
469
470void owl_perlconfig_new_command(const char *name)
471{
472  dSP;
473
474  ENTER;
475  SAVETMPS;
476
477  PUSHMARK(SP);
478  XPUSHs(sv_2mortal(owl_new_sv(name)));
479  PUTBACK;
480
481  call_pv("BarnOwl::Hooks::_new_command", G_VOID|G_EVAL);
482
483  SPAGAIN;
484
485  if(SvTRUE(ERRSV)) {
486    owl_function_error("%s", SvPV_nolen(ERRSV));
487  }
488
489  FREETMPS;
490  LEAVE;
491}
492
493/* caller must free the result */
494CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
495{
496  int i, count;
497  char * ret = NULL;
498  SV *rv;
499  dSP;
500
501  ENTER;
502  SAVETMPS;
503
504  PUSHMARK(SP);
505  for(i=0;i<argc;i++) {
506    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
507  }
508  PUTBACK;
509
510  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);
511
512  SPAGAIN;
513
514  if(SvTRUE(ERRSV)) {
515    owl_function_error("%s", SvPV_nolen(ERRSV));
516    (void)POPs;
517  } else {
518    if(count != 1)
519      croak("Perl command %s returned more than one value!", cmd->name);
520    rv = POPs;
521    if(SvTRUE(rv)) {
522      ret = g_strdup(SvPV_nolen(rv));
523    }
524  }
525
526  FREETMPS;
527  LEAVE;
528
529  return ret;
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;
541  dSP;
542
543  if(cb == NULL) {
544    owl_function_error("Perl callback is NULL!");
545    return;
546  }
547  text = owl_new_sv(owl_editwin_get_text(e));
548
549  ENTER;
550  SAVETMPS;
551
552  PUSHMARK(SP);
553  XPUSHs(sv_2mortal(text));
554  XPUSHs(sv_2mortal(newSViv(success)));
555  PUTBACK;
556 
557  call_sv(cb, G_DISCARD|G_EVAL);
558
559  if(SvTRUE(ERRSV)) {
560    owl_function_error("%s", SvPV_nolen(ERRSV));
561  }
562
563  FREETMPS;
564  LEAVE;
565}
566
567void owl_perlconfig_dec_refcnt(void *data)
568{
569  SV *v = data;
570  SvREFCNT_dec(v);
571}
Note: See TracBrowser for help on using the repository browser.