source: perlconfig.c @ e146cd7

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