/* * Copyright (c) 1998-2000 Carnegie Mellon University. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The name "Carnegie Mellon University" must not be used to * endorse or promote products derived from this software without * prior written permission. For permission or any other legal * details, please contact * Office of Technology Transfer * Carnegie Mellon University * 5000 Forbes Avenue * Pittsburgh, PA 15213-3890 * (412) 268-4387, fax: (412) 268-7395 * tech-transfer@andrew.cmu.edu * * 4. Redistributions of any form whatsoever must retain the following * acknowledgment: * "This product includes software developed by Computing Services * at Carnegie Mellon University (http://www.cmu.edu/computing/)." * * CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE * FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN * AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING * OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * */ /* $Id: IMAP.xs,v 1.25 2006/11/30 17:11:23 murch Exp $ */ /* * Perl interface to the Cyrus imclient routines. This enables the * use of Perl to implement Cyrus utilities, in particular imtest and cyradm. */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include <pwd.h> #include <unistd.h> #include "imclient.h" #include "imapurl.h" #include "xmalloc.h" #include "cyrperl.h" #include "config.h" typedef struct xscyrus *Cyrus_IMAP; /* Perl pre-5.6.0 compatibility */ #ifndef aTHX_ #define aTHX_ #endif /* * This is the code from xsutil.c */ /* hack, since libcyrus apparently expects fatal() to exist */ void fatal(const char *s, int exit) { croak(s); } /* * Decrement the refcounts of the Perl SV's in the passed rock, then free the * rock. This cleans up a callback. */ void imclient_xs_callback_free(struct xsccb *rock) { struct xscb *xcb; if (rock) { /* find the destructor-cleanup version and nuke its record */ for (xcb = rock->client->cb; xcb; xcb = xcb->next) { if (xcb->rock == rock) break; } if (xcb) { if (xcb->prev) xcb->prev->next = xcb->next; else rock->client->cb = xcb->next; if (xcb->next) xcb->next->prev = xcb->prev; if (xcb->name) safefree(xcb->name); safefree(xcb); } /* if (rock->pcb) SvREFCNT_dec(rock->pcb); */ /* if (rock->prock) SvREFCNT_dec(rock->prock); */ safefree(rock); } } /* * Invoke a Perl callback on behalf of a Cyrus callback. This requires some * silliness to adapt what we're passed to Perl conventions; specifically, * the reply struct becomes a hash (passed as a list). */ void imclient_xs_cb(struct imclient *client, void *prock, struct imclient_reply *reply) { dSP; dTARG; SV* rv; struct xsccb *rock = (struct xsccb *) prock; /* push our args onto Perl's stack */ ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("-client", 0))); rv = newSVsv(&sv_undef); sv_setref_pv(rv, NULL, (void *) rock->client); XPUSHs(rv); if (rock->prock != &sv_undef) { XPUSHs(sv_2mortal(newSVpv("-rock", 0))); XPUSHs(sv_mortalcopy(rock->prock)); } XPUSHs(sv_2mortal(newSVpv("-keyword", 0))); XPUSHs(sv_2mortal(newSVpv(reply->keyword, 0))); XPUSHs(sv_2mortal(newSVpv("-text", 0))); XPUSHs(sv_2mortal(newSVpv(reply->text, 0))); if (reply->msgno != -1) { char tmp[100]; XPUSHs(sv_2mortal(newSVpv("-msgno", 0))); sprintf(tmp,"%d",reply->msgno); XPUSHs(sv_2mortal(newSVpv(tmp, 0))); } PUTBACK; /* invoke Perl */ perl_call_sv(rock->pcb, G_VOID|G_DISCARD); FREETMPS; SPAGAIN; LEAVE; /* clean up */ if (rock->autofree) imclient_xs_callback_free(rock); } /* * Callback used when ::_send is invoked without a callback. The "prock" is an * AV, which is set to the contents of the imclient_reply; this is detected in * ::_send, which is calling imclient_processoneevent() repeatedly. (This * simulates a non-callback-based invocation, for trivial clients.) */ void imclient_xs_fcmdcb(struct imclient *client, void *prock, struct imclient_reply *reply) { AV *av; struct xsccb *rock = (struct xsccb *) prock; /* SvREFCNT_dec(SvRV(rock->prock)); */ SvRV(rock->prock) = (SV *) (av = newAV()); /* sv_setsv(rock->prock, sv_2mortal(newRV_inc((SV *) (av = newAV())))); */ av_push(av, sv_2mortal(newSVpv(reply->keyword, 0))); av_push(av, sv_2mortal(newSVpv(reply->text, 0))); if (reply->msgno != -1) av_push(av, sv_2mortal(newSViv(reply->msgno))); /* clean up */ if (rock->autofree) imclient_xs_callback_free(rock); } static int get_username(void *context, int id, const char **result, unsigned *len) { Cyrus_IMAP text = (Cyrus_IMAP)context; if(id == SASL_CB_AUTHNAME) { if(len) *len = strlen(text->authname); *result = text->authname; return SASL_OK; } else if (id == SASL_CB_USER) { if(text->username) { if(len) *len = strlen(text->username); *result = text->username; } else { if(len) *len = 0; *result = ""; } return SASL_OK; } return SASL_FAIL; } static int get_password(sasl_conn_t *conn, void *context, int id, sasl_secret_t **psecret) { Cyrus_IMAP text = (Cyrus_IMAP)context; if(id != SASL_CB_PASS) return SASL_FAIL; if(!text->password) { char *ptr; /* Using fprintf because printf won't flush under perl 5.8.0 for some * reason */ fprintf(stdout, "Password: "); fflush(stdout); ptr = getpass(""); text->password = safemalloc(sizeof(sasl_secret_t) + strlen(ptr)); text->password->len = strlen(ptr); strncpy((char *) text->password->data, ptr, text->password->len); } *psecret = text->password; return SASL_OK; } /* callbacks we support */ static const sasl_callback_t sample_callbacks[NUM_SUPPORTED_CALLBACKS] = { { SASL_CB_USER, get_username, NULL }, { SASL_CB_AUTHNAME, get_username, NULL }, { SASL_CB_PASS, get_password, NULL }, { SASL_CB_LIST_END, NULL, NULL } }; MODULE = Cyrus::IMAP PACKAGE = Cyrus::IMAP PROTOTYPES: ENABLE int CONN_NONSYNCLITERAL() CODE: RETVAL = IMCLIENT_CONN_NONSYNCLITERAL; OUTPUT: RETVAL int CONN_INITIALRESPONSE() CODE: RETVAL = IMCLIENT_CONN_INITIALRESPONSE; OUTPUT: RETVAL int CALLBACK_NUMBERED() CODE: RETVAL = CALLBACK_NUMBERED; OUTPUT: RETVAL int CALLBACK_NOLITERAL() CODE: RETVAL = CALLBACK_NOLITERAL; OUTPUT: RETVAL MODULE = Cyrus::IMAP PACKAGE = Cyrus::IMAP PREFIX=imclient_ PROTOTYPES: ENABLE SV * imclient_new(class, host = "localhost", port = 0, flags = 0) char *class; char *host char *port int flags; PREINIT: struct imclient *client; int rc; SV *bang; Cyrus_IMAP rv; int i; CODE: /* Allocate and setup the return value */ rv = safemalloc(sizeof *rv); rv->authenticated = 0; memcpy(rv->callbacks, sample_callbacks, sizeof(sample_callbacks)); /* Setup respective contexts */ for(i=0; i < NUM_SUPPORTED_CALLBACKS; i++) { rv->callbacks[i].context = rv; } /* Connect */ rc = imclient_connect(&client, host, port, rv->callbacks); switch (rc) { case -1: Perl_croak(aTHX_ "imclient_connect: unknown host \"%s\"", host); safefree(rv); break; case -2: Perl_croak(aTHX_ "imclient_connect: unknown service \"%s\"", port); safefree(rv); break; case 0: if (client) { rv->class = safemalloc(strlen(class) + 1); strcpy(rv->class, class); rv->username = rv->authname = NULL; rv->password = NULL; rv->imclient = client; imclient_setflags(client, flags); rv->flags = flags; rv->cb = 0; rv->cnt = 1; break; } /*FALLTHROUGH*/ default: bang = perl_get_sv("^E", TRUE); sv_setiv(bang, rc); XSRETURN_UNDEF; } ST(0) = sv_newmortal(); /* fprintf(stderr, "!NEW %p %s\n", rv, class); */ sv_setref_pv(ST(0), class, (void *) rv); void imclient_DESTROY(client) Cyrus_IMAP client PREINIT: struct xscb *nx; CODE: /* fprintf(stderr, "!DESTROY %p %d\n", client, client->cnt); */ if (!--client->cnt) { /* printf("closing\n"); */ imclient_close(client->imclient); while (client->cb) { nx = client->cb->next; if (client->cb->name) safefree(client->cb->name); /* if (client->cb->rock->pcb) SvREFCNT_dec(client->cb->rock->pcb); */ /* if (client->cb->rock->prock) SvREFCNT_dec(client->cb->rock->prock); */ safefree(client->cb->rock); client->cb = nx; } safefree(client->password); safefree(client->class); safefree(client); } void imclient_setflags(client, flags) Cyrus_IMAP client int flags PPCODE: imclient_setflags(client->imclient, flags); client->flags |= flags; void imclient_clearflags(client, flags) Cyrus_IMAP client int flags PPCODE: imclient_clearflags(client->imclient, flags); client->flags &= ~flags; int imclient_flags(client) Cyrus_IMAP client PPCODE: /* why is there no way to query this? */ RETVAL = client->flags; char * imclient_servername(client) Cyrus_IMAP client PREINIT: char *cp; CODE: cp = imclient_servername(client->imclient); RETVAL = cp; OUTPUT: RETVAL void imclient_processoneevent(client) Cyrus_IMAP client PPCODE: imclient_processoneevent(client->imclient); SV * imclient__authenticate(client, mechlist, service, user, auth, password, minssf, maxssf) Cyrus_IMAP client char* mechlist char* service char* user char* auth char* password int minssf int maxssf PREINIT: int rc; CODE: ST(0) = sv_newmortal(); if(client->authenticated) { ST(0) = &sv_no; return; } /* If the user parameter is undef, set user to be NULL */ if(!SvOK(ST(3))) user = NULL; if(!SvOK(ST(5))) password = NULL; client->username = user; /* AuthZid */ client->authname = auth; /* Authid */ if(password) { if(client->password) safefree(client->password); client->password = safemalloc(sizeof(sasl_secret_t) + strlen(password)); client->password->len = strlen(password); strncpy((char *) client->password->data, password, client->password->len); } rc = imclient_authenticate(client->imclient, mechlist, service, user, minssf, maxssf); if (rc) ST(0) = &sv_no; else { client->authenticated = 1; ST(0) = &sv_yes; } int imclient_havetls() CODE: #ifdef HAVE_SSL RETVAL = 1; #else RETVAL = 0; #endif /* HAVE_SSL */ OUTPUT: RETVAL SV * imclient__starttls(client, tls_cert_file, tls_key_file, CAfile, CApath) Cyrus_IMAP client char* tls_cert_file char* tls_key_file char* CAfile char* CApath PREINIT: int rc; int tls_layer; CODE: ST(0) = sv_newmortal(); /* If the tls_{cert, key}_file parameters are undef, set to be NULL */ if(!SvOK(ST(2))) tls_cert_file = NULL; if(!SvOK(ST(3))) tls_key_file = NULL; #ifdef HAVE_SSL rc = imclient_starttls(client->imclient, tls_cert_file, tls_key_file, CAfile, CApath); if (rc) ST(0) = &sv_no; else { ST(0) = &sv_yes; } #else ST(0) = &sv_no; #endif /* HAVE_SSL */ void imclient_addcallback(client, ...) Cyrus_IMAP client PREINIT: int arg; HV *cb; char *keyword; STRLEN klen; int flags; SV **val; SV *pcb; SV *prock; struct xsccb *rock; struct xscb *xcb; PPCODE: /* * $client->addcallback(\%cb[, ...]); * * where %cb is: * * -trigger => 'OK' (or 'NO', etc.) * -flags => CALLBACK_NOLITERAL|CALLBACK_NUMBERED (optional) * -callback => \&sub or undef (optional) * -rock => SV, reference or undef (optional) * * this is moderately complicated because the callback is a Perl ref... */ for (arg = 1; arg < items; arg++) { if (!SvROK(ST(arg)) || SvTYPE(SvRV(ST(arg))) != SVt_PVHV) Perl_croak(aTHX_ "addcallback: arg %d not a hash reference", arg); cb = (HV *) SvRV(ST(arg)); /* pull callback crud */ if (((val = hv_fetch(cb, "-trigger", 8, 0)) || (val = hv_fetch(cb, "Trigger", 7, 0))) && SvTYPE(*val) == SVt_PV) keyword = SvPV(*val, klen); else Perl_croak(aTHX_ "addcallback: arg %d missing trigger", arg); if ((((val = hv_fetch(cb, "-flags", 6, 0)) || (val = hv_fetch(cb, "Flags", 5, 0))))) { flags = SvIV(*val); } else { flags = 0; } if (((val = hv_fetch(cb, "-callback", 9, 0)) || (val = hv_fetch(cb, "Callback", 8, 0))) && ((SvROK(*val) && SvTYPE(SvRV(*val)) == SVt_PVCV) || SvTYPE(*val) == SVt_PV)) pcb = *val; else pcb = 0; if ((val = hv_fetch(cb, "-rock", 5, 0)) || (val = hv_fetch(cb, "Rock", 4, 0))) prock = *val; else prock = &sv_undef; /* * build our internal rock, which is used by our internal * callback handler to invoke the Perl callback */ if (!pcb) rock = 0; else { rock = (struct xsccb *) safemalloc(sizeof *rock); /* bump refcounts on these so they don't go away */ rock->pcb = SvREFCNT_inc(pcb); if (!prock) prock = &sv_undef; rock->prock = SvREFCNT_inc(prock); rock->client = client; rock->autofree = 0; } /* and add the resulting callback */ imclient_addcallback(client->imclient, keyword, flags, (pcb ? imclient_xs_cb : 0), rock, 0); /* update the callback list, possibly freeing old callback info */ for (xcb = client->cb; xcb; xcb = xcb->next) { if (xcb->name && strcmp(xcb->name, keyword) == 0 && xcb->flags == flags) break; } if (xcb) { if (xcb->rock->pcb) SvREFCNT_dec(xcb->rock->pcb); if (xcb->rock->prock) SvREFCNT_dec(xcb->rock->prock); safefree(xcb->rock); } else if (pcb) { xcb = (struct xscb *) safemalloc(sizeof *xcb); xcb->prev = 0; xcb->name = safemalloc(strlen(keyword) + 1); strcpy(xcb->name, keyword); xcb->flags = flags; xcb->next = client->cb; client->cb = xcb; } if (pcb) xcb->rock = rock; else if (xcb) { if (xcb->prev) xcb->prev->next = xcb->next; else client->cb = xcb->next; if (xcb->next) xcb->next->prev = xcb->prev; safefree(xcb->name); safefree(xcb); } } void imclient__send(client, finishproc, finishrock, str) Cyrus_IMAP client SV *finishproc SV *finishrock char *str PREINIT: STRLEN arg; SV *pcb; SV *prock; struct xscb *xcb; struct xsccb *rock; char *cp, *dp, *xstr; PPCODE: /* * The C version does escapes. It also does varargs, which I would * much rather not have to reimplement in XS code; so that is done in * Perl instead. (The minus being that I have to track any changes * to the C API; but it'll be easier in Perl than in XS.) * * We still have to do the callback, though. * * @@@ the Perl code can't do synchronous literals */ if (SvROK(finishproc) && SvTYPE(SvRV(finishproc)) == SVt_PVCV) pcb = SvRV(finishproc); else pcb = 0; if (!pcb) prock = sv_2mortal(newRV_inc(&PL_sv_undef)); else if (finishrock) prock = finishrock; else prock = sv_2mortal(newSVsv(&PL_sv_undef)); /* * build our internal rock, which is used by our internal * callback handler to invoke the Perl callback */ rock = (struct xsccb *) safemalloc(sizeof *rock); /* bump refcounts on these so they don't go away */ if (!pcb) pcb = sv_2mortal(newSVsv(&PL_sv_undef)); rock->pcb = pcb; if (!prock) prock = sv_2mortal(newSVsv(&PL_sv_undef)); rock->prock = prock; rock->client = client; rock->autofree = 1; /* register this callback so it can be gc'ed properly (pointless?) */ xcb = (struct xscb *) safemalloc(sizeof *xcb); xcb->prev = 0; xcb->name = 0; xcb->flags = 0; xcb->rock = rock; xcb->next = client->cb; client->cb = xcb; /* protect %'s in the string, since the caller does the dirty work */ arg = 0; for (cp = str; *cp; cp++) if (*cp == '%') arg++; xstr = safemalloc(strlen(str) + arg + 1); dp = xstr; for (cp = str; *cp; cp++) { *dp++ = *cp; if (*cp == '%') *dp++ = *cp; } *dp = 0; /* and do it to it */ imclient_send(client->imclient, (SvTRUE(pcb) ? imclient_xs_cb : imclient_xs_fcmdcb), (void *) rock, xstr); safefree(xstr); /* if there was no Perl callback, spin on events until finished */ if (!SvTRUE(pcb)) { AV *av; while (SvTYPE(SvRV(prock)) != SVt_PVAV) { PUTBACK; imclient_processoneevent(client->imclient); SPAGAIN; } /* push the result; if scalar, stuff text in $@ */ av = (AV *) SvRV(prock); if (GIMME_V == G_SCALAR) { EXTEND(SP, 1); pcb = av_shift(av); if (strcmp(SvPV(pcb, arg), "OK") == 0) PUSHs(&sv_yes); else PUSHs(&sv_no); pcb = perl_get_sv("@", TRUE); sv_setsv(pcb, av_shift(av)); if (av_len(av) != -1) { pcb = perl_get_sv("^E", TRUE); sv_setsv(pcb, av_shift(av)); } } else { EXTEND(SP, av_len(av) + 1); PUSHs(av_shift(av)); PUSHs(av_shift(av)); if (av_len(av) != -1) PUSHs(av_shift(av)); } /* and free it */ /* SvREFCNT_dec(prock); */ } void imclient_getselectinfo(client) Cyrus_IMAP client PREINIT: int fd, writep; PPCODE: imclient_getselectinfo(client->imclient, &fd, &writep); /* * should this return a glob? (evil, but would solve a nasty issue * in &send()...) * * also, should this check for scalar context and complain? */ EXTEND(SP, 2); PUSHs(sv_2mortal(newSViv(fd))); if (writep) PUSHs(&sv_yes); else PUSHs(&sv_no); void imclient_fromURL(client,url) Cyrus_IMAP client char *url PREINIT: struct imapurl imapurl; PPCODE: imapurl_fromURL(&imapurl, url); if(!imapurl.server || !imapurl.mailbox) { safefree(imapurl.freeme); XSRETURN_UNDEF; } XPUSHs(sv_2mortal(newSVpv(imapurl.server, 0))); XPUSHs(sv_2mortal(newSVpv(imapurl.mailbox, 0))); /* newSVpv copies the above */ safefree(imapurl.freeme); XSRETURN(2); void imclient_toURL(client,server,box) Cyrus_IMAP client char *server char *box PREINIT: char *out_buf; int len; struct imapurl imapurl; PPCODE: len = strlen(server)+strlen(box); out_buf = safemalloc(4*len); memset(&imapurl, 0, sizeof(struct imapurl)); imapurl.server = server; imapurl.mailbox = box; imapurl_toURL(out_buf, &imapurl); if(!out_buf[0]) { safefree(out_buf); XSRETURN_UNDEF; } XPUSHs(sv_2mortal(newSVpv(out_buf, 0))); /* newSVpv copies this */ safefree(out_buf); XSRETURN(1);