source: perlconfig.c @ 4cc49bc

release-1.10release-1.8release-1.9
Last change on this file since 4cc49bc was f25df21, checked in by David Benjamin <davidben@mit.edu>, 14 years ago
Don't call owl_list_create in owl_dict_get_keys Until we get rid of this owl_list thing altogether, there should be a convention as to who initializes the thing. Otherwise, we leak memory from people initializing it too many times. Whoever reviews this probably wants to look over this very carefully in case I missed one of the owl_list_creates. Also kill the various wrappers over owl_list_cleanup as they are not the inverse of any operation.
  • Property mode set to 100644
File size: 14.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  /* Add the system lib path to @INC */
406  inc = get_av("INC", 0);
407  path = g_strdup_printf("%s/lib", owl_get_datadir());
408  av_unshift(inc, 1);
409  av_store(inc, 0, owl_new_sv(path));
410  g_free(path);
411
412  eval_pv("use BarnOwl;", FALSE);
413
414  if (SvTRUE(ERRSV)) {
415    err=g_strdup(SvPV_nolen(ERRSV));
416    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
417    return(err);
418  }
419
420  /* check if we have the formatting function */
421  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
422    owl_global_set_config_format(&g, 1);
423  }
424
425  return(NULL);
426}
427
428/* returns whether or not a function exists */
429int owl_perlconfig_is_function(const char *fn) {
430  if (get_cv(fn, FALSE)) return(1);
431  else return(0);
432}
433
434/* caller is responsible for freeing returned string */
435char *owl_perlconfig_execute(const char *line)
436{
437  STRLEN len;
438  SV *response;
439  char *out;
440
441  if (!owl_global_have_config(&g)) return NULL;
442
443  ENTER;
444  SAVETMPS;
445  /* execute the subroutine */
446  response = eval_pv(line, FALSE);
447
448  if (SvTRUE(ERRSV)) {
449    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
450    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
451  }
452
453  out = g_strdup(SvPV(response, len));
454  FREETMPS;
455  LEAVE;
456
457  return(out);
458}
459
460void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
461{
462  char *ptr = NULL;
463  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
464    ptr = owl_perlconfig_call_with_message(subname?subname
465                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
466  }
467  if (ptr) g_free(ptr);
468}
469
470/* Called on all new messages; receivemsg is only called on incoming ones */
471void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
472{
473  char *ptr = NULL;
474  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
475    ptr = owl_perlconfig_call_with_message(subname?subname
476                                           :"BarnOwl::Hooks::_new_msg", m);
477  }
478  if (ptr) g_free(ptr);
479}
480
481void owl_perlconfig_new_command(const char *name)
482{
483  dSP;
484
485  ENTER;
486  SAVETMPS;
487
488  PUSHMARK(SP);
489  XPUSHs(sv_2mortal(owl_new_sv(name)));
490  PUTBACK;
491
492  call_pv("BarnOwl::Hooks::_new_command", G_SCALAR|G_VOID|G_EVAL);
493
494  SPAGAIN;
495
496  if(SvTRUE(ERRSV)) {
497    owl_function_error("%s", SvPV_nolen(ERRSV));
498  }
499
500  FREETMPS;
501  LEAVE;
502}
503
504char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
505{
506  int i, count;
507  char * ret = NULL;
508  SV *rv;
509  dSP;
510
511  ENTER;
512  SAVETMPS;
513
514  PUSHMARK(SP);
515  for(i=0;i<argc;i++) {
516    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
517  }
518  PUTBACK;
519
520  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);
521
522  SPAGAIN;
523
524  if(SvTRUE(ERRSV)) {
525    owl_function_error("%s", SvPV_nolen(ERRSV));
526    (void)POPs;
527  } else {
528    if(count != 1)
529      croak("Perl command %s returned more than one value!", cmd->name);
530    rv = POPs;
531    if(SvTRUE(rv)) {
532      ret = g_strdup(SvPV_nolen(rv));
533    }
534  }
535
536  FREETMPS;
537  LEAVE;
538
539  return ret;
540}
541
542void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
543{
544  SvREFCNT_dec(cmd->cmd_perl);
545}
546
547void owl_perlconfig_io_dispatch_destroy(const owl_io_dispatch *d)
548{
549  SvREFCNT_dec(d->data);
550}
551
552void owl_perlconfig_edit_callback(owl_editwin *e)
553{
554  SV *cb = owl_editwin_get_cbdata(e);
555  SV *text;
556  dSP;
557
558  if(cb == NULL) {
559    owl_function_error("Perl callback is NULL!");
560    return;
561  }
562  text = owl_new_sv(owl_editwin_get_text(e));
563
564  ENTER;
565  SAVETMPS;
566
567  PUSHMARK(SP);
568  XPUSHs(sv_2mortal(text));
569  PUTBACK;
570 
571  call_sv(cb, G_DISCARD|G_EVAL);
572
573  if(SvTRUE(ERRSV)) {
574    owl_function_error("%s", SvPV_nolen(ERRSV));
575  }
576
577  FREETMPS;
578  LEAVE;
579}
580
581void owl_perlconfig_dec_refcnt(void *data)
582{
583  SV *v = data;
584  SvREFCNT_dec(v);
585}
586
587void owl_perlconfig_io_dispatch(const owl_io_dispatch *d, void *data)
588{
589  SV *cb = data;
590  dSP;
591  if(cb == NULL) {
592    owl_function_error("Perl callback is NULL!");
593    return;
594  }
595
596  ENTER;
597  SAVETMPS;
598
599  PUSHMARK(SP);
600  PUTBACK;
601
602  call_sv(cb, G_DISCARD|G_EVAL);
603
604  if(SvTRUE(ERRSV)) {
605    owl_function_error("%s", SvPV_nolen(ERRSV));
606  }
607
608  FREETMPS;
609  LEAVE;
610}
611
612void owl_perlconfig_perl_timer(owl_timer *t, void *data)
613{
614  dSP;
615  SV *obj = data;
616
617  if(!SvROK(obj)) {
618    return;
619  }
620
621  ENTER;
622  SAVETMPS;
623
624  PUSHMARK(SP);
625  XPUSHs(obj);
626  PUTBACK;
627
628  call_method("do_callback", G_DISCARD|G_EVAL);
629
630  SPAGAIN;
631
632  if (SvTRUE(ERRSV)) {
633    owl_function_error("Error in callback: '%s'", SvPV_nolen(ERRSV));
634    sv_setsv (ERRSV, &PL_sv_undef);
635  }
636
637  PUTBACK;
638  FREETMPS;
639  LEAVE;
640}
641
642void owl_perlconfig_perl_timer_destroy(owl_timer *t)
643{
644  if(SvOK((SV*)t->data)) {
645    SvREFCNT_dec((SV*)t->data);
646  }
647}
Note: See TracBrowser for help on using the repository browser.