source: perlconfig.c @ d6b8b50

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