source: perlconfig.c @ b7a74a8

release-1.10
Last change on this file since b7a74a8 was 6401db3, checked in by David Benjamin <davidben@mit.edu>, 12 years ago
Fix display of pseudologins After b9517cf7ce2959a6e86a52d25a98b1d03df56d58, they lost fields and auth keys. They're faked, so they don't really have fields or auth, but put them in anyway to appease existing styles. Reported-By: Kevin Chen <kchen@mit.edu>
  • Property mode set to 100644
File size: 13.1 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  const char *f;
78  int i;
79  const owl_pair *pair;
80  const owl_filter *wrap;
81
82  if (!m) return &PL_sv_undef;
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
89  h = newHV();
90
91#define MSG2H(h,field) (void)hv_store(h, #field, strlen(#field),        \
92                                      owl_new_sv(owl_message_get_##field(m)), 0)
93
94  if (owl_message_is_type_zephyr(m) && owl_message_is_direction_in(m)) {
95    /* Handle zephyr-specific fields... */
96    AV *av_zfields = newAV();
97    if (owl_message_get_notice(m)) {
98      for (f = owl_zephyr_first_raw_field(owl_message_get_notice(m)); f != NULL;
99           f = owl_zephyr_next_raw_field(owl_message_get_notice(m), f)) {
100        ptr = owl_zephyr_field_as_utf8(owl_message_get_notice(m), f);
101        av_push(av_zfields, owl_new_sv(ptr));
102        g_free(ptr);
103      }
104      (void)hv_store(h, "auth", strlen("auth"),
105                     owl_new_sv(owl_zephyr_get_authstr(owl_message_get_notice(m))), 0);
106    } else {
107      /* Incoming zephyrs without a ZNotice_t are pseudo-logins. To appease
108       * existing styles, put in bogus 'auth' and 'fields' keys. */
109      (void)hv_store(h, "auth", strlen("auth"), owl_new_sv("NO"), 0);
110    }
111    (void)hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
112  }
113
114  for (i = 0; i < m->attributes->len; i++) {
115    pair = m->attributes->pdata[i];
116    (void)hv_store(h, owl_pair_get_key(pair), strlen(owl_pair_get_key(pair)),
117                   owl_new_sv(owl_pair_get_value(pair)),0);
118  }
119 
120  MSG2H(h, type);
121  MSG2H(h, direction);
122  MSG2H(h, class);
123  MSG2H(h, instance);
124  MSG2H(h, sender);
125  MSG2H(h, realm);
126  MSG2H(h, recipient);
127  MSG2H(h, opcode);
128  MSG2H(h, hostname);
129  MSG2H(h, body);
130  MSG2H(h, login);
131  MSG2H(h, zsig);
132  MSG2H(h, zwriteline);
133  if (owl_message_get_header(m)) {
134    MSG2H(h, header); 
135  }
136  (void)hv_store(h, "time", strlen("time"), owl_new_sv(owl_message_get_timestr(m)),0);
137  (void)hv_store(h, "unix_time", strlen("unix_time"), newSViv(m->time), 0);
138  (void)hv_store(h, "id", strlen("id"), newSViv(owl_message_get_id(m)),0);
139  (void)hv_store(h, "deleted", strlen("deleted"), newSViv(owl_message_is_delete(m)),0);
140  (void)hv_store(h, "private", strlen("private"), newSViv(owl_message_is_private(m)),0);
141  (void)hv_store(h, "should_wordwrap",
142                 strlen("should_wordwrap"), newSViv(
143                                                    owl_filter_message_match(wrap, m)),0);
144
145  type = owl_message_get_type(m);
146  if(!type || !*type) type = "generic";
147  utype = g_strdup(type);
148  utype[0] = toupper(type[0]);
149  blessas = g_strdup_printf("BarnOwl::Message::%s", utype);
150
151  hr = newRV_noinc((SV*)h);
152  stash =  gv_stashpv(blessas,0);
153  if(!stash) {
154    owl_function_error("No such class: %s for message type %s", blessas, owl_message_get_type(m));
155    stash = gv_stashpv("BarnOwl::Message", 1);
156  }
157  hr = sv_bless(hr,stash);
158  g_free(utype);
159  g_free(blessas);
160  return hr;
161}
162
163CALLER_OWN SV *owl_perlconfig_curmessage2hashref(void)
164{
165  int curmsg;
166  const owl_view *v;
167  v=owl_global_get_current_view(&g);
168  if (owl_view_get_size(v) < 1) {
169    return &PL_sv_undef;
170  }
171  curmsg=owl_global_get_curmsg(&g);
172  return owl_perlconfig_message2hashref(owl_view_get_element(v, curmsg));
173}
174
175/* XXX TODO: Messages should round-trip properly between
176   message2hashref and hashref2message. Currently we lose
177   zephyr-specific properties stored in the ZNotice_t
178 */
179CALLER_OWN owl_message *owl_perlconfig_hashref2message(SV *msg)
180{
181  owl_message * m;
182  HE * ent;
183  I32 len;
184  const char *key,*val;
185  HV * hash;
186  struct tm tm;
187
188  hash = (HV*)SvRV(msg);
189
190  m = g_new(owl_message, 1);
191  owl_message_init(m);
192
193  hv_iterinit(hash);
194  while((ent = hv_iternext(hash))) {
195    key = hv_iterkey(ent, &len);
196    val = SvPV_nolen(hv_iterval(hash, ent));
197    if(!strcmp(key, "type")) {
198      owl_message_set_type(m, val);
199    } else if(!strcmp(key, "direction")) {
200      owl_message_set_direction(m, owl_message_parse_direction(val));
201    } else if(!strcmp(key, "private")) {
202      SV * v = hv_iterval(hash, ent);
203      if(SvTRUE(v)) {
204        owl_message_set_isprivate(m);
205      }
206    } else if (!strcmp(key, "hostname")) {
207      owl_message_set_hostname(m, val);
208    } else if (!strcmp(key, "zwriteline")) {
209      owl_message_set_zwriteline(m, val);
210    } else if (!strcmp(key, "time")) {
211      g_free(m->timestr);
212      m->timestr = g_strdup(val);
213      strptime(val, "%a %b %d %T %Y", &tm);
214      m->time = mktime(&tm);
215    } else {
216      owl_message_set_attribute(m, key, val);
217    }
218  }
219  if(owl_message_is_type_admin(m)) {
220    if(!owl_message_get_attribute_value(m, "adminheader"))
221      owl_message_set_attribute(m, "adminheader", "");
222  }
223  return m;
224}
225
226/* Calls in a scalar context, passing it a hash reference.
227   If return value is non-null, caller must free. */
228CALLER_OWN char *owl_perlconfig_call_with_message(const char *subname, const owl_message *m)
229{
230  dSP ;
231  int count;
232  SV *msgref, *srv;
233  char *out;
234 
235  ENTER ;
236  SAVETMPS;
237 
238  PUSHMARK(SP) ;
239  msgref = owl_perlconfig_message2hashref(m);
240  XPUSHs(sv_2mortal(msgref));
241  PUTBACK ;
242 
243  count = call_pv(subname, G_SCALAR|G_EVAL);
244 
245  SPAGAIN ;
246
247  if (SvTRUE(ERRSV)) {
248    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
249    /* and clear the error */
250    sv_setsv (ERRSV, &PL_sv_undef);
251  }
252
253  if (count != 1) {
254    fprintf(stderr, "bad perl!  no biscuit!  returned wrong count!\n");
255    abort();
256  }
257
258  srv = POPs;
259
260  if (srv) {
261    out = g_strdup(SvPV_nolen(srv));
262  } else {
263    out = NULL;
264  }
265 
266  PUTBACK ;
267  FREETMPS ;
268  LEAVE ;
269
270  return out;
271}
272
273
274/* Calls a method on a perl object representing a message.
275   If the return value is non-null, the caller must free it.
276 */
277CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv)
278{
279  dSP;
280  unsigned int count, i;
281  SV *msgref, *srv;
282  char *out;
283
284  msgref = owl_perlconfig_message2hashref(m);
285
286  ENTER;
287  SAVETMPS;
288
289  PUSHMARK(SP);
290  XPUSHs(sv_2mortal(msgref));
291  for(i=0;i<argc;i++) {
292    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
293  }
294  PUTBACK;
295
296  count = call_method(method, G_SCALAR|G_EVAL);
297
298  SPAGAIN;
299
300  if(count != 1) {
301    fprintf(stderr, "perl returned wrong count %u\n", count);
302    abort();
303  }
304
305  if (SvTRUE(ERRSV)) {
306    owl_function_error("Error: '%s'", SvPV_nolen(ERRSV));
307    /* and clear the error */
308    sv_setsv (ERRSV, &PL_sv_undef);
309  }
310
311  srv = POPs;
312
313  if (srv) {
314    out = g_strdup(SvPV_nolen(srv));
315  } else {
316    out = NULL;
317  }
318
319  PUTBACK;
320  FREETMPS;
321  LEAVE;
322
323  return out;
324}
325
326/* caller must free result, if not NULL */
327CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
328{
329  int ret;
330  PerlInterpreter *p;
331  char *err;
332  const char *args[4] = {"", "-e", "0;", NULL};
333  AV *inc;
334  char *path;
335
336  /* create and initialize interpreter */
337  PERL_SYS_INIT3(Pargc, Pargv, Penv);
338  p=perl_alloc();
339  owl_global_set_perlinterp(&g, p);
340  perl_construct(p);
341
342  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
343
344  owl_global_set_no_have_config(&g);
345
346  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
347  if (ret || SvTRUE(ERRSV)) {
348    err=g_strdup(SvPV_nolen(ERRSV));
349    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
350    return(err);
351  }
352
353  ret=perl_run(p);
354  if (ret || SvTRUE(ERRSV)) {
355    err=g_strdup(SvPV_nolen(ERRSV));
356    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
357    return(err);
358  }
359
360  owl_global_set_have_config(&g);
361
362  /* create legacy variables */
363  get_sv("BarnOwl::id", TRUE);
364  get_sv("BarnOwl::class", TRUE);
365  get_sv("BarnOwl::instance", TRUE);
366  get_sv("BarnOwl::recipient", TRUE);
367  get_sv("BarnOwl::sender", TRUE);
368  get_sv("BarnOwl::realm", TRUE);
369  get_sv("BarnOwl::opcode", TRUE);
370  get_sv("BarnOwl::zsig", TRUE);
371  get_sv("BarnOwl::msg", TRUE);
372  get_sv("BarnOwl::time", TRUE);
373  get_sv("BarnOwl::host", TRUE);
374  get_av("BarnOwl::fields", TRUE);
375
376  if(file) {
377    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
378    sv_setpv(cfg, file);
379  }
380
381  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
382
383  /* Add the system lib path to @INC */
384  inc = get_av("INC", 0);
385  path = g_build_filename(owl_get_datadir(), "lib", NULL);
386  av_unshift(inc, 1);
387  av_store(inc, 0, owl_new_sv(path));
388  g_free(path);
389
390  eval_pv("use BarnOwl;", FALSE);
391
392  if (SvTRUE(ERRSV)) {
393    err=g_strdup(SvPV_nolen(ERRSV));
394    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
395    return(err);
396  }
397
398  /* check if we have the formatting function */
399  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
400    owl_global_set_config_format(&g, 1);
401  }
402
403  return(NULL);
404}
405
406/* returns whether or not a function exists */
407int owl_perlconfig_is_function(const char *fn) {
408  if (get_cv(fn, FALSE)) return(1);
409  else return(0);
410}
411
412/* caller is responsible for freeing returned string */
413CALLER_OWN char *owl_perlconfig_execute(const char *line)
414{
415  STRLEN len;
416  SV *response;
417  char *out;
418
419  if (!owl_global_have_config(&g)) return NULL;
420
421  ENTER;
422  SAVETMPS;
423  /* execute the subroutine */
424  response = eval_pv(line, FALSE);
425
426  if (SvTRUE(ERRSV)) {
427    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
428    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
429  }
430
431  out = g_strdup(SvPV(response, len));
432  FREETMPS;
433  LEAVE;
434
435  return(out);
436}
437
438void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
439{
440  char *ptr = NULL;
441  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
442    ptr = owl_perlconfig_call_with_message(subname?subname
443                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
444  }
445  g_free(ptr);
446}
447
448/* Called on all new messages; receivemsg is only called on incoming ones */
449void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
450{
451  char *ptr = NULL;
452  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
453    ptr = owl_perlconfig_call_with_message(subname?subname
454                                           :"BarnOwl::Hooks::_new_msg", m);
455  }
456  g_free(ptr);
457}
458
459void owl_perlconfig_new_command(const char *name)
460{
461  dSP;
462
463  ENTER;
464  SAVETMPS;
465
466  PUSHMARK(SP);
467  XPUSHs(sv_2mortal(owl_new_sv(name)));
468  PUTBACK;
469
470  call_pv("BarnOwl::Hooks::_new_command", G_VOID|G_EVAL);
471
472  SPAGAIN;
473
474  if(SvTRUE(ERRSV)) {
475    owl_function_error("%s", SvPV_nolen(ERRSV));
476  }
477
478  FREETMPS;
479  LEAVE;
480}
481
482/* caller must free the result */
483CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
484{
485  int i, count;
486  char * ret = NULL;
487  SV *rv;
488  dSP;
489
490  ENTER;
491  SAVETMPS;
492
493  PUSHMARK(SP);
494  for(i=0;i<argc;i++) {
495    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));
496  }
497  PUTBACK;
498
499  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);
500
501  SPAGAIN;
502
503  if(SvTRUE(ERRSV)) {
504    owl_function_error("%s", SvPV_nolen(ERRSV));
505    (void)POPs;
506  } else {
507    if(count != 1)
508      croak("Perl command %s returned more than one value!", cmd->name);
509    rv = POPs;
510    if(SvTRUE(rv)) {
511      ret = g_strdup(SvPV_nolen(rv));
512    }
513  }
514
515  FREETMPS;
516  LEAVE;
517
518  return ret;
519}
520
521void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
522{
523  SvREFCNT_dec(cmd->cmd_perl);
524}
525
526void owl_perlconfig_edit_callback(owl_editwin *e, bool success)
527{
528  SV *cb = owl_editwin_get_cbdata(e);
529  SV *text;
530  dSP;
531
532  if(cb == NULL) {
533    owl_function_error("Perl callback is NULL!");
534    return;
535  }
536  text = owl_new_sv(owl_editwin_get_text(e));
537
538  ENTER;
539  SAVETMPS;
540
541  PUSHMARK(SP);
542  XPUSHs(sv_2mortal(text));
543  XPUSHs(sv_2mortal(newSViv(success)));
544  PUTBACK;
545 
546  call_sv(cb, G_DISCARD|G_EVAL);
547
548  if(SvTRUE(ERRSV)) {
549    owl_function_error("%s", SvPV_nolen(ERRSV));
550  }
551
552  FREETMPS;
553  LEAVE;
554}
555
556void owl_perlconfig_dec_refcnt(void *data)
557{
558  SV *v = data;
559  SvREFCNT_dec(v);
560}
Note: See TracBrowser for help on using the repository browser.