source: perlconfig.c @ ad37b39

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