source: perlconfig.c @ 1e34e40

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