(U-0002011D): Use `ideographic-radical@{ucs|cns}' and
[chise/xemacs-chise.git.1] / src / eldap.c
1 /* LDAP client interface for XEmacs.
2    Copyright (C) 1998 Free Software Foundation, Inc.
3
4 This file is part of XEmacs.
5
6 XEmacs is free software; you can redistribute it and/or modify it
7 under the terms of the GNU General Public License as published by the
8 Free Software Foundation; either version 2, or (at your option) any
9 later version.
10
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
14 for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with XEmacs; see the file COPYING.  If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA.  */
20
21 /* Synched up with: Not in FSF. */
22
23 /* Author: Oscar Figueiredo with lots of support from Hrvoje Niksic */
24
25 /* This file provides lisp primitives for access to an LDAP library
26    conforming to the API defined in RFC 1823.
27    It has been tested with:
28    - UMich LDAP 3.3 (http://www.umich.edu/~dirsvcs/ldap/)
29    - OpenLDAP 1.2 (http://www.openldap.org/)
30    - Netscape's LDAP SDK (http://developer.netscape.com/) */
31
32
33 #include <config.h>
34 #include "lisp.h"
35 #include "opaque.h"
36 #include "sysdep.h"
37 #include "buffer.h"
38
39 #include <errno.h>
40
41 #include "eldap.h"
42
43 static Fixnum ldap_default_port;
44 static Lisp_Object Vldap_default_base;
45
46 /* Needed by the lrecord definition */
47 Lisp_Object Qldapp;
48
49 /* ldap-open plist keywords */
50 static Lisp_Object Qport, Qauth, Qbinddn, Qpasswd, Qderef, Qtimelimit, Qsizelimit;
51 /* Search scope limits */
52 static Lisp_Object Qbase, Qonelevel, Qsubtree;
53 /* Authentication methods */
54 static Lisp_Object Qkrbv41, Qkrbv42;
55 /* Deref policy */
56 static Lisp_Object Qnever, Qalways, Qfind;
57 /* Modification types (Qdelete is defined in general.c) */
58 static Lisp_Object Qadd, Qreplace;
59
60 \f
61 /************************************************************************/
62 /*                         Utility Functions                            */
63 /************************************************************************/
64
65 static void
66 signal_ldap_error (LDAP *ld, LDAPMessage *res, int ldap_err)
67 {
68   if (ldap_err <= 0)
69     {
70 #if defined HAVE_LDAP_PARSE_RESULT
71       int err;
72       ldap_err = ldap_parse_result (ld, res,
73                                     &err,
74                                     NULL, NULL, NULL, NULL, 0);
75       if (ldap_err == LDAP_SUCCESS)
76         ldap_err = err;
77 #elif defined HAVE_LDAP_GET_LDERRNO
78       ldap_err = ldap_get_lderrno (ld, NULL, NULL);
79 #elif defined HAVE_LDAP_RESULT2ERROR
80       ldap_err = ldap_result2error (ld, res, 0);
81 #else
82       ldap_err = ld->ld_errno;
83 #endif
84     }
85   signal_simple_error ("LDAP error",
86                        build_string (ldap_err2string (ldap_err)));
87 }
88
89 \f
90 /************************************************************************/
91 /*                        ldap lrecord basic functions                  */
92 /************************************************************************/
93
94 static Lisp_Object
95 make_ldap (Lisp_LDAP *ldap)
96 {
97   Lisp_Object lisp_ldap;
98   XSETLDAP (lisp_ldap, ldap);
99   return lisp_ldap;
100 }
101
102 static Lisp_Object
103 mark_ldap (Lisp_Object obj)
104 {
105   return XLDAP (obj)->host;
106 }
107
108 static void
109 print_ldap (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
110 {
111   char buf[32];
112
113   Lisp_LDAP *ldap = XLDAP (obj);
114
115   if (print_readably)
116     error ("printing unreadable object #<ldap %s>",
117            XSTRING_DATA (ldap->host));
118
119   write_c_string ("#<ldap ", printcharfun);
120   print_internal (ldap->host, printcharfun, 1);
121   if (!ldap->ld)
122     write_c_string ("(dead) ",printcharfun);
123   sprintf (buf, " 0x%lx>", (long)ldap);
124   write_c_string (buf, printcharfun);
125 }
126
127 static Lisp_LDAP *
128 allocate_ldap (void)
129 {
130   Lisp_LDAP *ldap = alloc_lcrecord_type (Lisp_LDAP, &lrecord_ldap);
131
132   ldap->ld = NULL;
133   ldap->host = Qnil;
134   return ldap;
135 }
136
137 static void
138 finalize_ldap (void *header, int for_disksave)
139 {
140   Lisp_LDAP *ldap = (Lisp_LDAP *) header;
141
142   if (for_disksave)
143     signal_simple_error ("Can't dump an emacs containing LDAP objects",
144                          make_ldap (ldap));
145
146   if (ldap->ld)
147     ldap_unbind (ldap->ld);
148   ldap->ld = NULL;
149 }
150
151 DEFINE_LRECORD_IMPLEMENTATION ("ldap", ldap,
152                                mark_ldap, print_ldap, finalize_ldap,
153                                NULL, NULL, 0, Lisp_LDAP);
154
155
156
157 \f
158 /************************************************************************/
159 /*                        Basic ldap accessors                          */
160 /************************************************************************/
161
162 DEFUN ("ldapp", Fldapp, 1, 1, 0, /*
163 Return t if OBJECT is a LDAP connection.
164 */
165        (object))
166 {
167   return LDAPP (object) ? Qt : Qnil;
168 }
169
170 DEFUN ("ldap-host", Fldap_host, 1, 1, 0, /*
171 Return the server host of the connection LDAP, as a string.
172 */
173        (ldap))
174 {
175   CHECK_LDAP (ldap);
176   return (XLDAP (ldap))->host;
177 }
178
179 DEFUN ("ldap-live-p", Fldap_status, 1, 1, 0, /*
180 Return t if LDAP is an active LDAP connection.
181 */
182        (ldap))
183 {
184   CHECK_LDAP (ldap);
185   return (XLDAP (ldap))->ld ? Qt : Qnil;
186 }
187 \f
188 /************************************************************************/
189 /*                  Opening/Closing a LDAP connection                   */
190 /************************************************************************/
191
192
193 DEFUN ("ldap-open", Fldap_open, 1, 2, 0, /*
194 Open a LDAP connection to HOST.
195 PLIST is a plist containing additional parameters for the connection.
196 Valid keys in that list are:
197   `port' the TCP port to use for the connection if different from
198 `ldap-default-port'.
199   `auth' is the authentication method to use, possible values depend on
200 the LDAP library XEmacs was compiled with: `simple', `krbv41' and `krbv42'.
201   `binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax).
202   `passwd' is the password to use for simple authentication.
203   `deref' is one of the symbols `never', `always', `search' or `find'.
204   `timelimit' is the timeout limit for the connection in seconds.
205   `sizelimit' is the maximum number of matches to return.
206 */
207        (host, plist))
208 {
209   /* This function can GC */
210   Lisp_LDAP *ldap;
211   LDAP *ld;
212   int  ldap_port = 0;
213   int  ldap_auth = LDAP_AUTH_SIMPLE;
214   char *ldap_binddn = NULL;
215   char *ldap_passwd = NULL;
216   int  ldap_deref = LDAP_DEREF_NEVER;
217   int  ldap_timelimit = 0;
218   int  ldap_sizelimit = 0;
219   int  err;
220
221   CHECK_STRING (host);
222
223   {
224     EXTERNAL_PROPERTY_LIST_LOOP_3 (keyword, value, plist)
225       {
226         /* TCP Port */
227         if (EQ (keyword, Qport))
228           {
229             CHECK_INT (value);
230             ldap_port = XINT (value);
231           }
232         /* Authentication method */
233         if (EQ (keyword, Qauth))
234           {
235             if (EQ (value, Qsimple))
236               ldap_auth = LDAP_AUTH_SIMPLE;
237 #ifdef LDAP_AUTH_KRBV41
238             else if (EQ (value, Qkrbv41))
239               ldap_auth = LDAP_AUTH_KRBV41;
240 #endif
241 #ifdef LDAP_AUTH_KRBV42
242             else if (EQ (value, Qkrbv42))
243               ldap_auth = LDAP_AUTH_KRBV42;
244 #endif
245             else
246               signal_simple_error ("Invalid authentication method", value);
247           }
248         /* Bind DN */
249         else if (EQ (keyword, Qbinddn))
250           {
251             CHECK_STRING (value);
252             LISP_STRING_TO_EXTERNAL (value, ldap_binddn, Qnative);
253           }
254         /* Password */
255         else if (EQ (keyword, Qpasswd))
256           {
257             CHECK_STRING (value);
258             LISP_STRING_TO_EXTERNAL (value, ldap_passwd, Qnative);
259           }
260         /* Deref */
261         else if (EQ (keyword, Qderef))
262           {
263             if (EQ (value, Qnever))
264               ldap_deref = LDAP_DEREF_NEVER;
265             else if (EQ (value, Qsearch))
266               ldap_deref = LDAP_DEREF_SEARCHING;
267             else if (EQ (value, Qfind))
268               ldap_deref = LDAP_DEREF_FINDING;
269             else if (EQ (value, Qalways))
270               ldap_deref = LDAP_DEREF_ALWAYS;
271             else
272               signal_simple_error ("Invalid deref value", value);
273           }
274         /* Timelimit */
275         else if (EQ (keyword, Qtimelimit))
276           {
277             CHECK_INT (value);
278             ldap_timelimit = XINT (value);
279           }
280         /* Sizelimit */
281         else if (EQ (keyword, Qsizelimit))
282           {
283             CHECK_INT (value);
284             ldap_sizelimit = XINT (value);
285           }
286       }
287   }
288
289   if (ldap_port == 0)
290     {
291       ldap_port = ldap_default_port;
292     }
293
294   /* Connect to the server and bind */
295   slow_down_interrupts ();
296   ld = ldap_open ((char *) XSTRING_DATA (host), ldap_port);
297   speed_up_interrupts ();
298
299   if (ld == NULL )
300     signal_simple_error_2 ("Failed connecting to host",
301                            host,
302                            lisp_strerror (errno));
303
304
305 #ifdef HAVE_LDAP_SET_OPTION
306   if ((err = ldap_set_option (ld, LDAP_OPT_DEREF,
307                               (void *)&ldap_deref)) != LDAP_SUCCESS)
308     signal_ldap_error (ld, NULL, err);
309   if ((err = ldap_set_option (ld, LDAP_OPT_TIMELIMIT,
310                               (void *)&ldap_timelimit)) != LDAP_SUCCESS)
311     signal_ldap_error (ld, NULL, err);
312   if ((err = ldap_set_option (ld, LDAP_OPT_SIZELIMIT,
313                               (void *)&ldap_sizelimit)) != LDAP_SUCCESS)
314     signal_ldap_error (ld, NULL, err);
315   if ((err = ldap_set_option (ld, LDAP_OPT_REFERRALS,
316                               LDAP_OPT_ON)) != LDAP_SUCCESS)
317     signal_ldap_error (ld, NULL, err);
318   if ((err = ldap_set_option (ld, LDAP_OPT_RESTART,
319                               LDAP_OPT_ON)) != LDAP_SUCCESS)
320     signal_ldap_error (ld, NULL, err);
321 #else  /* not HAVE_LDAP_SET_OPTION */
322   ld->ld_deref = ldap_deref;
323   ld->ld_timelimit = ldap_timelimit;
324   ld->ld_sizelimit = ldap_sizelimit;
325 #ifdef LDAP_REFERRALS
326   ld->ld_options = LDAP_OPT_REFERRALS;
327 #else /* not LDAP_REFERRALS */
328   ld->ld_options = 0;
329 #endif /* not LDAP_REFERRALS */
330   /* XEmacs uses interrupts (SIGIO,SIGALRM), LDAP calls need to ignore them */
331   ld->ld_options |= LDAP_OPT_RESTART;
332 #endif /* not HAVE_LDAP_SET_OPTION */
333
334   err = ldap_bind_s (ld, ldap_binddn, ldap_passwd, ldap_auth);
335   if (err != LDAP_SUCCESS)
336     signal_simple_error ("Failed binding to the server",
337                          build_string (ldap_err2string (err)));
338
339   ldap = allocate_ldap ();
340   ldap->ld = ld;
341   ldap->host = host;
342
343   return make_ldap (ldap);
344 }
345
346
347
348 DEFUN ("ldap-close", Fldap_close, 1, 1, 0, /*
349 Close an LDAP connection.
350 */
351       (ldap))
352 {
353   Lisp_LDAP *lldap;
354   CHECK_LIVE_LDAP (ldap);
355   lldap = XLDAP (ldap);
356   ldap_unbind (lldap->ld);
357   lldap->ld = NULL;
358   return Qnil;
359 }
360
361
362 \f
363 /************************************************************************/
364 /*                  Working on a LDAP connection                        */
365 /************************************************************************/
366 struct ldap_unwind_struct
367 {
368   LDAPMessage *res;
369   struct berval **vals;
370 };
371
372 static Lisp_Object
373 ldap_search_unwind (Lisp_Object unwind_obj)
374 {
375   struct ldap_unwind_struct *unwind =
376     (struct ldap_unwind_struct *) get_opaque_ptr (unwind_obj);
377   if (unwind->res)
378     ldap_msgfree (unwind->res);
379   if (unwind->vals)
380     ldap_value_free_len (unwind->vals);
381   return Qnil;
382 }
383
384 /* The following function is called `ldap-search-basic' instead of      */
385 /* plain `ldap-search' to maintain compatibility with the XEmacs 21.1   */
386 /* API where `ldap-search' was the name of the high-level search        */
387 /* function                                                             */
388
389 DEFUN ("ldap-search-basic", Fldap_search_basic, 2, 8, 0, /*
390 Perform a search on an open LDAP connection.
391 LDAP is an LDAP connection object created with `ldap-open'.
392 FILTER is a filter string for the search as described in RFC 1558.
393 BASE is the distinguished name at which to start the search.
394 SCOPE is one of the symbols `base', `onelevel' or `subtree' indicating
395 the scope of the search.
396 ATTRS is a list of strings indicating which attributes to retrieve
397  for each matching entry. If nil return all available attributes.
398 If ATTRSONLY is non-nil then only the attributes are retrieved, not
399 the associated values.
400 If WITHDN is non-nil each entry in the result will be prepended with
401 its distinguished name DN.
402 If VERBOSE is non-nil progress messages will be echoed.
403 The function returns a list of matching entries.  Each entry is itself
404 an alist of attribute/value pairs optionally preceded by the DN of the
405 entry according to the value of WITHDN.
406 */
407        (ldap, filter, base, scope, attrs, attrsonly, withdn, verbose))
408 {
409   /* This function can GC */
410
411   /* Vars for query */
412   LDAP *ld;
413   LDAPMessage *e;
414   BerElement *ptr;
415   char *a, *dn;
416   int i, rc;
417   int  matches;
418   struct ldap_unwind_struct unwind;
419
420   int  ldap_scope = LDAP_SCOPE_SUBTREE;
421   char **ldap_attributes = NULL;
422
423   int speccount = specpdl_depth ();
424
425   Lisp_Object list   = Qnil;
426   Lisp_Object entry  = Qnil;
427   Lisp_Object result = Qnil;
428   struct gcpro gcpro1, gcpro2, gcpro3;
429
430   GCPRO3 (list, entry, result);
431
432   unwind.res = NULL;
433   unwind.vals = NULL;
434
435   /* Do all the parameter checking  */
436   CHECK_LIVE_LDAP (ldap);
437   ld = XLDAP (ldap)->ld;
438
439   /* Filter */
440   CHECK_STRING (filter);
441
442   /* Search base */
443   if (NILP (base))
444     {
445       base = Vldap_default_base;
446     }
447   if (!NILP (base))
448     {
449       CHECK_STRING (base);
450     }
451
452   /* Search scope */
453   if (!NILP (scope))
454     {
455       if (EQ (scope, Qbase))
456         ldap_scope = LDAP_SCOPE_BASE;
457       else if (EQ (scope, Qonelevel))
458         ldap_scope = LDAP_SCOPE_ONELEVEL;
459       else if (EQ (scope, Qsubtree))
460         ldap_scope = LDAP_SCOPE_SUBTREE;
461       else
462         signal_simple_error ("Invalid scope", scope);
463     }
464
465   /* Attributes to search */
466   if (!NILP (attrs))
467     {
468       CHECK_CONS (attrs);
469       ldap_attributes = alloca_array (char *, 1 + XINT (Flength (attrs)));
470
471       i = 0;
472       EXTERNAL_LIST_LOOP (attrs, attrs)
473         {
474           Lisp_Object current = XCAR (attrs);
475           CHECK_STRING (current);
476           LISP_STRING_TO_EXTERNAL (current, ldap_attributes[i], Qnative);
477           ++i;
478         }
479       ldap_attributes[i] = NULL;
480     }
481
482   /* Attributes only ? */
483   CHECK_SYMBOL (attrsonly);
484
485   /* Perform the search */
486   if (ldap_search (ld,
487                    NILP (base) ? (char *) "" : (char *) XSTRING_DATA (base),
488                    ldap_scope,
489                    NILP (filter) ? (char *) "" : (char *) XSTRING_DATA (filter),
490                    ldap_attributes,
491                    NILP (attrsonly) ? 0 : 1)
492       == -1)
493     {
494       signal_ldap_error (ld, NULL, 0);
495     }
496
497   /* Ensure we don't exit without cleaning up */
498   record_unwind_protect (ldap_search_unwind,
499                          make_opaque_ptr (&unwind));
500
501   /* Build the results list */
502   matches = 0;
503
504   rc = ldap_result (ld, LDAP_RES_ANY, 0, NULL, &unwind.res);
505
506   while (rc == LDAP_RES_SEARCH_ENTRY)
507     {
508       QUIT;
509       matches ++;
510       e = ldap_first_entry (ld, unwind.res);
511       /* #### This call to message() is pretty fascist, because it
512          destroys the current echo area contents, even when invoked
513          from Lisp.  It should use echo_area_message() instead, and
514          restore the old echo area contents later.  */
515       if (! NILP (verbose))
516         message ("Parsing ldap results... %d", matches);
517       entry = Qnil;
518       /* Get the DN if required */
519       if (! NILP (withdn))
520         {
521           dn = ldap_get_dn (ld, e);
522           if (dn == NULL)
523             signal_ldap_error (ld, e, 0);
524           entry = Fcons (build_ext_string (dn, Qnative), Qnil);
525         }
526       for (a= ldap_first_attribute (ld, e, &ptr);
527            a != NULL;
528            a = ldap_next_attribute (ld, e, ptr) )
529         {
530           list = Fcons (build_ext_string (a, Qnative), Qnil);
531           unwind.vals = ldap_get_values_len (ld, e, a);
532           if (unwind.vals != NULL)
533             {
534               for (i = 0; unwind.vals[i] != NULL; i++)
535                 {
536                   list = Fcons (make_ext_string ((Extbyte *) unwind.vals[i]->bv_val,
537                                                  unwind.vals[i]->bv_len,
538                                                  Qnative),
539                                 list);
540                 }
541             }
542           entry = Fcons (Fnreverse (list),
543                          entry);
544           ldap_value_free_len (unwind.vals);
545           unwind.vals = NULL;
546         }
547       result = Fcons (Fnreverse (entry),
548                       result);
549       ldap_msgfree (unwind.res);
550       unwind.res = NULL;
551
552       rc = ldap_result (ld, LDAP_RES_ANY, 0, NULL, &(unwind.res));
553     }
554
555 #if defined HAVE_LDAP_PARSE_RESULT
556   {
557     int rc2 = ldap_parse_result (ld, unwind.res,
558                                  &rc,
559                                  NULL, NULL, NULL, NULL, 0);
560     if (rc2 != LDAP_SUCCESS)
561       rc = rc2;
562   }
563 #else
564   if (rc == 0)
565     signal_ldap_error (ld, NULL, LDAP_TIMELIMIT_EXCEEDED);
566
567   if (rc == -1)
568     signal_ldap_error (ld, unwind.res, (unwind.res==NULL) ? ld->ld_errno : 0);
569
570 #if defined HAVE_LDAP_RESULT2ERROR
571   rc = ldap_result2error (ld, unwind.res, 0);
572 #endif
573 #endif
574
575   if (rc != LDAP_SUCCESS)
576     signal_ldap_error (ld, NULL, rc);
577
578   ldap_msgfree (unwind.res);
579   unwind.res = (LDAPMessage *)NULL;
580
581   /* #### See above for calling message().  */
582   if (! NILP (verbose))
583     message ("Parsing ldap results... done");
584
585   unbind_to (speccount, Qnil);
586   UNGCPRO;
587   return Fnreverse (result);
588 }
589
590 DEFUN ("ldap-add", Fldap_add, 3, 3, 0, /*
591 Add an entry to an LDAP directory.
592 LDAP is an LDAP connection object created with `ldap-open'.
593 DN is the distinguished name of the entry to add.
594 ENTRY is an entry specification, i.e., a list of cons cells
595 containing attribute/value string pairs.
596 */
597        (ldap, dn, entry))
598 {
599   LDAP *ld;
600   LDAPMod *ldap_mods, **ldap_mods_ptrs;
601   struct berval *bervals;
602   int rc;
603   int i, j;
604   size_t len;
605
606   Lisp_Object current = Qnil;
607   Lisp_Object values  = Qnil;
608   struct gcpro gcpro1, gcpro2;
609
610   GCPRO2 (current, values);
611
612   /* Do all the parameter checking  */
613   CHECK_LIVE_LDAP (ldap);
614   ld = XLDAP (ldap)->ld;
615
616   /* Check the DN */
617   CHECK_STRING (dn);
618
619   /* Check the entry */
620   CHECK_CONS (entry);
621   if (NILP (entry))
622     signal_simple_error ("Cannot add void entry", entry);
623
624   /* Build the ldap_mods array */
625   len = XINT (Flength (entry));
626   ldap_mods = alloca_array (LDAPMod, len);
627   ldap_mods_ptrs = alloca_array (LDAPMod *, 1 + len);
628   i = 0;
629   EXTERNAL_LIST_LOOP (entry, entry)
630     {
631       current = XCAR (entry);
632       CHECK_CONS (current);
633       CHECK_STRING (XCAR (current));
634       ldap_mods_ptrs[i] = &(ldap_mods[i]);
635       LISP_STRING_TO_EXTERNAL (XCAR (current), ldap_mods[i].mod_type, Qnative);
636       ldap_mods[i].mod_op = LDAP_MOD_ADD | LDAP_MOD_BVALUES;
637       values = XCDR (current);
638       if (CONSP (values))
639         {
640           len = XINT (Flength (values));
641           bervals = alloca_array (struct berval, len);
642           ldap_mods[i].mod_vals.modv_bvals =
643             alloca_array (struct berval *, 1 + len);
644           j = 0;
645           EXTERNAL_LIST_LOOP (values, values)
646             {
647               current = XCAR (values);
648               CHECK_STRING (current);
649               ldap_mods[i].mod_vals.modv_bvals[j] = &(bervals[j]);
650               TO_EXTERNAL_FORMAT (LISP_STRING, current,
651                                   ALLOCA, (bervals[j].bv_val,
652                                            bervals[j].bv_len),
653                                   Qnative);
654               j++;
655             }
656           ldap_mods[i].mod_vals.modv_bvals[j] = NULL;
657         }
658       else
659         {
660           CHECK_STRING (values);
661           bervals = alloca_array (struct berval, 1);
662           ldap_mods[i].mod_vals.modv_bvals = alloca_array (struct berval *, 2);
663           ldap_mods[i].mod_vals.modv_bvals[0] = &(bervals[0]);
664           TO_EXTERNAL_FORMAT (LISP_STRING, values,
665                               ALLOCA, (bervals[0].bv_val,
666                                        bervals[0].bv_len),
667                               Qnative);
668           ldap_mods[i].mod_vals.modv_bvals[1] = NULL;
669         }
670       i++;
671     }
672   ldap_mods_ptrs[i] = NULL;
673   rc = ldap_add_s (ld, (char *) XSTRING_DATA (dn), ldap_mods_ptrs);
674   if (rc != LDAP_SUCCESS)
675     signal_ldap_error (ld, NULL, rc);
676
677   UNGCPRO;
678   return Qnil;
679 }
680
681 DEFUN ("ldap-modify", Fldap_modify, 3, 3, 0, /*
682 Add an entry to an LDAP directory.
683 LDAP is an LDAP connection object created with `ldap-open'.
684 DN is the distinguished name of the entry to modify.
685 MODS is a list of modifications to apply.
686 A modification is a list of the form (MOD-OP ATTR VALUE1 VALUE2 ...)
687 MOD-OP and ATTR are mandatory, VALUEs are optional depending on MOD-OP.
688 MOD-OP is the type of modification, one of the symbols `add', `delete'
689 or `replace'. ATTR is the LDAP attribute type to modify.
690 */
691        (ldap, dn, mods))
692 {
693   LDAP *ld;
694   LDAPMod *ldap_mods, **ldap_mods_ptrs;
695   struct berval *bervals;
696   int i, j, rc;
697   Lisp_Object mod_op;
698   size_t len;
699
700   Lisp_Object current = Qnil;
701   Lisp_Object values  = Qnil;
702   struct gcpro gcpro1, gcpro2;
703
704   /* Do all the parameter checking  */
705   CHECK_LIVE_LDAP (ldap);
706   ld = XLDAP (ldap)->ld;
707
708   /* Check the DN */
709   CHECK_STRING (dn);
710
711   /* Check the entry */
712   CHECK_CONS (mods);
713   if (NILP (mods))
714     return Qnil;
715
716   /* Build the ldap_mods array */
717   len = XINT (Flength (mods));
718   ldap_mods = alloca_array (LDAPMod, len);
719   ldap_mods_ptrs = alloca_array (LDAPMod *, 1 + len);
720   i = 0;
721
722   GCPRO2 (current, values);
723   EXTERNAL_LIST_LOOP (mods, mods)
724     {
725       current = XCAR (mods);
726       CHECK_CONS (current);
727       CHECK_SYMBOL (XCAR (current));
728       mod_op = XCAR (current);
729       ldap_mods_ptrs[i] = &(ldap_mods[i]);
730       ldap_mods[i].mod_op = LDAP_MOD_BVALUES;
731       if (EQ (mod_op, Qadd))
732         ldap_mods[i].mod_op |= LDAP_MOD_ADD;
733       else if (EQ (mod_op, Qdelete))
734         ldap_mods[i].mod_op |= LDAP_MOD_DELETE;
735       else if (EQ (mod_op, Qreplace))
736         ldap_mods[i].mod_op |= LDAP_MOD_REPLACE;
737       else
738         signal_simple_error ("Invalid LDAP modification type", mod_op);
739       current = XCDR (current);
740       CHECK_STRING (XCAR (current));
741       LISP_STRING_TO_EXTERNAL (XCAR (current), ldap_mods[i].mod_type, Qnative);
742       values = XCDR (current);
743       len = XINT (Flength (values));
744       bervals = alloca_array (struct berval, len);
745       ldap_mods[i].mod_vals.modv_bvals =
746         alloca_array (struct berval *, 1 + len);
747       j = 0;
748       EXTERNAL_LIST_LOOP (values, values)
749         {
750           current = XCAR (values);
751           CHECK_STRING (current);
752           ldap_mods[i].mod_vals.modv_bvals[j] = &(bervals[j]);
753           TO_EXTERNAL_FORMAT (LISP_STRING, current,
754                               ALLOCA, (bervals[j].bv_val,
755                                        bervals[j].bv_len),
756                               Qnative);
757           j++;
758         }
759       ldap_mods[i].mod_vals.modv_bvals[j] = NULL;
760       i++;
761     }
762   ldap_mods_ptrs[i] = NULL;
763   rc = ldap_modify_s (ld, (char *) XSTRING_DATA (dn), ldap_mods_ptrs);
764   if (rc != LDAP_SUCCESS)
765     signal_ldap_error (ld, NULL, rc);
766
767   UNGCPRO;
768   return Qnil;
769 }
770
771
772 DEFUN ("ldap-delete", Fldap_delete, 2, 2, 0, /*
773 Delete an entry to an LDAP directory.
774 LDAP is an LDAP connection object created with `ldap-open'.
775 DN is the distinguished name of the entry to delete.
776 */
777        (ldap, dn))
778 {
779   LDAP *ld;
780   int rc;
781
782   /* Check parameters */
783   CHECK_LIVE_LDAP (ldap);
784   ld = XLDAP (ldap)->ld;
785   CHECK_STRING (dn);
786
787   rc = ldap_delete_s (ld, (char *) XSTRING_DATA (dn));
788   if (rc != LDAP_SUCCESS)
789     signal_ldap_error (ld, NULL, rc);
790
791   return Qnil;
792 }
793
794 void
795 syms_of_eldap (void)
796 {
797   INIT_LRECORD_IMPLEMENTATION (ldap);
798
799   defsymbol (&Qldapp, "ldapp");
800   defsymbol (&Qport, "port");
801   defsymbol (&Qauth, "auth");
802   defsymbol (&Qbinddn, "binddn");
803   defsymbol (&Qpasswd, "passwd");
804   defsymbol (&Qderef, "deref");
805   defsymbol (&Qtimelimit, "timelimit");
806   defsymbol (&Qsizelimit, "sizelimit");
807   defsymbol (&Qbase, "base");
808   defsymbol (&Qonelevel, "onelevel");
809   defsymbol (&Qsubtree, "subtree");
810   defsymbol (&Qkrbv41, "krbv41");
811   defsymbol (&Qkrbv42, "krbv42");
812   defsymbol (&Qnever, "never");
813   defsymbol (&Qalways, "always");
814   defsymbol (&Qfind, "find");
815   defsymbol (&Qadd, "add");
816   defsymbol (&Qreplace, "replace");
817
818   DEFSUBR (Fldapp);
819   DEFSUBR (Fldap_host);
820   DEFSUBR (Fldap_status);
821   DEFSUBR (Fldap_open);
822   DEFSUBR (Fldap_close);
823   DEFSUBR (Fldap_search_basic);
824   DEFSUBR (Fldap_add);
825   DEFSUBR (Fldap_modify);
826   DEFSUBR (Fldap_delete);
827 }
828
829 void
830 vars_of_eldap (void)
831 {
832
833   ldap_default_port = LDAP_PORT;
834   Vldap_default_base =  Qnil;
835
836   DEFVAR_INT ("ldap-default-port", &ldap_default_port /*
837 Default TCP port for LDAP connections.
838 Initialized from the LDAP library. Default value is 389.
839 */ );
840
841   DEFVAR_LISP ("ldap-default-base", &Vldap_default_base /*
842 Default base for LDAP searches.
843 This is a string using the syntax of RFC 1779.
844 For instance, "o=ACME, c=US" limits the search to the
845 Acme organization in the United States.
846 */ );
847
848 }
849
850