source: perlconfig.c @ e1ed6f4

release-1.10release-1.9
Last change on this file since e1ed6f4 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
RevLine 
[908e388]1#define OWL_PERL
[f1e629d]2#include "owl.h"
[f271129]3#include <stdio.h>
[f1e629d]4
[8203afd]5extern XS(boot_BarnOwl);
[908e388]6extern XS(boot_DynaLoader);
[af1920fd]7/* extern XS(boot_DBI); */
[f1e629d]8
[5aa33fd]9void owl_perl_xs_init(pTHX) /* noproto */
[c3acb0b]10{
[e19eb97]11  const char *file = __FILE__;
[f1e629d]12  dXSUB_SYS;
13  {
[8203afd]14    newXS("BarnOwl::bootstrap", boot_BarnOwl, file);
[908e388]15    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
[f1e629d]16  }
17}
18
[d1b1cf6]19
[6829afc]20CALLER_OWN SV *owl_new_sv(const char * str)
[d1b1cf6]21{
22  SV *ret = newSVpv(str, 0);
[68f358c]23  if (is_utf8_string((const U8 *)str, strlen(str))) {
[d1b1cf6]24    SvUTF8_on(ret);
25  } else {
[eea72a13]26    char *escape = owl_escape_highbit(str);
27    owl_function_error("Internal error! Non-UTF-8 string encountered:\n%s", escape);
[ddbbcffa]28    g_free(escape);
[d1b1cf6]29  }
30  return ret;
31}
32
[ce68f23]33CALLER_OWN AV *owl_new_av(const GPtrArray *l, SV *(*to_sv)(const void *))
[e67359b]34{
35  AV *ret;
36  int i;
37  void *element;
38
39  ret = newAV();
40
[ce68f23]41  for (i = 0; i < l->len; i++) {
42    element = l->pdata[i];
[e67359b]43    av_push(ret, to_sv(element));
44  }
45
46  return ret;
47}
48
[6829afc]49CALLER_OWN HV *owl_new_hv(const owl_dict *d, SV *(*to_sv)(const void *))
[e7f5970]50{
51  HV *ret;
[ce68f23]52  GPtrArray *keys;
[e7f5970]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 */
[ce68f23]60  keys = owl_dict_get_keys(d);
61  for (i = 0; i < keys->len; i++) {
62    key = keys->pdata[i];
[e7f5970]63    element = owl_dict_find_element(d, key);
64    (void)hv_store(ret, key, strlen(key), to_sv(element), 0);
65  }
[ce68f23]66  owl_ptr_array_free(keys, g_free);
[e7f5970]67
68  return ret;
69}
70
[6829afc]71CALLER_OWN SV *owl_perlconfig_message2hashref(const owl_message *m)
[c3acb0b]72{
[1cc95709]73  HV *h, *stash;
[f1e629d]74  SV *hr;
[e19eb97]75  const char *type;
[fa4562c]76  char *ptr, *utype, *blessas;
[b0430a6]77  int i, j;
[25fb825]78  const owl_pair *pair;
[4542047]79  const owl_filter *wrap;
[f1e629d]80
81  if (!m) return &PL_sv_undef;
[f6b319c]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
[f1e629d]88  h = newHV();
89
[3ea31b6]90#define MSG2H(h,field) (void)hv_store(h, #field, strlen(#field),        \
[d1b1cf6]91                                      owl_new_sv(owl_message_get_##field(m)), 0)
[f1e629d]92
[b9517cf]93  if (owl_message_get_notice(m)) {
[f1e629d]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++) {
[5376a95]100      ptr=owl_zephyr_get_field_as_utf8(owl_message_get_notice(m), i+1);
[d1b1cf6]101      av_push(av_zfields, owl_new_sv(ptr));
[ddbbcffa]102      g_free(ptr);
[f1e629d]103    }
[3ea31b6]104    (void)hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
[f1e629d]105
[3ea31b6]106    (void)hv_store(h, "auth", strlen("auth"), 
[d1b1cf6]107                   owl_new_sv(owl_zephyr_get_authstr(owl_message_get_notice(m))),0);
[f1e629d]108  }
109
[f9df2f0]110  for (i = 0; i < m->attributes->len; i++) {
111    pair = m->attributes->pdata[i];
[3ea31b6]112    (void)hv_store(h, owl_pair_get_key(pair), strlen(owl_pair_get_key(pair)),
[d1b1cf6]113                   owl_new_sv(owl_pair_get_value(pair)),0);
[421c8ef7]114  }
115 
[f1e629d]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  }
[d1b1cf6]132  (void)hv_store(h, "time", strlen("time"), owl_new_sv(owl_message_get_timestr(m)),0);
[d1ae4a4]133  (void)hv_store(h, "unix_time", strlen("unix_time"), newSViv(m->time), 0);
[3ea31b6]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);
[f1e629d]140
[30678ae]141  type = owl_message_get_type(m);
[8fba2ee]142  if(!type || !*type) type = "generic";
[d4927a7]143  utype = g_strdup(type);
[fa4562c]144  utype[0] = toupper(type[0]);
[3472845]145  blessas = g_strdup_printf("BarnOwl::Message::%s", utype);
[f1e629d]146
[19bab8e]147  hr = newRV_noinc((SV*)h);
[1cc95709]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);
[ddbbcffa]154  g_free(utype);
155  g_free(blessas);
[30678ae]156  return hr;
[f1e629d]157}
158
[6829afc]159CALLER_OWN SV *owl_perlconfig_curmessage2hashref(void)
[c3acb0b]160{
[f1e629d]161  int curmsg;
[9e5c9f3]162  const owl_view *v;
[f1e629d]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
[30678ae]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 */
[6829afc]175CALLER_OWN owl_message *owl_perlconfig_hashref2message(SV *msg)
[30678ae]176{
177  owl_message * m;
178  HE * ent;
[c107129]179  I32 len;
[e19eb97]180  const char *key,*val;
[30678ae]181  HV * hash;
[ad15610]182  struct tm tm;
[30678ae]183
184  hash = (HV*)SvRV(msg);
185
[96828e4]186  m = g_new(owl_message, 1);
[30678ae]187  owl_message_init(m);
188
[c107129]189  hv_iterinit(hash);
[30678ae]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")) {
[937a00e9]207      g_free(m->timestr);
[d4927a7]208      m->timestr = g_strdup(val);
[30678ae]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}
[f1e629d]221
222/* Calls in a scalar context, passing it a hash reference.
223   If return value is non-null, caller must free. */
[6829afc]224CALLER_OWN char *owl_perlconfig_call_with_message(const char *subname, const owl_message *m)
[c3acb0b]225{
[f1e629d]226  dSP ;
[c4ba74d]227  int count;
[f1e629d]228  SV *msgref, *srv;
[909771e]229  char *out;
[f1e629d]230 
231  ENTER ;
232  SAVETMPS;
233 
234  PUSHMARK(SP) ;
235  msgref = owl_perlconfig_message2hashref(m);
[19bab8e]236  XPUSHs(sv_2mortal(msgref));
[f1e629d]237  PUTBACK ;
238 
[e3068de]239  count = call_pv(subname, G_SCALAR|G_EVAL);
[f1e629d]240 
241  SPAGAIN ;
242
243  if (SvTRUE(ERRSV)) {
[ce6721f]244    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
[27c3a93]245    /* and clear the error */
246    sv_setsv (ERRSV, &PL_sv_undef);
[f1e629d]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) {
[d4927a7]257    out = g_strdup(SvPV_nolen(srv));
[f1e629d]258  } else {
259    out = NULL;
260  }
261 
262  PUTBACK ;
263  FREETMPS ;
264  LEAVE ;
265
266  return out;
267}
268
[25729b2]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 */
[6829afc]273CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv)
[25729b2]274{
275  dSP;
[909771e]276  unsigned int count, i;
[25729b2]277  SV *msgref, *srv;
[909771e]278  char *out;
[25729b2]279
280  msgref = owl_perlconfig_message2hashref(m);
281
282  ENTER;
283  SAVETMPS;
284
285  PUSHMARK(SP);
[19bab8e]286  XPUSHs(sv_2mortal(msgref));
[25729b2]287  for(i=0;i<argc;i++) {
[d1b1cf6]288    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
[25729b2]289  }
290  PUTBACK;
291
[e3068de]292  count = call_method(method, G_SCALAR|G_EVAL);
[25729b2]293
294  SPAGAIN;
295
296  if(count != 1) {
[f278ff3]297    fprintf(stderr, "perl returned wrong count %u\n", count);
[25729b2]298    abort();
299  }
300
301  if (SvTRUE(ERRSV)) {
[ce6721f]302    owl_function_error("Error: '%s'", SvPV_nolen(ERRSV));
[25729b2]303    /* and clear the error */
304    sv_setsv (ERRSV, &PL_sv_undef);
305  }
306
307  srv = POPs;
308
309  if (srv) {
[d4927a7]310    out = g_strdup(SvPV_nolen(srv));
[25729b2]311  } else {
312    out = NULL;
313  }
314
315  PUTBACK;
316  FREETMPS;
317  LEAVE;
318
319  return out;
320}
321
[d427f08]322/* caller must free result, if not NULL */
[6829afc]323CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
[c3acb0b]324{
[d03091c]325  int ret;
[f1e629d]326  PerlInterpreter *p;
[4e0f545]327  char *err;
[e19eb97]328  const char *args[4] = {"", "-e", "0;", NULL};
[fd8dfe7]329  AV *inc;
330  char *path;
[f1e629d]331
332  /* create and initialize interpreter */
[e8c6d8f]333  PERL_SYS_INIT3(Pargc, Pargv, Penv);
[f1e629d]334  p=perl_alloc();
[4d86e06]335  owl_global_set_perlinterp(&g, p);
[f1e629d]336  perl_construct(p);
337
[5aa33fd]338  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
339
[f1e629d]340  owl_global_set_no_have_config(&g);
341
[fa4562c]342  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
[f1e629d]343  if (ret || SvTRUE(ERRSV)) {
[d4927a7]344    err=g_strdup(SvPV_nolen(ERRSV));
[4e0f545]345    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
346    return(err);
[f1e629d]347  }
348
349  ret=perl_run(p);
350  if (ret || SvTRUE(ERRSV)) {
[d4927a7]351    err=g_strdup(SvPV_nolen(ERRSV));
[4e0f545]352    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
353    return(err);
[f1e629d]354  }
355
356  owl_global_set_have_config(&g);
357
358  /* create legacy variables */
[c415aca]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);
[00f9a7d]371
372  if(file) {
[8203afd]373    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
[00f9a7d]374    sv_setpv(cfg, file);
375  }
376
[f2d71cfa]377  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
378
[fd8dfe7]379  /* Add the system lib path to @INC */
380  inc = get_av("INC", 0);
[dde1b4d]381  path = g_build_filename(owl_get_datadir(), "lib", NULL);
[fd8dfe7]382  av_unshift(inc, 1);
[d1b1cf6]383  av_store(inc, 0, owl_new_sv(path));
[ddbbcffa]384  g_free(path);
[fd8dfe7]385
386  eval_pv("use BarnOwl;", FALSE);
[f1e629d]387
388  if (SvTRUE(ERRSV)) {
[d4927a7]389    err=g_strdup(SvPV_nolen(ERRSV));
[27c3a93]390    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
[4e0f545]391    return(err);
[f1e629d]392  }
393
394  /* check if we have the formatting function */
[8203afd]395  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
[f1e629d]396    owl_global_set_config_format(&g, 1);
397  }
398
399  return(NULL);
400}
401
402/* returns whether or not a function exists */
[e19eb97]403int owl_perlconfig_is_function(const char *fn) {
[c415aca]404  if (get_cv(fn, FALSE)) return(1);
[f1e629d]405  else return(0);
406}
407
408/* caller is responsible for freeing returned string */
[6829afc]409CALLER_OWN char *owl_perlconfig_execute(const char *line)
[c3acb0b]410{
[f1e629d]411  STRLEN len;
412  SV *response;
[65b2173]413  char *out;
[f1e629d]414
415  if (!owl_global_have_config(&g)) return NULL;
416
[e0096b7]417  ENTER;
418  SAVETMPS;
[f1e629d]419  /* execute the subroutine */
[c415aca]420  response = eval_pv(line, FALSE);
[f1e629d]421
422  if (SvTRUE(ERRSV)) {
[ce6721f]423    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
[27c3a93]424    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
[f1e629d]425  }
426
[d4927a7]427  out = g_strdup(SvPV(response, len));
[e0096b7]428  FREETMPS;
429  LEAVE;
[f1e629d]430
431  return(out);
432}
433
[c08c70a]434void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
[b67ab6b]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);
[f1e629d]440  }
[3b8a563]441  g_free(ptr);
[0f9eca7]442}
443
444/* Called on all new messages; receivemsg is only called on incoming ones */
[c08c70a]445void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
[0f9eca7]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  }
[3b8a563]452  g_free(ptr);
[f1e629d]453}
[6922edd]454
[e19eb97]455void owl_perlconfig_new_command(const char *name)
[eb6cedc]456{
457  dSP;
458
459  ENTER;
460  SAVETMPS;
461
462  PUSHMARK(SP);
[d1b1cf6]463  XPUSHs(sv_2mortal(owl_new_sv(name)));
[eb6cedc]464  PUTBACK;
465
[a9237aa]466  call_pv("BarnOwl::Hooks::_new_command", G_VOID|G_EVAL);
[eb6cedc]467
468  SPAGAIN;
469
470  if(SvTRUE(ERRSV)) {
471    owl_function_error("%s", SvPV_nolen(ERRSV));
472  }
473
474  FREETMPS;
475  LEAVE;
476}
477
[d427f08]478/* caller must free the result */
[6829afc]479CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
[6922edd]480{
481  int i, count;
482  char * ret = NULL;
[ad15610]483  SV *rv;
[6922edd]484  dSP;
485
486  ENTER;
487  SAVETMPS;
488
489  PUSHMARK(SP);
490  for(i=0;i<argc;i++) {
[d1b1cf6]491    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
[6922edd]492  }
493  PUTBACK;
494
495  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);
496
497  SPAGAIN;
498
499  if(SvTRUE(ERRSV)) {
[ce6721f]500    owl_function_error("%s", SvPV_nolen(ERRSV));
[c4ba74d]501    (void)POPs;
[6922edd]502  } else {
503    if(count != 1)
504      croak("Perl command %s returned more than one value!", cmd->name);
[ad15610]505    rv = POPs;
[6922edd]506    if(SvTRUE(rv)) {
[d4927a7]507      ret = g_strdup(SvPV_nolen(rv));
[6922edd]508    }
509  }
510
511  FREETMPS;
512  LEAVE;
513
514  return ret;
515}
516
[8f2d9bf]517void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
[6922edd]518{
[ff13a6f]519  SvREFCNT_dec(cmd->cmd_perl);
[6922edd]520}
[db8b00b]521
522void owl_perlconfig_edit_callback(owl_editwin *e)
523{
[4d86e06]524  SV *cb = owl_editwin_get_cbdata(e);
[367fbf3]525  SV *text;
[ad15610]526  dSP;
527
[db8b00b]528  if(cb == NULL) {
529    owl_function_error("Perl callback is NULL!");
[1373d35]530    return;
[db8b00b]531  }
[d1b1cf6]532  text = owl_new_sv(owl_editwin_get_text(e));
[db8b00b]533
534  ENTER;
535  SAVETMPS;
536
537  PUSHMARK(SP);
[367fbf3]538  XPUSHs(sv_2mortal(text));
[db8b00b]539  PUTBACK;
540 
[e3068de]541  call_sv(cb, G_DISCARD|G_EVAL);
[9364a36]542
543  if(SvTRUE(ERRSV)) {
[ce6721f]544    owl_function_error("%s", SvPV_nolen(ERRSV));
[9364a36]545  }
[db8b00b]546
547  FREETMPS;
548  LEAVE;
[1b1cd2c]549}
[db8b00b]550
[1b1cd2c]551void owl_perlconfig_dec_refcnt(void *data)
552{
553  SV *v = data;
554  SvREFCNT_dec(v);
[db8b00b]555}
Note: See TracBrowser for help on using the repository browser.