source: perlconfig.c @ 216c734

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 216c734 was 216c734, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 14 years ago
Adding my getstyle patch, which I rely on from perl right now for a number of my "modules".
  • Property mode set to 100644
File size: 8.1 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  hv_store(h, "private", strlen("private"), newSViv(owl_message_is_private(m)),0);
81
82  if (owl_message_is_type_zephyr(m))       blessas = "owl::Message::Zephyr";
83  else if (owl_message_is_type_aim(m))     blessas = "owl::Message::AIM";
84  else if (owl_message_is_type_admin(m))   blessas = "owl::Message::Admin";
85  else if (owl_message_is_type_generic(m)) blessas = "owl::Message::Generic";
86  else                                     blessas = "owl::Message";
87
88  hr = sv_2mortal(newRV_noinc((SV*)h));
89  return sv_bless(hr, gv_stashpv(blessas,0));
90}
91
92
93SV *owl_perlconfig_curmessage2hashref(void) /*noproto*/
94{
95  int curmsg;
96  owl_view *v;
97  v=owl_global_get_current_view(&g);
98  if (owl_view_get_size(v) < 1) {
99    return &PL_sv_undef;
100  }
101  curmsg=owl_global_get_curmsg(&g);
102  return owl_perlconfig_message2hashref(owl_view_get_element(v, curmsg));
103}
104
105
106/* Calls in a scalar context, passing it a hash reference.
107   If return value is non-null, caller must free. */
108char *owl_perlconfig_call_with_message(char *subname, owl_message *m)
109{
110  dSP ;
111  int count, len;
112  SV *msgref, *srv;
113  char *out, *preout;
114 
115  ENTER ;
116  SAVETMPS;
117 
118  PUSHMARK(SP) ;
119  msgref = owl_perlconfig_message2hashref(m);
120  XPUSHs(msgref);
121  PUTBACK ;
122 
123  count = call_pv(subname, G_SCALAR|G_EVAL|G_KEEPERR);
124 
125  SPAGAIN ;
126
127  if (SvTRUE(ERRSV)) {
128    STRLEN n_a;
129    owl_function_error("Perl Error: '%s'", SvPV(ERRSV, n_a));
130    /* and clear the error */
131    sv_setsv (ERRSV, &PL_sv_undef);
132  }
133
134  if (count != 1) {
135    fprintf(stderr, "bad perl!  no biscuit!  returned wrong count!\n");
136    abort();
137  }
138
139  srv = POPs;
140
141  if (srv) {
142    preout=SvPV(srv, len);
143    out = owl_malloc(strlen(preout)+1);
144    strncpy(out, preout, len);
145    out[len] = '\0';
146  } else {
147    out = NULL;
148  }
149 
150  PUTBACK ;
151  FREETMPS ;
152  LEAVE ;
153
154  return out;
155}
156
157char *owl_perlconfig_readconfig(char *file)
158{
159  int ret, fd;
160  PerlInterpreter *p;
161  char filename[1024];
162  char *embedding[5];
163  char *err;
164  struct stat statbuff;
165
166  if (file==NULL) {
167    sprintf(filename, "%s/%s", getenv("HOME"), ".owlconf");
168  } else {
169    strcpy(filename, file);
170  }
171  embedding[0]="";
172  embedding[1]=filename;
173  embedding[2]=0;
174
175  /* create and initialize interpreter */
176  p=perl_alloc();
177  owl_global_set_perlinterp(&g, (void*)p);
178  perl_construct(p);
179
180  owl_global_set_no_have_config(&g);
181
182  /* Before we let perl have at it, we'll do our own checks on the the
183   *  file to see if it's present, readnable etc.
184   */
185
186  /* Not present, start without it */
187  ret=stat(filename, &statbuff);
188  if (ret) {
189    return(NULL);
190  }
191
192  /* present, but stat thinks it's unreadable */
193  if (! (statbuff.st_mode & S_IREAD)) {
194    return(owl_sprintf("%s present but not readable", filename));
195  }
196
197  /* can we open it? */
198  fd=open(filename, O_RDONLY);
199  if (fd==-1) {
200    return(owl_sprintf("could not open %s for reading", filename));
201  }
202  close(fd);
203
204  ret=perl_parse(p, owl_perl_xs_init, 2, embedding, NULL);
205  if (ret || SvTRUE(ERRSV)) {
206    STRLEN n_a;
207    err=owl_strdup(SvPV(ERRSV, n_a));
208    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
209    return(err);
210  }
211
212  ret=perl_run(p);
213  if (ret || SvTRUE(ERRSV)) {
214    STRLEN n_a;
215    err=owl_strdup(SvPV(ERRSV, n_a));
216    sv_setsv(ERRSV, &PL_sv_undef);     /* and clear the error */
217    return(err);
218  }
219
220  owl_global_set_have_config(&g);
221
222  /* create legacy variables */
223  perl_get_sv("owl::id", TRUE);
224  perl_get_sv("owl::class", TRUE);
225  perl_get_sv("owl::instance", TRUE);
226  perl_get_sv("owl::recipient", TRUE);
227  perl_get_sv("owl::sender", TRUE);
228  perl_get_sv("owl::realm", TRUE);
229  perl_get_sv("owl::opcode", TRUE);
230  perl_get_sv("owl::zsig", TRUE);
231  perl_get_sv("owl::msg", TRUE);
232  perl_get_sv("owl::time", TRUE);
233  perl_get_sv("owl::host", TRUE);
234  perl_get_av("owl::fields", TRUE);
235 
236  perl_eval_pv(owl_perlwrap_codebuff, FALSE);
237
238  if (SvTRUE(ERRSV)) {
239    STRLEN n_a;
240    err=owl_strdup(SvPV(ERRSV, n_a));
241    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
242    return(err);
243  }
244
245  /* check if we have the formatting function */
246  if (owl_perlconfig_is_function("owl::format_msg")) {
247    owl_global_set_config_format(&g, 1);
248  }
249
250  return(NULL);
251}
252
253/* returns whether or not a function exists */
254int owl_perlconfig_is_function(char *fn) {
255  if (perl_get_cv(fn, FALSE)) return(1);
256  else return(0);
257}
258
259/* returns 0 on success */
260int owl_perlconfig_get_hashkeys(char *hashname, owl_list *l)
261{
262  HV *hv;
263  HE *he;
264  char *key;
265  I32 i;
266
267  if (owl_list_create(l)) return(-1);
268  hv = get_hv(hashname, FALSE);
269  if (!hv) return(-1);
270  i = hv_iterinit(hv);
271  while ((he = hv_iternext(hv))) {
272    key = hv_iterkey(he, &i);
273    if (key) {
274      owl_list_append_element(l, owl_strdup(key));
275    }
276  }
277  return(0);
278}
279
280/* caller is responsible for freeing returned string */
281char *owl_perlconfig_execute(char *line)
282{
283  STRLEN len;
284  SV *response;
285  char *out, *preout;
286
287  if (!owl_global_have_config(&g)) return NULL;
288
289  /* execute the subroutine */
290  response = perl_eval_pv(line, FALSE);
291
292  if (SvTRUE(ERRSV)) {
293    STRLEN n_a;
294    owl_function_error("Perl Error: '%s'", SvPV(ERRSV, n_a));
295    sv_setsv (ERRSV, &PL_sv_undef);     /* and clear the error */
296  }
297
298  preout=SvPV(response, len);
299  /* leave enough space in case we have to add a newline */
300  out = owl_malloc(strlen(preout)+2);
301  strncpy(out, preout, len);
302  out[len] = '\0';
303  if (!strlen(out) || out[strlen(out)-1]!='\n') {
304    strcat(out, "\n");
305  }
306
307  return(out);
308}
309
310char *owl_perlconfig_getmsg(owl_message *m, int mode, char *subname)
311{ 
312  /* if mode==1 we are doing message formatting.  The returned
313   * formatted message needs to be freed by the caller.
314   *
315   * if mode==0 we are just doing the message-has-been-received
316   * thing.
317   */
318  if (!owl_global_have_config(&g)) return(NULL);
319 
320  /* run the procedure corresponding to the mode */
321  if (mode==1) {
322    char *ret = NULL;
323    ret = owl_perlconfig_call_with_message(subname?subname
324                                           :"owl::_format_msg_legacy_wrap", m);
325    if (!ret) {
326      ret = owl_sprintf("@b([Perl Message Formatting Failed!])\n");
327    } 
328    return ret;
329  } else {
330    char *ptr = NULL;
331    if (owl_perlconfig_is_function("owl::receive_msg")) {
332      ptr = owl_perlconfig_call_with_message(subname?subname
333                                       :"owl::_receive_msg_legacy_wrap", m);
334    }
335    if (ptr) owl_free(ptr);
336    return(NULL);
337  }
338}
Note: See TracBrowser for help on using the repository browser.