source: perlconfig.c @ bdc53e0

Last change on this file since bdc53e0 was f21bc36, 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      m->timestr = g_strdup(val);
218      strptime(val, "%a %b %d %T %Y", &tm);
219      m->time = mktime(&tm);
220    } else {
221      owl_message_set_attribute(m, key, val);
222    }
223  }
224  if(owl_message_is_type_admin(m)) {
225    if(!owl_message_get_attribute_value(m, "adminheader"))
226      owl_message_set_attribute(m, "adminheader", "");
227  }
228#ifdef HAVE_LIBZEPHYR
229  if (owl_message_is_type_zephyr(m)) {
230    ZNotice_t *n = &(m->notice);
231    n->z_kind = ACKED;
232    n->z_port = 0;
233    n->z_auth = ZAUTH_NO;
234    n->z_checked_auth = 0;
235    n->z_class = zstr(owl_message_get_class(m));
236    n->z_class_inst = zstr(owl_message_get_instance(m));
237    n->z_opcode = zstr(owl_message_get_opcode(m));
238    n->z_sender = zstr(owl_message_get_sender(m));
239    n->z_recipient = zstr(owl_message_get_recipient(m));
240    n->z_default_format = zstr("[zephyr created from perl]");
241    n->z_multinotice = zstr("[zephyr created from perl]");
242    n->z_num_other_fields = 0;
243    n->z_message = g_strdup_printf("%s%c%s", owl_message_get_zsig(m), '\0', owl_message_get_body(m));
244    n->z_message_len = strlen(owl_message_get_zsig(m)) + strlen(owl_message_get_body(m)) + 1;
245  }
246#endif
247  return m;
248}
249
250/* Calls in a scalar context, passing it a hash reference.
251   If return value is non-null, caller must free. */
252char *owl_perlconfig_call_with_message(const char *subname, const owl_message *m)
253{
254  dSP ;
255  int count;
256  SV *msgref, *srv;
257  char *out;
258 
259  ENTER ;
260  SAVETMPS;
261 
262  PUSHMARK(SP) ;
263  msgref = owl_perlconfig_message2hashref(m);
264  XPUSHs(sv_2mortal(msgref));
265  PUTBACK ;
266 
267  count = call_pv(subname, G_SCALAR|G_EVAL);
268 
269  SPAGAIN ;
270
271  if (SvTRUE(ERRSV)) {
272    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
273    /* and clear the error */
274    sv_setsv (ERRSV, &PL_sv_undef);
275  }
276
277  if (count != 1) {
278    fprintf(stderr, "bad perl!  no biscuit!  returned wrong count!\n");
279    abort();
280  }
281
282  srv = POPs;
283
284  if (srv) {
285    out = g_strdup(SvPV_nolen(srv));
286  } else {
287    out = NULL;
288  }
289 
290  PUTBACK ;
291  FREETMPS ;
292  LEAVE ;
293
294  return out;
295}
296
297
298/* Calls a method on a perl object representing a message.
299   If the return value is non-null, the caller must free it.
300 */
301char * owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char ** argv)
302{
303  dSP;
304  unsigned int count, i;
305  SV *msgref, *srv;
306  char *out;
307
308  msgref = owl_perlconfig_message2hashref(m);
309
310  ENTER;
311  SAVETMPS;
312
313  PUSHMARK(SP);
314  XPUSHs(sv_2mortal(msgref));
315  for(i=0;i<argc;i++) {
316    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
317  }
318  PUTBACK;
319
320  count = call_method(method, G_SCALAR|G_EVAL);
321
322  SPAGAIN;
323
324  if(count != 1) {
325    fprintf(stderr, "perl returned wrong count %u\n", count);
326    abort();
327  }
328
329  if (SvTRUE(ERRSV)) {
330    owl_function_error("Error: '%s'", SvPV_nolen(ERRSV));
331    /* and clear the error */
332    sv_setsv (ERRSV, &PL_sv_undef);
333  }
334
335  srv = POPs;
336
337  if (srv) {
338    out = g_strdup(SvPV_nolen(srv));
339  } else {
340    out = NULL;
341  }
342
343  PUTBACK;
344  FREETMPS;
345  LEAVE;
346
347  return out;
348}
349
350
351char *owl_perlconfig_initperl(const char * file, int *Pargc, char ***Pargv, char *** Penv)
352{
353  int ret;
354  PerlInterpreter *p;
355  char *err;
356  const char *args[4] = {"", "-e", "0;", NULL};
357  AV *inc;
358  char *path;
359
360  /* create and initialize interpreter */
361  PERL_SYS_INIT3(Pargc, Pargv, Penv);
362  p=perl_alloc();
363  owl_global_set_perlinterp(&g, p);
364  perl_construct(p);
365
366  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
367
368  owl_global_set_no_have_config(&g);
369
370  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
371  if (ret || SvTRUE(ERRSV)) {
372    err=g_strdup(SvPV_nolen(ERRSV));
373    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
374    return(err);
375  }
376
377  ret=perl_run(p);
378  if (ret || SvTRUE(ERRSV)) {
379    err=g_strdup(SvPV_nolen(ERRSV));
380    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
381    return(err);
382  }
383
384  owl_global_set_have_config(&g);
385
386  /* create legacy variables */
387  get_sv("BarnOwl::id", TRUE);
388  get_sv("BarnOwl::class", TRUE);
389  get_sv("BarnOwl::instance", TRUE);
390  get_sv("BarnOwl::recipient", TRUE);
391  get_sv("BarnOwl::sender", TRUE);
392  get_sv("BarnOwl::realm", TRUE);
393  get_sv("BarnOwl::opcode", TRUE);
394  get_sv("BarnOwl::zsig", TRUE);
395  get_sv("BarnOwl::msg", TRUE);
396  get_sv("BarnOwl::time", TRUE);
397  get_sv("BarnOwl::host", TRUE);
398  get_av("BarnOwl::fields", TRUE);
399
400  if(file) {
401    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
402    sv_setpv(cfg, file);
403  }
404
405  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
406
407  /* Add the system lib path to @INC */
408  inc = get_av("INC", 0);
409  path = g_strdup_printf("%s/lib", owl_get_datadir());
410  av_unshift(inc, 1);
411  av_store(inc, 0, owl_new_sv(path));
412  g_free(path);
413
414  eval_pv("use BarnOwl;", FALSE);
415
416  if (SvTRUE(ERRSV)) {
417    err=g_strdup(SvPV_nolen(ERRSV));
418    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
419    return(err);
420  }
421
422  /* check if we have the formatting function */
423  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
424    owl_global_set_config_format(&g, 1);
425  }
426
427  return(NULL);
428}
429
430/* returns whether or not a function exists */
431int owl_perlconfig_is_function(const char *fn) {
432  if (get_cv(fn, FALSE)) return(1);
433  else return(0);
434}
435
436/* caller is responsible for freeing returned string */
437char *owl_perlconfig_execute(const char *line)
438{
439  STRLEN len;
440  SV *response;
441  char *out;
442
443  if (!owl_global_have_config(&g)) return NULL;
444
445  ENTER;
446  SAVETMPS;
447  /* execute the subroutine */
448  response = eval_pv(line, FALSE);
449
450  if (SvTRUE(ERRSV)) {
451    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
452    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
453  }
454
455  out = g_strdup(SvPV(response, len));
456  FREETMPS;
457  LEAVE;
458
459  return(out);
460}
461
462void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
463{
464  char *ptr = NULL;
465  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
466    ptr = owl_perlconfig_call_with_message(subname?subname
467                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
468  }
469  g_free(ptr);
470}
471
472/* Called on all new messages; receivemsg is only called on incoming ones */
473void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
474{
475  char *ptr = NULL;
476  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
477    ptr = owl_perlconfig_call_with_message(subname?subname
478                                           :"BarnOwl::Hooks::_new_msg", m);
479  }
480  g_free(ptr);
481}
482
483void owl_perlconfig_new_command(const char *name)
484{
485  dSP;
486
487  ENTER;
488  SAVETMPS;
489
490  PUSHMARK(SP);
491  XPUSHs(sv_2mortal(owl_new_sv(name)));
492  PUTBACK;
493
494  call_pv("BarnOwl::Hooks::_new_command", G_SCALAR|G_VOID|G_EVAL);
495
496  SPAGAIN;
497
498  if(SvTRUE(ERRSV)) {
499    owl_function_error("%s", SvPV_nolen(ERRSV));
500  }
501
502  FREETMPS;
503  LEAVE;
504}
505
506char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
507{
508  int i, count;
509  char * ret = NULL;
510  SV *rv;
511  dSP;
512
513  ENTER;
514  SAVETMPS;
515
516  PUSHMARK(SP);
517  for(i=0;i<argc;i++) {
518    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
519  }
520  PUTBACK;
521
522  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);
523
524  SPAGAIN;
525
526  if(SvTRUE(ERRSV)) {
527    owl_function_error("%s", SvPV_nolen(ERRSV));
528    (void)POPs;
529  } else {
530    if(count != 1)
531      croak("Perl command %s returned more than one value!", cmd->name);
532    rv = POPs;
533    if(SvTRUE(rv)) {
534      ret = g_strdup(SvPV_nolen(rv));
535    }
536  }
537
538  FREETMPS;
539  LEAVE;
540
541  return ret;
542}
543
544void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
545{
546  SvREFCNT_dec(cmd->cmd_perl);
547}
548
549void owl_perlconfig_edit_callback(owl_editwin *e)
550{
551  SV *cb = owl_editwin_get_cbdata(e);
552  SV *text;
553  dSP;
554
555  if(cb == NULL) {
556    owl_function_error("Perl callback is NULL!");
557    return;
558  }
559  text = owl_new_sv(owl_editwin_get_text(e));
560
561  ENTER;
562  SAVETMPS;
563
564  PUSHMARK(SP);
565  XPUSHs(sv_2mortal(text));
566  PUTBACK;
567 
568  call_sv(cb, G_DISCARD|G_EVAL);
569
570  if(SvTRUE(ERRSV)) {
571    owl_function_error("%s", SvPV_nolen(ERRSV));
572  }
573
574  FREETMPS;
575  LEAVE;
576}
577
578void owl_perlconfig_dec_refcnt(void *data)
579{
580  SV *v = data;
581  SvREFCNT_dec(v);
582}
Note: See TracBrowser for help on using the repository browser.