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