source: perlconfig.c @ 908e388

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 908e388 was 908e388, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
Applying alexmv's patch to allow dynamic loading of perl XS
  • Property mode set to 100644
File size: 8.0 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#include <perl.h>
10#include "XSUB.h"
11
12static const char fileIdent[] = "$Id$";
13
14extern char *owl_perlwrap_codebuff;
15
16extern XS(boot_owl);
17extern XS(boot_DynaLoader);
18extern XS(boot_DBI);
19
20static void owl_perl_xs_init(pTHX)
21{
22  char *file = __FILE__;
23  dXSUB_SYS;
24  {
25    newXS("owl::bootstrap", boot_owl, file);
26    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
27  }
28}
29
30SV *owl_perlconfig_message2hashref(owl_message *m)  /*noproto*/
31{
32  HV *h;
33  SV *hr;
34  char *ptr, *blessas;
35  int i, j;
36
37  if (!m) return &PL_sv_undef;
38  h = newHV();
39
40#define MSG2H(h,field) hv_store(h, #field, strlen(#field), \
41                              newSVpv(owl_message_get_##field(m),0), 0)
42
43  if (owl_message_is_type_zephyr(m)
44      && owl_message_is_direction_in(m)) {
45    /* Handle zephyr-specific fields... */
46    AV *av_zfields;
47
48    av_zfields = newAV();
49    j=owl_zephyr_get_num_fields(owl_message_get_notice(m));
50    for (i=0; i<j; i++) {
51      ptr=owl_zephyr_get_field(owl_message_get_notice(m), i+1);
52      av_push(av_zfields, newSVpvn(ptr, strlen(ptr)));
53      owl_free(ptr);
54    }
55    hv_store(h, "fields", strlen("fields"), newRV_noinc((SV*)av_zfields), 0);
56
57    hv_store(h, "auth", strlen("auth"), 
58             newSVpv(owl_zephyr_get_authstr(owl_message_get_notice(m)),0),0);
59  }
60
61  MSG2H(h, type);
62  MSG2H(h, direction);
63  MSG2H(h, class);
64  MSG2H(h, instance);
65  MSG2H(h, sender);
66  MSG2H(h, realm);
67  MSG2H(h, recipient);
68  MSG2H(h, opcode);
69  MSG2H(h, hostname);
70  MSG2H(h, body);
71  MSG2H(h, login);
72  MSG2H(h, zsig);
73  MSG2H(h, zwriteline);
74  if (owl_message_get_header(m)) {
75    MSG2H(h, header); 
76  }
77  hv_store(h, "time", strlen("time"), newSVpv(owl_message_get_timestr(m),0),0);
78  hv_store(h, "id", strlen("id"), newSViv(owl_message_get_id(m)),0);
79  hv_store(h, "deleted", strlen("deleted"), newSViv(owl_message_is_delete(m)),0);
80
81  if (owl_message_is_type_zephyr(m))       blessas = "owl::Message::Zephyr";
82  else if (owl_message_is_type_aim(m))     blessas = "owl::Message::AIM";
83  else if (owl_message_is_type_admin(m))   blessas = "owl::Message::Admin";
84  else if (owl_message_is_type_generic(m)) blessas = "owl::Message::Generic";
85  else                                     blessas = "owl::Message";
86
87  hr = sv_2mortal(newRV_noinc((SV*)h));
88  return sv_bless(hr, gv_stashpv(blessas,0));
89}
90
91
92SV *owl_perlconfig_curmessage2hashref(void) /*noproto*/
93{
94  int curmsg;
95  owl_view *v;
96  v=owl_global_get_current_view(&g);
97  if (owl_view_get_size(v) < 1) {
98    return &PL_sv_undef;
99  }
100  curmsg=owl_global_get_curmsg(&g);
101  return owl_perlconfig_message2hashref(owl_view_get_element(v, curmsg));
102}
103
104
105/* Calls in a scalar context, passing it a hash reference.
106   If return value is non-null, caller must free. */
107char *owl_perlconfig_call_with_message(char *subname, owl_message *m)
108{
109  dSP ;
110  int count, len;
111  SV *msgref, *srv;
112  char *out, *preout;
113 
114  ENTER ;
115  SAVETMPS;
116 
117  PUSHMARK(SP) ;
118  msgref = owl_perlconfig_message2hashref(m);
119  XPUSHs(msgref);
120  PUTBACK ;
121 
122  count = call_pv(subname, G_SCALAR|G_EVAL|G_KEEPERR);
123 
124  SPAGAIN ;
125
126  if (SvTRUE(ERRSV)) {
127    STRLEN n_a;
128    owl_function_error("Perl Error: '%s'", SvPV(ERRSV, n_a));
129    /* and clear the error */
130    sv_setsv (ERRSV, &PL_sv_undef);
131  }
132
133  if (count != 1) {
134    fprintf(stderr, "bad perl!  no biscuit!  returned wrong count!\n");
135    abort();
136  }
137
138  srv = POPs;
139
140  if (srv) {
141    preout=SvPV(srv, len);
142    out = owl_malloc(strlen(preout)+1);
143    strncpy(out, preout, len);
144    out[len] = '\0';
145  } else {
146    out = NULL;
147  }
148 
149  PUTBACK ;
150  FREETMPS ;
151  LEAVE ;
152
153  return out;
154}
155
156char *owl_perlconfig_readconfig(char *file)
157{
158  int ret, fd;
159  PerlInterpreter *p;
160  char filename[1024];
161  char *embedding[5];
162  char *err;
163  struct stat statbuff;
164
165  if (file==NULL) {
166    sprintf(filename, "%s/%s", getenv("HOME"), ".owlconf");
167  } else {
168    strcpy(filename, file);
169  }
170  embedding[0]="";
171  embedding[1]=filename;
172  embedding[2]=0;
173
174  /* create and initialize interpreter */
175  p=perl_alloc();
176  owl_global_set_perlinterp(&g, (void*)p);
177  perl_construct(p);
178
179  owl_global_set_no_have_config(&g);
180
181  /* Before we let perl have at it, we'll do our own checks on the the
182   *  file to see if it's present, readnable etc.
183   */
184
185  /* Not present, start without it */
186  ret=stat(filename, &statbuff);
187  if (ret) {
188    return(NULL);
189  }
190
191  /* present, but stat thinks it's unreadable */
192  if (! (statbuff.st_mode & S_IREAD)) {
193    return(owl_sprintf("%s present but not readable", filename));
194  }
195
196  /* can we open it? */
197  fd=open(filename, O_RDONLY);
198  if (fd==-1) {
199    return(owl_sprintf("could not open %s for reading", filename));
200  }
201  close(fd);
202
203  ret=perl_parse(p, owl_perl_xs_init, 2, embedding, NULL);
204  if (ret || SvTRUE(ERRSV)) {
205    STRLEN n_a;
206    err=owl_strdup(SvPV(ERRSV, n_a));
207    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
208    return(err);
209  }
210
211  ret=perl_run(p);
212  if (ret || SvTRUE(ERRSV)) {
213    STRLEN n_a;
214    err=owl_strdup(SvPV(ERRSV, n_a));
215    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
216    return(err);
217  }
218
219  owl_global_set_have_config(&g);
220
221  /* create legacy variables */
222  perl_get_sv("owl::id", TRUE);
223  perl_get_sv("owl::class", TRUE);
224  perl_get_sv("owl::instance", TRUE);
225  perl_get_sv("owl::recipient", TRUE);
226  perl_get_sv("owl::sender", TRUE);
227  perl_get_sv("owl::realm", TRUE);
228  perl_get_sv("owl::opcode", TRUE);
229  perl_get_sv("owl::zsig", TRUE);
230  perl_get_sv("owl::msg", TRUE);
231  perl_get_sv("owl::time", TRUE);
232  perl_get_sv("owl::host", TRUE);
233  perl_get_av("owl::fields", TRUE);
234 
235  perl_eval_pv(owl_perlwrap_codebuff, FALSE);
236
237  if (SvTRUE(ERRSV)) {
238    STRLEN n_a;
239    err=owl_strdup(SvPV(ERRSV, n_a));
240    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
241    return(err);
242  }
243
244  /* check if we have the formatting function */
245  if (owl_perlconfig_is_function("owl::format_msg")) {
246    owl_global_set_config_format(&g, 1);
247  }
248
249  return(NULL);
250}
251
252/* returns whether or not a function exists */
253int owl_perlconfig_is_function(char *fn) {
254  if (perl_get_cv(fn, FALSE)) return(1);
255  else return(0);
256}
257
258/* returns 0 on success */
259int owl_perlconfig_get_hashkeys(char *hashname, owl_list *l)
260{
261  HV *hv;
262  HE *he;
263  char *key;
264  I32 i;
265
266  if (owl_list_create(l)) return(-1);
267  hv = get_hv(hashname, FALSE);
268  if (!hv) return(-1);
269  i = hv_iterinit(hv);
270  while ((he = hv_iternext(hv))) {
271    key = hv_iterkey(he, &i);
272    if (key) {
273      owl_list_append_element(l, owl_strdup(key));
274    }
275  }
276  return(0);
277}
278
279/* caller is responsible for freeing returned string */
280char *owl_perlconfig_execute(char *line)
281{
282  STRLEN len;
283  SV *response;
284  char *out, *preout;
285
286  if (!owl_global_have_config(&g)) return NULL;
287
288  /* execute the subroutine */
289  response = perl_eval_pv(line, FALSE);
290
291  if (SvTRUE(ERRSV)) {
292    STRLEN n_a;
293    owl_function_error("Perl Error: '%s'", SvPV(ERRSV, n_a));
294    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
295  }
296
297  preout=SvPV(response, len);
298  /* leave enough space in case we have to add a newline */
299  out = owl_malloc(strlen(preout)+2);
300  strncpy(out, preout, len);
301  out[len] = '\0';
302  if (!strlen(out) || out[strlen(out)-1]!='\n') {
303    strcat(out, "\n");
304  }
305
306  return(out);
307}
308
309char *owl_perlconfig_getmsg(owl_message *m, int mode, char *subname)
310{ 
311  /* if mode==1 we are doing message formatting.  The returned
312   * formatted message needs to be freed by the caller.
313   *
314   * if mode==0 we are just doing the message-has-been-received
315   * thing.
316   */
317  if (!owl_global_have_config(&g)) return(NULL);
318 
319  /* run the procedure corresponding to the mode */
320  if (mode==1) {
321    char *ret = NULL;
322    ret = owl_perlconfig_call_with_message(subname?subname
323                                           :"owl::_format_msg_legacy_wrap", m);
324    if (!ret) {
325      ret = owl_sprintf("@b([Perl Message Formatting Failed!])\n");
326    } 
327    return ret;
328  } else {
329    char *ptr = NULL;
330    if (owl_perlconfig_is_function("owl::receive_msg")) {
331      ptr = owl_perlconfig_call_with_message(subname?subname
332                                       :"owl::_receive_msg_legacy_wrap", m);
333    }
334    if (ptr) owl_free(ptr);
335    return(NULL);
336  }
337}
Note: See TracBrowser for help on using the repository browser.