source: perlconfig.c @ 2a42248

release-1.10release-1.9
Last change on this file since 2a42248 was b9517cf, checked in by David Benjamin <davidben@mit.edu>, 13 years ago
Explicitly store whether an owl_message has a ZNotice_t We should remove it altogether in perlmessages, but in the meantime, we shouldn't be crashing on faked incoming zephyr messages. Also drop the attempted fake ZNotice_t in owl_perlconfig_hashref2message. No one could have relied on it safely today because any such message would crash on delete.
  • Property mode set to 100644
File size: 12.6 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)
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  PUTBACK;
540 
541  call_sv(cb, G_DISCARD|G_EVAL);
542
543  if(SvTRUE(ERRSV)) {
544    owl_function_error("%s", SvPV_nolen(ERRSV));
545  }
546
547  FREETMPS;
548  LEAVE;
549}
550
551void owl_perlconfig_dec_refcnt(void *data)
552{
553  SV *v = data;
554  SvREFCNT_dec(v);
555}
Note: See TracBrowser for help on using the repository browser.