source: perlconfig.c @ 0a9ffc5

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