source: perlconfig.c @ fd8dfe7

release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since fd8dfe7 was fd8dfe7, checked in by Nelson Elhage <nelhage@mit.edu>, 12 years ago
Load perl code from the filesystem at runtime. Remove perlwrap.pm and associated code, and instead do 'use BarnOwl' at boot time to load cdoe from the file system at runtime. In addition, add appropriate 'use' statements to the .pm files to cause everything to get loaded.
  • Property mode set to 100644
File size: 13.3 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
10static const char fileIdent[] = "$Id$";
11
12extern XS(boot_BarnOwl);
13extern XS(boot_DynaLoader);
14/* extern XS(boot_DBI); */
15
16static void owl_perl_xs_init(pTHX)
17{
18  char *file = __FILE__;
19  dXSUB_SYS;
20  {
21    newXS("BarnOwl::bootstrap", boot_BarnOwl, file);
22    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
23  }
24}
25
26SV *owl_perlconfig_message2hashref(owl_message *m)
27{
28  HV *h, *stash;
29  SV *hr;
30  char *ptr, *blessas, *type;
31  int i, j;
32  owl_pair *pair;
33  owl_filter *wrap;
34
35  if (!m) return &PL_sv_undef;
36  wrap = owl_global_get_filter(&g, "wordwrap");
37  if(!wrap) {
38      owl_function_error("wrap filter is not defined");
39      return &PL_sv_undef;
40  }
41
42  h = newHV();
43
44#define MSG2H(h,field) (void)hv_store(h, #field, strlen(#field),        \
45                                      newSVpv(owl_message_get_##field(m),0), 0)
46
47  if (owl_message_is_type_zephyr(m)
48      && owl_message_is_direction_in(m)) {
49    /* Handle zephyr-specific fields... */
50    AV *av_zfields;
51
52    av_zfields = newAV();
53    j=owl_zephyr_get_num_fields(owl_message_get_notice(m));
54    for (i=0; i<j; i++) {
55      ptr=owl_zephyr_get_field_as_utf8(owl_message_get_notice(m), i+1);
56      av_push(av_zfields, newSVpvn(ptr, strlen(ptr)));
57      owl_free(ptr);
58    }
59    (void)hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
60
61    (void)hv_store(h, "auth", strlen("auth"), 
62                   newSVpv(owl_zephyr_get_authstr(owl_message_get_notice(m)),0),0);
63  }
64
65  j=owl_list_get_size(&(m->attributes));
66  for(i=0; i<j; i++) {
67    pair=owl_list_get_element(&(m->attributes), i);
68    (void)hv_store(h, owl_pair_get_key(pair), strlen(owl_pair_get_key(pair)),
69                   newSVpv(owl_pair_get_value(pair),0),0);
70  }
71 
72  MSG2H(h, type);
73  MSG2H(h, direction);
74  MSG2H(h, class);
75  MSG2H(h, instance);
76  MSG2H(h, sender);
77  MSG2H(h, realm);
78  MSG2H(h, recipient);
79  MSG2H(h, opcode);
80  MSG2H(h, hostname);
81  MSG2H(h, body);
82  MSG2H(h, login);
83  MSG2H(h, zsig);
84  MSG2H(h, zwriteline);
85  if (owl_message_get_header(m)) {
86    MSG2H(h, header); 
87  }
88  (void)hv_store(h, "time", strlen("time"), newSVpv(owl_message_get_timestr(m),0),0);
89  (void)hv_store(h, "id", strlen("id"), newSViv(owl_message_get_id(m)),0);
90  (void)hv_store(h, "deleted", strlen("deleted"), newSViv(owl_message_is_delete(m)),0);
91  (void)hv_store(h, "private", strlen("private"), newSViv(owl_message_is_private(m)),0);
92  (void)hv_store(h, "should_wordwrap",
93                 strlen("should_wordwrap"), newSViv(
94                                                    owl_filter_message_match(wrap, m)),0);
95
96  type = owl_message_get_type(m);
97  if(!type || !*type) type = "generic";
98  type = owl_strdup(type);
99  type[0] = toupper(type[0]);
100  blessas = owl_sprintf("BarnOwl::Message::%s", type);
101
102  hr = newRV_noinc((SV*)h);
103  stash =  gv_stashpv(blessas,0);
104  if(!stash) {
105    owl_function_error("No such class: %s for message type %s", blessas, owl_message_get_type(m));
106    stash = gv_stashpv("BarnOwl::Message", 1);
107  }
108  hr = sv_bless(hr,stash);
109  owl_free(type);
110  owl_free(blessas);
111  return hr;
112}
113
114SV *owl_perlconfig_curmessage2hashref(void) /*noproto*/
115{
116  int curmsg;
117  owl_view *v;
118  v=owl_global_get_current_view(&g);
119  if (owl_view_get_size(v) < 1) {
120    return &PL_sv_undef;
121  }
122  curmsg=owl_global_get_curmsg(&g);
123  return owl_perlconfig_message2hashref(owl_view_get_element(v, curmsg));
124}
125
126/* XXX TODO: Messages should round-trip properly between
127   message2hashref and hashref2message. Currently we lose
128   zephyr-specific properties stored in the ZNotice_t
129
130   This has been somewhat addressed, but is still not lossless.
131 */
132owl_message * owl_perlconfig_hashref2message(SV *msg)
133{
134  owl_message * m;
135  HE * ent;
136  I32 count, len;
137  char *key,*val;
138  HV * hash;
139  struct tm tm;
140
141  hash = (HV*)SvRV(msg);
142
143  m = owl_malloc(sizeof(owl_message));
144  owl_message_init(m);
145
146  count = hv_iterinit(hash);
147  while((ent = hv_iternext(hash))) {
148    key = hv_iterkey(ent, &len);
149    val = SvPV_nolen(hv_iterval(hash, ent));
150    if(!strcmp(key, "type")) {
151      owl_message_set_type(m, val);
152    } else if(!strcmp(key, "direction")) {
153      owl_message_set_direction(m, owl_message_parse_direction(val));
154    } else if(!strcmp(key, "private")) {
155      SV * v = hv_iterval(hash, ent);
156      if(SvTRUE(v)) {
157        owl_message_set_isprivate(m);
158      }
159    } else if (!strcmp(key, "hostname")) {
160      owl_message_set_hostname(m, val);
161    } else if (!strcmp(key, "zwriteline")) {
162      owl_message_set_zwriteline(m, val);
163    } else if (!strcmp(key, "time")) {
164      m->timestr = owl_strdup(val);
165      strptime(val, "%a %b %d %T %Y", &tm);
166      m->time = mktime(&tm);
167    } else {
168      owl_message_set_attribute(m, key, val);
169    }
170  }
171  if(owl_message_is_type_admin(m)) {
172    if(!owl_message_get_attribute_value(m, "adminheader"))
173      owl_message_set_attribute(m, "adminheader", "");
174  }
175#ifdef HAVE_LIBZEPHYR
176  if (owl_message_is_type_zephyr(m)) {
177    ZNotice_t *n = &(m->notice);
178    n->z_kind = ACKED;
179    n->z_port = 0;
180    n->z_auth = ZAUTH_NO;
181    n->z_checked_auth = 0;
182    n->z_class = owl_message_get_class(m);
183    n->z_class_inst = owl_message_get_instance(m);
184    n->z_opcode = owl_message_get_opcode(m);
185    n->z_sender = owl_message_get_sender(m);
186    n->z_recipient = owl_message_get_recipient(m);
187    n->z_default_format = "[zephyr created from perl]";
188    n->z_multinotice = "[zephyr created from perl]";
189    n->z_num_other_fields = 0;
190    n->z_message = owl_sprintf("%s%c%s", owl_message_get_zsig(m), '\0', owl_message_get_body(m));
191    n->z_message_len = strlen(owl_message_get_zsig(m)) + strlen(owl_message_get_body(m)) + 1;
192  }
193#endif
194  return m;
195}
196
197/* Calls in a scalar context, passing it a hash reference.
198   If return value is non-null, caller must free. */
199char *owl_perlconfig_call_with_message(char *subname, owl_message *m)
200{
201  dSP ;
202  int count;
203  SV *msgref, *srv;
204  char *out;
205 
206  ENTER ;
207  SAVETMPS;
208 
209  PUSHMARK(SP) ;
210  msgref = owl_perlconfig_message2hashref(m);
211  XPUSHs(sv_2mortal(msgref));
212  PUTBACK ;
213 
214  count = call_pv(subname, G_SCALAR|G_EVAL|G_KEEPERR);
215 
216  SPAGAIN ;
217
218  if (SvTRUE(ERRSV)) {
219    owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV));
220    /* and clear the error */
221    sv_setsv (ERRSV, &PL_sv_undef);
222  }
223
224  if (count != 1) {
225    fprintf(stderr, "bad perl!  no biscuit!  returned wrong count!\n");
226    abort();
227  }
228
229  srv = POPs;
230
231  if (srv) {
232    out = owl_strdup(SvPV_nolen(srv));
233  } else {
234    out = NULL;
235  }
236 
237  PUTBACK ;
238  FREETMPS ;
239  LEAVE ;
240
241  return out;
242}
243
244
245/* Calls a method on a perl object representing a message.
246   If the return value is non-null, the caller must free it.
247 */
248char * owl_perlconfig_message_call_method(owl_message *m, char *method, int argc, char ** argv)
249{
250  dSP;
251  unsigned int count, i;
252  SV *msgref, *srv;
253  char *out;
254
255  msgref = owl_perlconfig_message2hashref(m);
256
257  ENTER;
258  SAVETMPS;
259
260  PUSHMARK(SP);
261  XPUSHs(sv_2mortal(msgref));
262  for(i=0;i<argc;i++) {
263    XPUSHs(sv_2mortal(newSVpv(argv[i], 0)));
264  }
265  PUTBACK;
266
267  count = call_method(method, G_SCALAR|G_KEEPERR|G_EVAL);
268
269  SPAGAIN;
270
271  if(count != 1) {
272    fprintf(stderr, "perl returned wrong count %d\n", count);
273    abort();
274  }
275
276  if (SvTRUE(ERRSV)) {
277    owl_function_error("Error: '%s'", SvPV_nolen(ERRSV));
278    /* and clear the error */
279    sv_setsv (ERRSV, &PL_sv_undef);
280  }
281
282  srv = POPs;
283
284  if (srv) {
285    out = owl_strdup(SvPV_nolen(srv));
286  } else {
287    out = NULL;
288  }
289
290  PUTBACK;
291  FREETMPS;
292  LEAVE;
293
294  return out;
295}
296
297
298char *owl_perlconfig_initperl(char * file, int *Pargc, char ***Pargv, char *** Penv)
299{
300  int ret;
301  PerlInterpreter *p;
302  char *err;
303  char *args[4] = {"", "-e", "0;", NULL};
304  AV *inc;
305  char *path;
306
307  /* create and initialize interpreter */
308  PERL_SYS_INIT3(Pargc, Pargv, Penv);
309  p=perl_alloc();
310  owl_global_set_perlinterp(&g, (void*)p);
311  perl_construct(p);
312
313  owl_global_set_no_have_config(&g);
314
315  ret=perl_parse(p, owl_perl_xs_init, 2, args, NULL);
316  if (ret || SvTRUE(ERRSV)) {
317    err=owl_strdup(SvPV_nolen(ERRSV));
318    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
319    return(err);
320  }
321
322  ret=perl_run(p);
323  if (ret || SvTRUE(ERRSV)) {
324    err=owl_strdup(SvPV_nolen(ERRSV));
325    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
326    return(err);
327  }
328
329  owl_global_set_have_config(&g);
330
331  /* create legacy variables */
332  get_sv("BarnOwl::id", TRUE);
333  get_sv("BarnOwl::class", TRUE);
334  get_sv("BarnOwl::instance", TRUE);
335  get_sv("BarnOwl::recipient", TRUE);
336  get_sv("BarnOwl::sender", TRUE);
337  get_sv("BarnOwl::realm", TRUE);
338  get_sv("BarnOwl::opcode", TRUE);
339  get_sv("BarnOwl::zsig", TRUE);
340  get_sv("BarnOwl::msg", TRUE);
341  get_sv("BarnOwl::time", TRUE);
342  get_sv("BarnOwl::host", TRUE);
343  get_av("BarnOwl::fields", TRUE);
344
345  if(file) {
346    SV * cfg = get_sv("BarnOwl::configfile", TRUE);
347    sv_setpv(cfg, file);
348  }
349
350  /* Add the system lib path to @INC */
351  inc = get_av("INC", 0);
352  path = owl_sprintf("%s/lib", owl_get_datadir());
353  av_unshift(inc, 1);
354  av_store(inc, 0, newSVpv(path, 0));
355  owl_free(path);
356
357  eval_pv("use BarnOwl;", FALSE);
358
359  if (SvTRUE(ERRSV)) {
360    err=owl_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(char *fn) {
375  if (get_cv(fn, FALSE)) return(1);
376  else return(0);
377}
378
379/* caller is responsible for freeing returned string */
380char *owl_perlconfig_execute(char *line)
381{
382  STRLEN len;
383  SV *response;
384  char *out, *preout;
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  preout=SvPV(response, len);
399  if (len == 0 || preout[len - 1] != '\n')
400    out = owl_sprintf("%s\n", preout);
401  else
402    out = owl_strdup(preout);
403  FREETMPS;
404  LEAVE;
405
406  return(out);
407}
408
409void owl_perlconfig_getmsg(owl_message *m, char *subname)
410{
411  char *ptr = NULL;
412  if (owl_perlconfig_is_function("BarnOwl::Hooks::_receive_msg")) {
413    ptr = owl_perlconfig_call_with_message(subname?subname
414                                           :"BarnOwl::_receive_msg_legacy_wrap", m);
415  }
416  if (ptr) owl_free(ptr);
417}
418
419/* Called on all new messages; receivemsg is only called on incoming ones */
420void owl_perlconfig_newmsg(owl_message *m, char *subname)
421{
422  char *ptr = NULL;
423  if (owl_perlconfig_is_function("BarnOwl::Hooks::_new_msg")) {
424    ptr = owl_perlconfig_call_with_message(subname?subname
425                                           :"BarnOwl::Hooks::_new_msg", m);
426  }
427  if (ptr) owl_free(ptr);
428}
429
430char *owl_perlconfig_perlcmd(owl_cmd *cmd, int argc, char **argv)
431{
432  int i, count;
433  char * ret = NULL;
434  SV *rv;
435  dSP;
436
437  ENTER;
438  SAVETMPS;
439
440  PUSHMARK(SP);
441  for(i=0;i<argc;i++) {
442    SV *tmp = newSVpv(argv[i], 0);
443    SvUTF8_on(tmp);
444    XPUSHs(sv_2mortal(tmp));
445  }
446  PUTBACK;
447
448  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);
449
450  SPAGAIN;
451
452  if(SvTRUE(ERRSV)) {
453    owl_function_error("%s", SvPV_nolen(ERRSV));
454    (void)POPs;
455  } else {
456    if(count != 1)
457      croak("Perl command %s returned more than one value!", cmd->name);
458    rv = POPs;
459    if(SvTRUE(rv)) {
460      ret = owl_strdup(SvPV_nolen(rv));
461    }
462  }
463
464  FREETMPS;
465  LEAVE;
466
467  return ret;
468}
469
470void owl_perlconfig_cmd_free(owl_cmd *cmd)
471{
472  SvREFCNT_dec(cmd->cmd_perl);
473}
474
475void owl_perlconfig_dispatch_free(owl_dispatch *d)
476{
477  SvREFCNT_dec((SV*)d->data);
478  owl_free(d);
479}
480
481void owl_perlconfig_edit_callback(owl_editwin *e)
482{
483  SV *cb = (SV*)(e->cbdata);
484  SV *text;
485  dSP;
486
487  if(cb == NULL) {
488    owl_function_error("Perl callback is NULL!");
489  }
490  text = newSVpv(owl_editwin_get_text(e), 0);
491  SvUTF8_on(text);
492
493  ENTER;
494  SAVETMPS;
495
496  PUSHMARK(SP);
497  XPUSHs(sv_2mortal(text));
498  PUTBACK;
499 
500  call_sv(cb, G_DISCARD|G_KEEPERR|G_EVAL);
501
502  if(SvTRUE(ERRSV)) {
503    owl_function_error("%s", SvPV_nolen(ERRSV));
504  }
505
506  FREETMPS;
507  LEAVE;
508
509  SvREFCNT_dec(cb);
510  e->cbdata = NULL;
511}
512
513void owl_perlconfig_mainloop()
514{
515  dSP;
516  if (!owl_perlconfig_is_function("BarnOwl::Hooks::_mainloop_hook"))
517    return;
518  PUSHMARK(SP) ;
519  call_pv("BarnOwl::Hooks::_mainloop_hook", G_DISCARD|G_EVAL);
520  if(SvTRUE(ERRSV)) {
521    owl_function_error("%s", SvPV_nolen(ERRSV));
522  }
523  return;
524}
525
526void owl_perlconfig_dispatch(owl_dispatch *d)
527{
528  SV *cb = d->data;
529  dSP;
530  if(cb == NULL) {
531    owl_function_error("Perl callback is NULL!");
532    return;
533  }
534
535  ENTER;
536  SAVETMPS;
537
538  PUSHMARK(SP);
539  PUTBACK;
540 
541  call_sv(cb, G_DISCARD|G_KEEPERR|G_EVAL);
542
543  if(SvTRUE(ERRSV)) {
544    owl_function_error("%s", SvPV_nolen(ERRSV));
545  }
546
547  FREETMPS;
548  LEAVE;
549}
550
551void owl_perlconfig_perl_timer(owl_timer *t, void *data)
552{
553  SV *obj = data;
554
555  if(!SvROK(obj)) {
556    return;
557  }
558
559  dSP;
560  ENTER;
561  SAVETMPS;
562
563  PUSHMARK(SP);
564  XPUSHs(obj);
565  PUTBACK;
566
567  call_method("do_callback", G_DISCARD|G_KEEPERR|G_EVAL);
568
569  SPAGAIN;
570
571  if (SvTRUE(ERRSV)) {
572    owl_function_error("Error in calback: '%s'", SvPV_nolen(ERRSV));
573    sv_setsv (ERRSV, &PL_sv_undef);
574  }
575
576  PUTBACK;
577  FREETMPS;
578  LEAVE;
579}
580
581void owl_perlconfig_perl_timer_destroy(owl_timer *t)
582{
583  if(SvOK((SV*)t->data)) {
584    SvREFCNT_dec((SV*)t->data);
585  }
586}
Note: See TracBrowser for help on using the repository browser.