1 /*
2 # Copyright (c) 2002 Carnegie Mellon University
3 # Written by Mark Adamson
4 # with SASL2 support by Leif Johansson
5 # with better mem management and callbacks by Ulrich Pfeifer
6 #
7 # C code to glue Perl SASL to Cyrus libsasl.so
8 #
9 */
10
11 #define PERL_NO_GET_CONTEXT
12 #include <EXTERN.h>
13 #include <perl.h>
14 #include <XSUB.h>
15 #include <netinet/in.h>
16 #include <arpa/inet.h>
17 #include <sasl/sasl.h>
18
19
20 #ifdef SASL2
21 #define SASLCONST const
22 #define SASL_ERR(x) sasl_errdetail(sasl->conn)
23 #else
24 #define SASLCONST
25 #define SASL_ERR(x) x
26 #endif
27
28 #ifndef SASL_IP_LOCAL
29 #define SASL_IP_LOCAL 5
30 #endif
31 #ifndef SASL_IP_REMOTE
32 #define SASL_IP_REMOTE 6
33 #endif
34
35
36 /* Ulrich Pfeifer: Poor man's XPUSH macros for ancient perls. Note that the
37 stack is extended by a constant 1. That is OK for the uses below, but
38 insufficient in general */
39
40 #ifndef dXSTARG
41 #undef XPUSHi
42 #undef XPUSHp
43 #define XPUSHi(A) \
44 EXTEND(sp,1); \
45 PUSHs(sv_2mortal(newSViv(A)));
46 #define XPUSHp(A,B) \
47 EXTEND(sp,1); \
48 PUSHs(sv_2mortal(newSVpvn((char *)(A),(STRLEN)(B))));
49 #endif
50 #ifndef SvPV_nolen
51 #define SvPV_nolen(A) SvPV(A,PL_na)
52 #endif
53
54
55 struct authensasl {
56 sasl_conn_t *conn;
57 sasl_callback_t *callbacks;
58 char *server;
59 char *service;
60 char *mech;
61 char *user;
62 char *initstring;
63 int initstringlen;
64 SASLCONST char *errormsg;
65 int code;
66 };
67
68
69
70
71
72 /* A unique looking number to help PerlCallback() determine which parameter is
73 the context. Apparently not all callbacks get the context as the first */
74 #define PERLCONTEXT_MAGIC 0x0001ABCD
75
76 struct _perlcontext {
77 unsigned long magic;
78 int id;
79 SV *func;
80 SV *param;
81 int intparam;
82 };
83
84
85
free_callbacks(struct authensasl * sasl)86 void free_callbacks(struct authensasl *sasl)
87 {
88 if (sasl->callbacks) {
89 Safefree(sasl->callbacks);
90 Safefree(sasl->callbacks->context);
91 sasl->callbacks = NULL;
92 }
93 }
94
95
96
97 struct _perlcontext *
alloc_callbacks(struct authensasl * sasl,int count)98 alloc_callbacks(struct authensasl *sasl, int count)
99 {
100 dTHX;
101 struct _perlcontext *pcb;
102 int i;
103
104
105 Newz(23, pcb, count, struct _perlcontext);
106 if (pcb == NULL) {croak("Out of memory\n");}
107
108 for (i=0; i<count; i++) {
109 pcb[i].magic = PERLCONTEXT_MAGIC;
110 }
111
112 Newz(23, sasl->callbacks, count+1, sasl_callback_t);
113 if (sasl->callbacks == NULL) {croak("Out of memory\n");}
114
115 return(pcb);
116 }
117
118
119
120 /*
121 This is the wrapper function that calls Perl callback functions. The SASL
122 library needs a C function to handle callbacks, and this function forms the
123 glue to get from the C library back into Perl. The perlcontext is a wrapper
124 around the context given to the "callbacks" method. It tells which Perl
125 function should be called and what parameter to pass it.
126 Different types of callbacks have different "output" parameters to give data
127 back to the C library. This function needs to know how to take information
128 returned from the Perl callback subroutine and load it back into the output
129 parameters for the C library to read.
130 Note that if the callback given to the "callbacks" Perl method is really just
131 a string or integer, there is no need to jump into a Perl subroutine.
132 The value is loaded directly into the output parameters.
133 */
134
135
PerlCallback(void * perlcontext,char * arg0,char * arg1,char * arg2)136 int PerlCallback(void *perlcontext, char *arg0, char *arg1, char *arg2)
137 {
138 dTHX;
139 char *c;
140 int i, intparam, count, rc=0;
141 unsigned int len=0;
142 struct _perlcontext *cp;
143 sasl_secret_t *pass;
144 SV *rsv;
145
146
147 cp = (struct _perlcontext *)perlcontext;
148
149 /* For SASL_CB_PASS, the context is in the SECOND param */
150 if ((cp == NULL) || (cp->magic != PERLCONTEXT_MAGIC)) {
151 cp = (struct _perlcontext *)arg1;
152 warn("Authen::SASL::Cyrus: PerlCallback called with bad context\n");
153 }
154
155 /* If there is no function to call, just return the "parameter" */
156 if (cp->func == NULL) {
157
158 switch(cp->id) {
159 case SASL_CB_USER:
160 case SASL_CB_AUTHNAME:
161 case SASL_CB_LANGUAGE:
162 if (cp->param==NULL) rc = -1;
163 else {
164 *((char **)arg1) = SvPV(cp->param, len);
165 if (arg2) *((unsigned *)arg2) = len;
166 }
167 break;
168 case SASL_CB_PASS:
169 arg1 = SvPV(cp->param, len);
170 Newc(23, pass, len+sizeof(sasl_secret_t), char, sasl_secret_t);
171 if (pass == NULL) {
172 rc = -1;
173 }
174 else {
175 pass->len = len;
176 Copy(arg1, (char *)pass->data, len, char);
177 *((sasl_secret_t **)arg2) = pass;
178 }
179 break;
180 default:
181 break;
182 }
183 }
184
185 /* If there is a function, call it */
186 else {
187 /* Make a new call stack */
188 dSP;
189
190 /* We'll be making temporary perl variables */
191 ENTER ;
192 SAVETMPS ;
193
194 /* Push values onto the new call stack, using temporary perl variables */
195 PUSHMARK(SP);
196 if (cp->param) XPUSHs( cp->param );
197 switch(cp->id) {
198 case SASL_CB_USER:
199 case SASL_CB_AUTHNAME:
200 case SASL_CB_LANGUAGE:
201 case SASL_CB_PASS:
202 /* No additional parameters to load */
203 break;
204 default:
205 warn("Authen::SASL::Cyrus: Don't know how to instate args for callback %d\n", cp->id);
206 }
207 PUTBACK;
208
209 count = call_sv(cp->func, G_SCALAR);
210
211 /* Refresh the local stack in case the function played with it */
212 SPAGAIN;
213
214 /* Rewrite whatever parameters need it */
215 if (count != 1) {
216 rc = -1;
217 }
218 else {
219 switch(cp->id) {
220 case SASL_CB_USER:
221 case SASL_CB_AUTHNAME:
222 case SASL_CB_LANGUAGE:
223 rsv = POPs;
224 arg0 = SvPV(rsv, len);
225 c = savepvn(arg0, len);
226 if (c) {
227 if (arg2) *((unsigned *)arg2) = len;
228 *((char **)arg1) = c;
229 }
230 else {
231 rc = -1;
232 }
233 break;
234 case SASL_CB_PASS:
235 rsv = POPs;
236 arg1 = SvPV(rsv, len);
237 Newc(23, pass, len+sizeof(sasl_secret_t), char, sasl_secret_t);
238 if (pass == NULL) {
239 rc = -1;
240 }
241 else {
242 pass->len = len;
243 Copy(arg1, (char *)pass->data, len, char);
244 *((sasl_secret_t **)arg2) = pass;
245 }
246 default:
247 break;
248 }
249 }
250
251 /* Final cleanup of the stack, since we may've pop'd one */
252 PUTBACK ;
253
254 /* Remember to delete temporary variables */
255 FREETMPS ;
256 LEAVE ;
257 }
258
259
260 return(rc);
261 }
262
263
264
PerlPassCallback(sasl_conn_t * conn,void * perlcontext,int id,sasl_secret_t ** psecret)265 int PerlPassCallback(sasl_conn_t *conn, void *perlcontext,
266 int id, sasl_secret_t **psecret)
267 {
268 return(PerlCallback(perlcontext, NULL, NULL, (char *)psecret));
269 }
270
271
272
273
274
275 static
PropertyNumber(char * name)276 int PropertyNumber(char *name)
277 {
278 dTHX;
279
280 if (!strcasecmp(name, "user")) return SASL_USERNAME;
281 else if (!strcasecmp(name, "ssf")) return SASL_SSF;
282 else if (!strcasecmp(name, "maxout")) return SASL_MAXOUTBUF;
283 else if (!strcasecmp(name, "optctx")) return SASL_GETOPTCTX;
284 #ifdef SASL2
285 else if (!strcasecmp(name, "realm")) return SASL_DEFUSERREALM;
286 else if (!strcasecmp(name, "service")) return SASL_SERVICE;
287 else if (!strcasecmp(name, "serverfqdn")) return SASL_SERVERFQDN;
288 else if (!strcasecmp(name, "authsource")) return SASL_AUTHSOURCE;
289 else if (!strcasecmp(name, "mechname")) return SASL_MECHNAME;
290 else if (!strcasecmp(name, "authuser")) return SASL_AUTHUSER;
291 else if (!strcasecmp(name, "iplocalport")) return SASL_IPLOCALPORT;
292 else if (!strcasecmp(name, "ipremoteport")) return SASL_IPREMOTEPORT;
293 else if (!strcasecmp(name, "sockname")) return SASL_IPLOCALPORT;
294 else if (!strcasecmp(name, "peername")) return SASL_IPREMOTEPORT;
295 else if (!strcasecmp(name, "iplocal")) return SASL_IPLOCALPORT;
296 else if (!strcasecmp(name, "ipremote")) return SASL_IPREMOTEPORT;
297 #else
298 else if (!strcasecmp(name, "realm")) return SASL_REALM;
299 else if (!strcasecmp(name, "iplocalport")) return SASL_IP_LOCAL;
300 else if (!strcasecmp(name, "ipremoteport")) return SASL_IP_REMOTE;
301 else if (!strcasecmp(name, "sockname")) return SASL_IP_LOCAL;
302 else if (!strcasecmp(name, "peername")) return SASL_IP_REMOTE;
303 else if (!strcasecmp(name, "iplocal")) return SASL_IP_LOCAL;
304 else if (!strcasecmp(name, "ipremote")) return SASL_IP_REMOTE;
305 #endif
306 #ifdef SASL2
307 croak("Unknown SASL property: '%s' (user|ssf|maxout|realm|optctx|iplocalport|sockname|ipremoteport|peername|service|serverfqdn|authsource|mechname|authuser)\n", name);
308 #else
309 croak("Unknown SASL property: '%s' (user|ssf|maxout|realm|optctx|sockname|peername)\n", name);
310 #endif
311 return -1;
312 }
313
314
315
316 /* Convert a SASL IP address from that given by the user to the library format */
317 static
SASLIPuser2lib(char * buf,char * value,int valuelen)318 void SASLIPuser2lib(char *buf, char *value, int valuelen)
319 {
320 char *c;
321 int i, dotcount=0, semicolon=0, isv2=0, ip[5]={0,0,0,0,0};
322 struct sockaddr_in *saddr;
323 struct in_addr addr;
324
325 /* See if the *value is in V2 "IP1.IP2.IP3.IP4;PORT" format, or
326 in V1 "struct sockaddr" format */
327 for (i=0; i<valuelen; i++) {
328 if (value[i] == '.') {
329 dotcount++;
330 if (dotcount >= 4) {
331 isv2=0;
332 break;
333 }
334 }
335 else if ((value[i] == ';') && (dotcount == 3)) {
336 semicolon = 1;
337 isv2 = 1;
338 }
339 else if ((value[i] >= '0') && (value[i] <= '9')) {
340 ip[dotcount+semicolon] = ip[dotcount+semicolon]*10 + (value[i] - '0');
341 if ((semicolon == 0) && (ip[dotcount] >= 256)) {
342 break;
343 }
344 }
345 else {
346 isv2=0;
347 break;
348 }
349 }
350
351 if (isv2) {
352 #ifdef SASL2
353 strcpy(buf, value);
354 #else
355 saddr = (struct sockaddr_in *)buf;
356 saddr->sin_port = ip[4];
357 saddr->sin_addr.s_addr = (ip[0] << 24) | (ip[1] << 16) | (ip[2] << 8) | ip[3];
358 #endif
359 }
360 else {
361 #ifdef SASL2
362 saddr=(struct sockaddr_in *)value;
363 memcpy(&addr, &saddr->sin_addr, sizeof(addr));
364 c = inet_ntoa(addr);
365 sprintf(buf, "%s;%d", c, saddr->sin_port);
366 #else
367 memcpy(buf, value, sizeof(struct sockaddr_in));
368 #endif
369 }
370 }
371
372
373
374
375
376 /* Convert a Perl callback name into a C callback ID */
377 static
CallbackNumber(char * name)378 int CallbackNumber(char *name)
379 {
380 dTHX;
381 if (!strcasecmp(name, "user")) return(SASL_CB_USER);
382 else if (!strcasecmp(name, "auth")) return(SASL_CB_AUTHNAME);
383 else if (!strcasecmp(name, "language")) return(SASL_CB_LANGUAGE);
384 else if (!strcasecmp(name, "password")) return(SASL_CB_PASS);
385 else if (!strcasecmp(name, "pass")) return(SASL_CB_PASS);
386
387 croak("Unknown callback: '%s'. (user|auth|language|pass)\n", name);
388 }
389
390
391
392
393
394
395 /*
396 Fill the passed callback action into the passed Perl/SASL callback. This
397 is called either from ExtractParentCallbacks() when the "new" method is
398 called, or from callbacks() when that method is called directly.
399 */
400
401 static
AddCallback(char * name,SV * action,struct _perlcontext * pcb,sasl_callback_t * cb)402 void AddCallback(
403 char *name,
404 SV *action,
405 struct _perlcontext *pcb,
406 sasl_callback_t *cb
407 )
408 {
409 dTHX;
410
411 pcb->id = CallbackNumber(name);
412
413 if (SvROK(action)) { /* user => <ref> */
414 action = SvRV(action);
415
416 if (SvTYPE(action) == SVt_PVCV) { /* user => sub { }, user => \&func */
417 pcb->func = action;
418 pcb->param = NULL;
419 }
420
421 else if (SvTYPE(action) == SVt_PVAV) { /* user => [ \&func, $param ] */
422 pcb->func = av_shift((AV *)action);
423 pcb->param = av_shift((AV *)action);
424 }
425 else
426 croak("Unknown reference parameter to %s callback.\n", name);
427 }
428 else if (SvTYPE(action) & SVt_PV) { /* user => $param */
429 pcb->func = NULL;
430 pcb->param = action;
431 }
432 else if (SvTYPE(action) & SVt_IV) { /* user => 1 */
433 pcb->func = NULL;
434 pcb->param = NULL;
435 pcb->intparam = SvIV(action);
436 }
437 else
438 croak("Unknown parameter to %s callback.\n", name);
439
440 /* Write the C SASL callback */
441 cb->id = pcb->id;
442 cb->proc = PerlCallback;
443 if (cb->id == SASL_CB_PASS) {
444 cb->proc = PerlPassCallback;
445 }
446 else {
447 cb->proc = PerlCallback;
448 }
449 cb->context = pcb;
450 }
451
452
453
454
455
456 /*
457 Take the callback stored in the parent object and install them into the
458 current *sasl object. This is called from the "new" method.
459 */
460
461 static
ExtractParentCallbacks(SV * parent,struct authensasl * sasl)462 void ExtractParentCallbacks(SV *parent, struct authensasl *sasl)
463 {
464 dTHX;
465 char *key;
466 int count=0;
467 long l;
468 struct _perlcontext *pcb;
469 SV **hashval, *val;
470 HV *hash=NULL;
471 HE *iter;
472
473 /* Make sure parent is a ref to a hash (with keys like "mechanism"
474 and "callback") */
475 if (!parent) return;
476 if (!SvROK(parent)) return;
477 if (SvTYPE(SvRV(parent)) != SVt_PVHV) return;
478 hash = (HV *)SvRV(parent);
479
480 /* Get the parent's callbacks */
481 hashval = hv_fetch(hash, "callback", 8, 0);
482 if (!hashval || !*hashval) return;
483 val = *hashval;
484
485 /* Parent's callbacks are another hash (with keys like "user" and "auth") */
486 if (!SvROK(val)) return;
487 if (SvTYPE(SvRV(val)) != SVt_PVHV) return;
488 hash = (HV *)SvRV(val);
489
490 /* Run through all of parent's callback types, counting them */
491 hv_iterinit(hash);
492 for (iter=hv_iternext(hash); iter; iter=hv_iternext(hash)) count++;
493
494 /* Allocate space for the callbacks */
495 free_callbacks(sasl);
496 pcb = alloc_callbacks(sasl, count);
497
498 /* Run through all of parent's callback types, fill in the sasl->callbacks */
499 hv_iterinit(hash);
500 for (count=0,iter=hv_iternext(hash); iter; iter=hv_iternext(hash),count++){
501 key = hv_iterkey(iter, &l);
502 val = hv_iterval(hash, iter);
503 AddCallback(key, val, &pcb[count], &sasl->callbacks[count]);
504 }
505 sasl->callbacks[count].id = SASL_CB_LIST_END;
506 sasl->callbacks[count].context = NULL;
507
508 return;
509 }
510
511
512
513
514 MODULE=Authen::SASL::Cyrus PACKAGE=Authen::SASL::Cyrus
515
516
517
518 struct authensasl *
client_new(pkg,parent,service,host,...)519 client_new(pkg, parent, service, host, ...)
520 char *pkg
521 SV *parent
522 char *service
523 char *host
524 CODE:
525 {
526 const char *mech=NULL;
527 SASLCONST char *init=NULL;
528 unsigned int initlen=0;
529 struct authensasl *sasl;
530 HV *hash;
531 SV **hashval, *val;
532 sasl_security_properties_t ssp;
533
534
535 sasl = Newz(23, sasl, 1, struct authensasl);
536 if (sasl == NULL) croak("Out of memory\n");
537
538 if (!host || !*host) {
539 if (!sasl->errormsg) sasl->errormsg = "Need a 'hostname' in client_new()";
540 }
541 else
542 sasl->server = savepv(host);
543
544 if (!service || !*service) {
545 if (!sasl->errormsg) sasl->errormsg = "Need a 'service' name in client_new()";
546 }
547 else
548 sasl->service = savepv(service);
549
550
551 /* Extract callback info from the parent object */
552 ExtractParentCallbacks(parent, sasl);
553
554 /* Extract mechanism info from the parent object */
555 if (parent && SvROK(parent) && (SvTYPE(SvRV(parent)) == SVt_PVHV)) {
556 hash = (HV *)SvRV(parent);
557 hashval = hv_fetch(hash, "mechanism", 9, 0);
558 if (hashval && *hashval && SvTYPE(*hashval) == SVt_PV) {
559 if (sasl->mech) Safefree(sasl->mech);
560 sasl->mech = savepv(SvPV_nolen(*hashval));
561 }
562 }
563
564 sasl_client_init(NULL);
565 #ifdef SASL2
566 sasl->code = sasl_client_new(sasl->service, sasl->server, 0, 0, sasl->callbacks, 1, &sasl->conn);
567 #else
568 sasl->code = sasl_client_new(sasl->service, sasl->server, sasl->callbacks, 1, &sasl->conn);
569 #endif
570
571 if (sasl->code != SASL_OK) {
572 if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_client_new failed");
573 }
574 else {
575 #ifdef SASL2
576 sasl->code = sasl_client_start(sasl->conn, sasl->mech, NULL, &init, &initlen, &mech);
577 #else
578 sasl->code = sasl_client_start(sasl->conn, sasl->mech, NULL, NULL, &init, &initlen, &mech);
579 #endif
580 if (sasl->code == SASL_NOMECH) {
581 if (!sasl->errormsg)
582 sasl->errormsg = "No mechanisms available (did you set all needed callbacks?)";
583 }
584 else if ((sasl->code != SASL_OK) && (sasl->code != SASL_CONTINUE)) {
585 if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_client_start failed");
586 }
587 else {
588 #ifdef SASL2
589 memset(&ssp, 0, sizeof(ssp));
590 ssp.maxbufsize = 0xFFFF;
591 ssp.max_ssf = 0xFF;
592 sasl_setprop(sasl->conn, SASL_SEC_PROPS, &ssp);
593 #endif
594 if (init) {
595 New(23, sasl->initstring, initlen, char);
596 if (sasl->initstring) {
597 memcpy(sasl->initstring, init, initlen);
598 sasl->initstringlen = initlen;
599 }
600 else {
601 sasl->code = SASL_FAIL;
602 if (!sasl->errormsg) sasl->errormsg = "Out of memory in client_new()";
603 sasl->initstringlen = 0;
604 }
605 }
606 }
607 }
608 RETVAL = sasl;
609 }
610 OUTPUT:
611 RETVAL
612
613
614
615
616
617
618 char *
619 client_start(sasl)
620 struct authensasl *sasl
621 PPCODE:
622 {
623 XPUSHp(sasl->initstring, sasl->initstringlen);
624 }
625
626
627
628
629
630 char *
client_step(sasl,instring)631 client_step(sasl, instring)
632 struct authensasl *sasl
633 char *instring
634 PPCODE:
635 {
636 SASLCONST char *outstring=NULL;
637 unsigned int inlen, outlen=0;
638
639 if (sasl->errormsg) {
640 XSRETURN_EMPTY;
641 }
642 SvPV(ST(1),inlen);
643 sasl->code = sasl_client_step(sasl->conn, instring, inlen, NULL, &outstring, &outlen);
644 if (sasl->code == SASL_OK) {
645 sasl->errormsg = NULL;
646 }
647 else if (sasl->code != SASL_CONTINUE) {
648 if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_client_step failed");
649 XSRETURN_EMPTY;
650 }
651 XPUSHp(outstring, outlen);
652 }
653
654
655
656
657 char *
658 encode(sasl, instring)
659 struct authensasl *sasl
660 char *instring
661 PPCODE:
662 {
663 SASLCONST char *outstring=NULL;
664 unsigned int inlen, outlen=0;
665
666
667 if (sasl->errormsg) {
668 XSRETURN_UNDEF;
669 }
670 instring = SvPV(ST(1),inlen);
671
672 sasl->code = sasl_encode(sasl->conn, instring, inlen, &outstring, &outlen);
673 if (sasl->code != SASL_OK) {
674 if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_encode failed");
675 XSRETURN_UNDEF;
676 }
677 XPUSHp(outstring, outlen);
678 }
679
680
681
682
683 char *
decode(sasl,instring)684 decode(sasl, instring)
685 struct authensasl *sasl
686 char *instring
687 PPCODE:
688 {
689 SASLCONST char *outstring=NULL;
690 unsigned int inlen, outlen=0;
691
692
693 if (sasl->errormsg) {
694 XSRETURN_UNDEF;
695 }
696
697 instring = SvPV(ST(1),inlen);
698 sasl->code = sasl_decode(sasl->conn, instring, inlen, &outstring, &outlen);
699 if (sasl->code != SASL_OK) {
700 if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_decode failed");
701 XSRETURN_UNDEF;
702 }
703 XPUSHp(outstring, outlen);
704 }
705
706
707
708
709
710 int
711 callback(sasl, ...)
712 struct authensasl *sasl
713 CODE:
714 {
715 SV *action;
716 char *name;
717 int x, count;
718 struct _perlcontext *pcb;
719
720
721 /* Asking if a given callback exists */
722 if (items == 2) {
723 RETVAL = 0;
724 if (sasl->callbacks) {
725 name = SvPV_nolen(ST(1));
726 x = CallbackNumber(name);
727
728 /* Check the installed callbacks for the requested ID */
729 for (count=0; sasl->callbacks[count].id != SASL_CB_LIST_END; count++) {
730 if (sasl->callbacks[count].id == x) {
731 RETVAL = 1;
732 break;
733 }
734 }
735 }
736 }
737 else {
738 /* Prepare space for the callback list */
739 free_callbacks(sasl);
740 count = (items - 1) / 2;
741 pcb = alloc_callbacks(sasl, count);
742
743 /* Fill in the callbacks */
744 for(x=0; x<count; x++) {
745 /* Convert the callback name into a SASL ID number */
746 if (SvTYPE(ST(1+x*2)) != SVt_PV) {
747 croak("callbacks: Unknown key given in position %d\n", x);
748 }
749 name = SvPV_nolen(ST(1+x*2));
750 action = ST(2+x*2);
751 AddCallback(name, action, &pcb[x], &sasl->callbacks[x]);
752 }
753 sasl->callbacks[count].id = SASL_CB_LIST_END;
754 sasl->callbacks[count].context = NULL;
755
756 RETVAL = count;
757 }
758 }
759 OUTPUT:
760 RETVAL
761
762
763
764
765 int
766 saslversion(sasl)
767 struct authensasl *sasl
768 CODE:
769 #ifdef SASL2
770 RETVAL=2;
771 #else
772 RETVAL=1;
773 #endif
774 OUTPUT:
775 RETVAL
776
777
778
779
780 char *
781 error(sasl)
782 struct authensasl *sasl
783 CODE:
784 RETVAL = (char *)sasl->errormsg;
785 sasl->errormsg = NULL;
786 OUTPUT:
787 RETVAL
788
789
790
791 int
792 code(sasl)
793 struct authensasl *sasl
794 CODE:
795 RETVAL=sasl->code;
796 OUTPUT:
797 RETVAL
798
799
800 SV *
801 diag(sasl)
802 struct authensasl *sasl
803 CODE:
804 if (sasl->errormsg) {
805 RETVAL = sv_2mortal(newSVpv((char *)sasl->errormsg, 0));
806 }
807 else {
808 RETVAL = &PL_sv_undef;
809 }
810 OUTPUT:
811 RETVAL
812
813
814 char *
815 mechanism(sasl)
816 struct authensasl *sasl
817 CODE:
818 RETVAL = sasl->mech;
819 OUTPUT:
820 RETVAL
821
822
823
824 char *
825 host(sasl, ...)
826 struct authensasl *sasl
827 CODE:
828 if (items > 1) {
829 if (sasl->server) Safefree(sasl->server);
830 sasl->server = savepv(SvPV_nolen(ST(1)));
831 }
832 RETVAL = sasl->server;
833 OUTPUT:
834 RETVAL
835
836
837
838 char *
839 user(sasl, ...)
840 struct authensasl *sasl
841 CODE:
842 if (items > 1) {
843 if (sasl->user) Safefree(sasl->user);
844 sasl->user = savepv(SvPV_nolen(ST(1)));
845 }
846 RETVAL = sasl->user;
847 OUTPUT:
848 RETVAL
849
850
851
852 char *
853 service(sasl, ...)
854 struct authensasl *sasl
855 CODE:
856 if (items > 1) {
857 if (sasl->service) Safefree(sasl->service);
858 sasl->service = savepv(SvPV_nolen(ST(1)));
859 }
860 RETVAL = sasl->service;
861 OUTPUT:
862 RETVAL
863
864
865
866
867 int
868 property(sasl, ...)
869 struct authensasl *sasl
870 PPCODE:
871 {
872 SASLCONST void *value=NULL;
873 STRLEN proplen;
874 char *name, buf[32];
875 int x, propnum=-1;
876 SV *prop;
877
878
879 RETVAL = 0;
880
881 if (!sasl->conn) {
882 if (!sasl->errormsg) sasl->errormsg="sasl_setproperty called on uninitialized connection";
883 RETVAL = 1;
884 items = 0;
885 }
886
887 /* Querying the value of a property */
888 if (items == 2) {
889 name = SvPV_nolen(ST(1));
890 propnum = PropertyNumber(name);
891 sasl->code = sasl_getprop(sasl->conn, propnum, &value);
892 if (sasl->code != SASL_OK) XSRETURN_UNDEF;
893 switch(propnum){
894 case SASL_USERNAME:
895 #ifdef SASL2
896 case SASL_DEFUSERREALM:
897 #else
898 case SASL_REALM:
899 #endif
900 XPUSHp( (char *)value, strlen((char *)value));
901 break;
902 case SASL_SSF:
903 case SASL_MAXOUTBUF:
904 XPUSHi(*(int *)value);
905 break;
906 #ifdef SASL2
907 case SASL_IPLOCALPORT:
908 case SASL_IPREMOTEPORT:
909 XPUSHp( (char *)value, strlen((char *)value));
910 break;
911 #else
912 case SASL_IP_LOCAL:
913 case SASL_IP_REMOTE:
914 XPUSHp( (char *)value, sizeof(struct sockaddr_in));
915 break;
916 #endif
917 default:
918 XPUSHi(-1);
919 }
920 XSRETURN(1);
921 }
922
923 /* Fill in the properties */
924 for(x=1; x<items; x+=2) {
925
926 prop = ST(x);
927 value = (void *)SvPV( ST(x+1), proplen );
928
929 if (SvTYPE(prop) == SVt_IV) {
930 propnum = SvIV(prop);
931 }
932 else if (SvTYPE(prop) == SVt_PV) {
933 name = SvPV_nolen(prop);
934 propnum = PropertyNumber(name);
935 }
936
937 switch(propnum){
938 case SASL_IPLOCALPORT:
939 case SASL_IPREMOTEPORT:
940 case SASL_IP_LOCAL:
941 case SASL_IP_REMOTE:
942 SASLIPuser2lib(buf, (char *)value, proplen);
943 value = buf;
944 break;
945 default:
946 break;
947 }
948 sasl->code = sasl_setprop(sasl->conn, propnum, value);
949 if (sasl->code != SASL_OK) {
950 if (!sasl->errormsg) sasl->errormsg = SASL_ERR("sasl_setprop failed");
951 RETVAL = 1;
952 }
953 }
954 }
955
956
957
958
959
960 void
961 DESTROY(sasl)
962 struct authensasl *sasl
963 CODE:
964 if (sasl->conn) sasl_dispose(&sasl->conn);
965 free_callbacks(sasl);
966 if (sasl->service) Safefree(sasl->service);
967 if (sasl->mech) Safefree(sasl->mech);
968 #ifndef SASL2
969 if (sasl->errormsg) Safefree(sasl->errormsg);
970 #endif
971 if (sasl->initstring)Safefree(sasl->initstring);
972 Safefree(sasl);
973