source: perlconfig.c @ 8135737

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