source: perlconfig.c @ d6bc343

release-1.10
Last change on this file since d6bc343 was 96d80e9, checked in by Jason Gross <jgross@mit.edu>, 11 years ago
Added support for calling perl subs with various return types
  • Property mode set to 100644
File size: 15.0 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  SV *msgref, *rv;
231  char *out = NULL;
232
233  msgref = owl_perlconfig_message2hashref(m);
234
235  OWL_PERL_CALL((call_pv(subname, G_SCALAR|G_EVAL))
236                ,
237                XPUSHs(sv_2mortal(msgref));
238                ,
239                "Perl Error: '%s'"
240                ,
241                false
242                ,
243                false
244                ,
245                rv = POPs;
246                if (rv && SvPOK(rv))
247                  out = g_strdup(SvPV_nolen(rv));
248                );
249  return out;
250}
251
252
253/* Calls a method on a perl object representing a message.
254   If the return value is non-null, the caller must free it.
255 */
256CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv)
257{
258  SV *msgref, *rv;
259  char *out = NULL;
260  int i;
261
262  msgref = owl_perlconfig_message2hashref(m);
263
264  OWL_PERL_CALL(call_method(method, G_SCALAR|G_EVAL)
265                ,
266                XPUSHs(sv_2mortal(msgref));
267                OWL_PERL_PUSH_ARGS(i, argc, argv);
268                ,
269                "Perl Error: '%s'"
270                ,
271                false
272                ,
273                false
274                ,
275                rv = POPs;
276                if (rv && SvPOK(rv))
277                  out = g_strdup(SvPV_nolen(rv));
278                );
279  return out;
280}
281
282/* caller must free result, if not NULL */
283CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv)
284{
285  int ret;
286  PerlInterpreter *p;
287  char *err;
288  const char *args[4] = {"", "-e", "0;", NULL};
289  const char *dlerr;
290  AV *inc;
291  char *path;
292
293  /* create and initialize interpreter */
294  PERL_SYS_INIT3(Pargc, Pargv, Penv);
295  p=perl_alloc();
296  owl_global_set_perlinterp(&g, p);
297  perl_construct(p);
298
299  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
300
301  owl_global_set_no_have_config(&g);
302
303  ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL);
304  if (ret || SvTRUE(ERRSV)) {
305    err=g_strdup(SvPV_nolen(ERRSV));
306    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
307    return(err);
308  }
309
310  ret=perl_run(p);
311  if (ret || SvTRUE(ERRSV)) {
312    err=g_strdup(SvPV_nolen(ERRSV));
313    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
314    return(err);
315  }
316
317  owl_global_set_have_config(&g);
318
319  /* create legacy variables */
320  get_sv("BarnOwl::id", TRUE);
321  get_sv("BarnOwl::class", TRUE);
322  get_sv("BarnOwl::instance", TRUE);
323  get_sv("BarnOwl::recipient", TRUE);
324  get_sv("BarnOwl::sender", TRUE);
325  get_sv("BarnOwl::realm", TRUE);
326  get_sv("BarnOwl::opcode", TRUE);
327  get_sv("BarnOwl::zsig", TRUE);
328  get_sv("BarnOwl::msg", TRUE);
329  get_sv("BarnOwl::time", TRUE);
330  get_sv("BarnOwl::host", TRUE);
331  get_av("BarnOwl::fields", TRUE);
332
333  if(file) {
334    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
335    sv_setpv(cfg, file);
336  }
337
338  sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING);
339
340  /* Add the system lib path to @INC */
341  inc = get_av("INC", 0);
342  path = g_build_filename(owl_get_datadir(), "lib", NULL);
343  av_unshift(inc, 1);
344  av_store(inc, 0, owl_new_sv(path));
345  g_free(path);
346
347  /* Load up perl-Glib. */
348  eval_pv("use Glib;", FALSE);
349
350  /* Now, before BarnOwl tries to use them, get the relevant function pointers out. */
351  dlerr = owl_closure_init();
352  if (dlerr) {
353    return g_strdup(dlerr);
354  }
355
356  /* And now it's safe to import BarnOwl. */
357  eval_pv("use BarnOwl;", FALSE);
358
359  if (SvTRUE(ERRSV)) {
360    err=g_strdup(SvPV_nolen(ERRSV));
361    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
362    return(err);
363  }
364
365  /* check if we have the formatting function */
366  if (owl_perlconfig_is_function("BarnOwl::format_msg")) {
367    owl_global_set_config_format(&g, 1);
368  }
369
370  return(NULL);
371}
372
373/* returns whether or not a function exists */
374int owl_perlconfig_is_function(const char *fn) {
375  if (get_cv(fn, FALSE)) return(1);
376  else return(0);
377}
378
379/* caller is responsible for freeing returned string */
380CALLER_OWN char *owl_perlconfig_execute(const char *line)
381{
382  STRLEN len;
383  SV *response;
384  char *out;
385
386  if (!owl_global_have_config(&g)) return NULL;
387
388  ENTER;
389  SAVETMPS;
390  /* execute the subroutine */
391  response = eval_pv(line, FALSE);
392
393  if (SvTRUE(ERRSV)) {
394    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
395    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
396  }
397
398  out = g_strdup(SvPV(response, len));
399  FREETMPS;
400  LEAVE;
401
402  return(out);
403}
404
405void owl_perlconfig_getmsg(const owl_message *m, const char *subname)
406{
407  char *ptr = NULL;
408  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
409    ptr = owl_perlconfig_call_with_message(subname?subname
410                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
411  }
412  g_free(ptr);
413}
414
415/* Called on all new messages; receivemsg is only called on incoming ones */
416void owl_perlconfig_newmsg(const owl_message *m, const char *subname)
417{
418  char *ptr = NULL;
419  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
420    ptr = owl_perlconfig_call_with_message(subname?subname
421                                           :"BarnOwl::Hooks::_new_msg", m);
422  }
423  g_free(ptr);
424}
425
426void owl_perlconfig_new_command(const char *name)
427{
428  OWL_PERL_CALL(call_pv("BarnOwl::Hooks::_new_command", G_VOID|G_EVAL);
429                ,
430                XPUSHs(sv_2mortal(owl_new_sv(name)));
431                ,
432                "Perl Error: '%s'"
433                ,
434                false
435                ,
436                true
437                ,
438                );
439}
440
441CALLER_OWN char *owl_perlconfig_perl_call(const char *method, int argc, const char *const *argv)
442{
443  SV *rv;
444  char *out = NULL;
445  int i;
446  OWL_PERL_CALL(call_pv(method, G_SCALAR|G_EVAL)
447                ,
448                OWL_PERL_PUSH_ARGS(i, argc, argv);
449                ,
450                "Perl Error: '%s'"
451                ,
452                false
453                ,
454                false
455                ,
456                rv = POPs;
457                if (rv && SvPOK(rv))
458                  out = g_strdup(SvPV_nolen(rv));
459                );
460  return out;
461}
462
463int owl_perlconfig_perl_call_int(const char *method, int argc, const char *const *argv)
464{
465  SV *rv;
466  int ret = -1;
467  int i;
468  OWL_PERL_CALL(call_pv(method, G_SCALAR|G_EVAL)
469                ,
470                OWL_PERL_PUSH_ARGS(i, argc, argv);
471                ,
472                "Perl Error: '%s'"
473                ,
474                false
475                ,
476                false
477                ,
478                rv = POPs;
479                if (rv && SvIOK(rv))
480                  ret = SvIV(rv);
481                );
482  return ret;
483}
484
485bool owl_perlconfig_perl_call_bool(const char *method, int argc, const char *const *argv)
486{
487  SV *rv;
488  bool ret = false;
489  int i;
490  OWL_PERL_CALL(call_pv(method, G_SCALAR|G_EVAL)
491                ,
492                OWL_PERL_PUSH_ARGS(i, argc, argv);
493                ,
494                "Perl Error: '%s'"
495                ,
496                false
497                ,
498                false
499                ,
500                rv = POPs;
501                if (rv)
502                  ret = SvTRUE(rv);
503                );
504  return ret;
505}
506
507void owl_perlconfig_perl_call_norv(const char *method, int argc, const char *const *argv)
508{
509  int i;
510  OWL_PERL_CALL(call_pv(method, G_DISCARD|G_EVAL)
511                ,
512                OWL_PERL_PUSH_ARGS(i, argc, argv);
513                ,
514                "Perl Error: '%s'"
515                ,
516                false
517                ,
518                true
519                ,
520                );
521}
522
523/* caller must free the result */
524CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv)
525{
526  int i;
527  SV* rv;
528  char *out = NULL;
529
530  OWL_PERL_CALL(call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL)
531                ,
532                OWL_PERL_PUSH_ARGS(i, argc, argv);
533                ,
534                "Perl Error: '%s'"
535                ,
536                false
537                ,
538                false
539                ,
540                rv = POPs;
541                if (rv && SvPOK(rv))
542                  out = g_strdup(SvPV_nolen(rv));
543                );
544  return out;
545}
546
547void owl_perlconfig_cmd_cleanup(owl_cmd *cmd)
548{
549  SvREFCNT_dec(cmd->cmd_perl);
550}
551
552void owl_perlconfig_edit_callback(owl_editwin *e, bool success)
553{
554  SV *cb = owl_editwin_get_cbdata(e);
555  SV *text = owl_new_sv(owl_editwin_get_text(e));
556
557  if (cb == NULL) {
558    owl_function_error("Perl callback is NULL!");
559    return;
560  }
561
562  OWL_PERL_CALL(call_sv(cb, G_DISCARD|G_EVAL)
563                ,
564                XPUSHs(sv_2mortal(text));
565                XPUSHs(sv_2mortal(newSViv(success)));
566                ,
567                "Perl Error: '%s'"
568                ,
569                false
570                ,
571                true
572                ,
573                );
574}
575
576void owl_perlconfig_dec_refcnt(void *data)
577{
578  SV *v = data;
579  SvREFCNT_dec(v);
580}
Note: See TracBrowser for help on using the repository browser.