?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Emacs crashes with segmentation fault when mime-view tries to display malformed
[more-wl.git] / elmo / pldap.el
blobb6ae29a86a4c9b109cae428457ce2c2bfc99ee11
1 ;;; pldap.el --- A portable LDAP support for Emacs.
2
3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
4 ;; Copyright (C) 2000 Yuuichi Teranishi <teranisi@gohome.org>
5
6 ;; Original was ldap.el:
7 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
8 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
9
10 ;; pldap.el:
11 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
12 ;; Maintainer: Yuuichi Teranishi <teranisi@gohome.org>
13 ;; Keywords: emulating, LDAP, comm
14 ;; Created: 15 June 2000
15
16 ;; This file is not part of GNU Emacs
17
18 ;; This program is free software; you can redistribute it and/or modify
19 ;; it under the terms of the GNU General Public License as published by
20 ;; the Free Software Foundation; either version 2, or (at your option)
21 ;; any later version.
22 ;;
23 ;; This program is distributed in the hope that it will be useful,
24 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 ;; GNU General Public License for more details.
27 ;;
28 ;; You should have received a copy of the GNU General Public License
29 ;; along with GNU Emacs; see the file COPYING. If not, write to the
30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
31 ;; Boston, MA 02111-1307, USA.
32 ;;
33
34 ;;; Commentary:
35
36 ;;; Code:
37 ;;
38
39 (eval-when-compile (require 'cl))
40
41 (defmacro ldap-static-if (cond then &rest else)
42 "`if' expression but COND is evaluated at compile-time."
43 (if (eval cond)
44 then
45 `(progn ,@else)))
46
47 (ldap-static-if (and (not (featurep 'pldap))
48 (fboundp 'ldap-open))
49 ;; You have built-in ldap feature (XEmacs).
50 (require 'ldap)
51
52 ;; You don't have built-in ldap feature.
53 ;; Use external program.
54
55 ;;; For LDIF encoding.
56 ;; SAFE-CHAR = %x01-09 / %x0B-0C / %x0E-7F
57 (defconst ldap-ldif-safe-char-regexp
58 "[\000-\011\013\014\016-\177]"
59 "A Regexp for safe-char.")
60 ;; SAFE-INIT-CHAR = %x01-09 / %x0B-0C / %x0E-1F /
61 ;; %x21-39 / %x3B / %x3D-7F
62 (defconst ldap-ldif-safe-init-char-regexp
63 "[\001-\011\013\014\016-\037\038-\071\073\075-\177]"
64 "A Regexp for safe-init-char.")
65 ;; SAFE-STRING = [SAFE-INIT-CHAR *SAFE-CHAR]
66 (defconst ldap-ldif-safe-string-regexp
67 (concat ldap-ldif-safe-init-char-regexp ldap-ldif-safe-char-regexp "*")
68 "A Regexp for safe-string.")
69
70 (defconst ldap-ldif-field-name-regexp "[a-zA-Z][a-zA-Z0-9-;]*"
71 "A Regexp for field name.")
72
73 (defconst ldap-ldif-field-head-regexp
74 (concat "^" ldap-ldif-field-name-regexp ":")
75 "A Regexp for field head.")
76
77 (defconst ldap-ldif-next-field-head-regexp
78 (concat "\n" ldap-ldif-field-name-regexp ":")
79 "A Regexp for next field head.")
80
81 (defmacro ldap/ldif-safe-string-p (string)
82 "Return t if STRING is a safe-string for LDIF."
83 ;; Need better implentation.
84 `(string-match ldap-ldif-safe-string-regexp ,string))
85
86 (defgroup ldap nil
87 "Lightweight Directory Access Protocol"
88 :group 'comm)
89
90 (defvar ldap-search-program "ldapsearch"
91 "LDAP search program.")
92
93 (defvar ldap-add-program "ldapadd"
94 "LDAP add program.")
95
96 (defvar ldap-delete-program "ldapdelete"
97 "LDAP delete program.")
98
99 (defvar ldap-modify-program "ldapmodify"
100 "LDAP modify program.")
101
102 (defcustom ldap-search-program-arguments '("-LL" "-x")
103 "*A list of additional arguments to pass to `ldapsearch'.
104 It is recommended to use the `-T' switch with Nescape's
105 implementation to avoid line wrapping.
106 `-L' is needed to get LDIF outout.
107 \(`-LL' is needed to get rid of comments from OpenLDAP's ldapsearch.\)
108 `-x' is needed to use simple authentication.
109 The `-B' switch should be used to enable the retrieval of
110 binary values."
111 :type '(repeat :tag "`ldapsearch' Arguments"
112 (string :tag "Argument"))
113 :group 'ldap)
114
115 (defcustom ldap-default-host nil
116 "*Default LDAP server hostname."
117 :type '(choice (string :tag "Host name")
118 (const :tag "Use library default" nil))
119 :group 'ldap)
120
121 (defcustom ldap-default-port nil
122 "*Default TCP port for LDAP connections.
123 Initialized from the LDAP library at build time. Default value is 389."
124 :type '(choice (const :tag "Use library default" nil)
125 (integer :tag "Port number"))
126 :group 'ldap)
127
128 (defcustom ldap-default-base nil
129 "*Default base for LDAP searches.
130 This is a string using the syntax of RFC 1779.
131 For instance, \"o=ACME, c=US\" limits the search to the
132 Acme organization in the United States."
133 :type '(choice (const :tag "Use library default" nil)
134 (string :tag "Search base"))
135 :group 'ldap)
136
137 (defcustom ldap-host-parameters-alist nil
138 "*Alist of host-specific options for LDAP transactions.
139 The format of each list element is:
140 \(HOST PROP1 VAL1 PROP2 VAL2 ...)
141 HOST is the hostname of an LDAP server (with an optional TCP port number
142 appended to it using a colon as a separator).
143 PROPn and VALn are property/value pairs describing parameters for the server.
144 Valid properties include:
145 `binddn' is the distinguished name of the user to bind as
146 (in RFC 1779 syntax).
147 `passwd' is the password to use for simple authentication.
148 `auth' is the authentication method to use.
149 Possible values are: `simple', `krbv41' and `krbv42'.
150 `base' is the base for the search as described in RFC 1779.
151 `scope' is one of the three symbols `subtree', `base' or `onelevel'.
152 `deref' is one of the symbols `never', `always', `search' or `find'.
153 `timelimit' is the timeout limit for the connection in seconds.
154 `sizelimit' is the maximum number of matches to return."
155 :type '(repeat :menu-tag "Host parameters"
156 :tag "Host parameters"
157 (list :menu-tag "Host parameters"
158 :tag "Host parameters"
159 :value nil
160 (string :tag "Host name")
161 (checklist :inline t
162 :greedy t
163 (list
164 :tag "Search Base"
165 :inline t
166 (const :tag "Search Base" base)
167 string)
168 (list
169 :tag "Binding DN"
170 :inline t
171 (const :tag "Binding DN" binddn)
172 string)
173 (list
174 :tag "Password"
175 :inline t
176 (const :tag "Password" passwd)
177 string)
178 (list
179 :tag "Authentication Method"
180 :inline t
181 (const :tag "Authentication Method" auth)
182 (choice
183 (const :menu-tag "None" :tag "None" nil)
184 (const :menu-tag "Simple" :tag "Simple" simple)
185 (const :menu-tag "Kerberos 4.1" :tag "Kerberos 4.1" krbv41)
186 (const :menu-tag "Kerberos 4.2" :tag "Kerberos 4.2" krbv42)))
187 (list
188 :tag "Search Scope"
189 :inline t
190 (const :tag "Search Scope" scope)
191 (choice
192 (const :menu-tag "Default" :tag "Default" nil)
193 (const :menu-tag "Subtree" :tag "Subtree" subtree)
194 (const :menu-tag "Base" :tag "Base" base)
195 (const :menu-tag "One Level" :tag "One Level" onelevel)))
196 (list
197 :tag "Dereferencing"
198 :inline t
199 (const :tag "Dereferencing" deref)
200 (choice
201 (const :menu-tag "Default" :tag "Default" nil)
202 (const :menu-tag "Never" :tag "Never" never)
203 (const :menu-tag "Always" :tag "Always" always)
204 (const :menu-tag "When searching" :tag "When searching" search)
205 (const :menu-tag "When locating base" :tag "When locating base" find)))
206 (list
207 :tag "Time Limit"
208 :inline t
209 (const :tag "Time Limit" timelimit)
210 (integer :tag "(in seconds)"))
211 (list
212 :tag "Size Limit"
213 :inline t
214 (const :tag "Size Limit" sizelimit)
215 (integer :tag "(number of records)")))))
216 :group 'ldap)
217
218 (defcustom ldap-verbose nil
219 "*If non-nil, LDAP operations echo progress messages."
220 :type 'boolean
221 :group 'ldap)
222
223 (defcustom ldap-ignore-attribute-codings nil
224 "*If non-nil, do not perform any encoding/decoding on LDAP attribute values."
225 :type 'boolean
226 :group 'ldap)
227
228 (defcustom ldap-default-attribute-encoder nil
229 "*Encoder function to use for attributes whose syntax is unknown."
230 :type 'symbol
231 :group 'ldap)
232
233 (defcustom ldap-default-attribute-decoder nil
234 "*Decoder function to use for attributes whose syntax is unknown."
235 :type 'symbol
236 :group 'ldap)
237
238 (defcustom ldap-coding-system nil
239 "*Coding system of LDAP string values.
240 LDAP v3 specifies the coding system of strings to be UTF-8.
241 Mule support is needed for this."
242 :type 'symbol
243 :group 'ldap)
244
245 (defvar ldap-attribute-syntax-encoders
246 [nil ; 1 ACI Item N
247 nil ; 2 Access Point Y
248 nil ; 3 Attribute Type Description Y
249 nil ; 4 Audio N
250 nil ; 5 Binary N
251 nil ; 6 Bit String Y
252 ldap-encode-boolean ; 7 Boolean Y
253 nil ; 8 Certificate N
254 nil ; 9 Certificate List N
255 nil ; 10 Certificate Pair N
256 ldap-encode-country-string ; 11 Country String Y
257 ldap-encode-string ; 12 DN Y
258 nil ; 13 Data Quality Syntax Y
259 nil ; 14 Delivery Method Y
260 ldap-encode-string ; 15 Directory String Y
261 nil ; 16 DIT Content Rule Description Y
262 nil ; 17 DIT Structure Rule Description Y
263 nil ; 18 DL Submit Permission Y
264 nil ; 19 DSA Quality Syntax Y
265 nil ; 20 DSE Type Y
266 nil ; 21 Enhanced Guide Y
267 nil ; 22 Facsimile Telephone Number Y
268 nil ; 23 Fax N
269 nil ; 24 Generalized Time Y
270 nil ; 25 Guide Y
271 nil ; 26 IA5 String Y
272 number-to-string ; 27 INTEGER Y
273 nil ; 28 JPEG N
274 nil ; 29 Master And Shadow Access Points Y
275 nil ; 30 Matching Rule Description Y
276 nil ; 31 Matching Rule Use Description Y
277 nil ; 32 Mail Preference Y
278 nil ; 33 MHS OR Address Y
279 nil ; 34 Name And Optional UID Y
280 nil ; 35 Name Form Description Y
281 nil ; 36 Numeric String Y
282 nil ; 37 Object Class Description Y
283 nil ; 38 OID Y
284 nil ; 39 Other Mailbox Y
285 nil ; 40 Octet String Y
286 ldap-encode-address ; 41 Postal Address Y
287 nil ; 42 Protocol Information Y
288 nil ; 43 Presentation Address Y
289 ldap-encode-string ; 44 Printable String Y
290 nil ; 45 Subtree Specification Y
291 nil ; 46 Supplier Information Y
292 nil ; 47 Supplier Or Consumer Y
293 nil ; 48 Supplier And Consumer Y
294 nil ; 49 Supported Algorithm N
295 nil ; 50 Telephone Number Y
296 nil ; 51 Teletex Terminal Identifier Y
297 nil ; 52 Telex Number Y
298 nil ; 53 UTC Time Y
299 nil ; 54 LDAP Syntax Description Y
300 nil ; 55 Modify Rights Y
301 nil ; 56 LDAP Schema Definition Y
302 nil ; 57 LDAP Schema Description Y
303 nil ; 58 Substring Assertion Y
304 ]
305 "A vector of functions used to encode LDAP attribute values.
306 The sequence of functions corresponds to the sequence of LDAP attribute syntax
307 object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
308 RFC2252 section 4.3.2")
309
310 (defvar ldap-attribute-syntax-decoders
311 [nil ; 1 ACI Item N
312 nil ; 2 Access Point Y
313 nil ; 3 Attribute Type Description Y
314 nil ; 4 Audio N
315 nil ; 5 Binary N
316 nil ; 6 Bit String Y
317 ldap-decode-boolean ; 7 Boolean Y
318 nil ; 8 Certificate N
319 nil ; 9 Certificate List N
320 nil ; 10 Certificate Pair N
321 ldap-decode-string ; 11 Country String Y
322 ldap-decode-string ; 12 DN Y
323 nil ; 13 Data Quality Syntax Y
324 nil ; 14 Delivery Method Y
325 ldap-decode-string ; 15 Directory String Y
326 nil ; 16 DIT Content Rule Description Y
327 nil ; 17 DIT Structure Rule Description Y
328 nil ; 18 DL Submit Permission Y
329 nil ; 19 DSA Quality Syntax Y
330 nil ; 20 DSE Type Y
331 nil ; 21 Enhanced Guide Y
332 nil ; 22 Facsimile Telephone Number Y
333 nil ; 23 Fax N
334 nil ; 24 Generalized Time Y
335 nil ; 25 Guide Y
336 nil ; 26 IA5 String Y
337 string-to-number ; 27 INTEGER Y
338 nil ; 28 JPEG N
339 nil ; 29 Master And Shadow Access Points Y
340 nil ; 30 Matching Rule Description Y
341 nil ; 31 Matching Rule Use Description Y
342 nil ; 32 Mail Preference Y
343 nil ; 33 MHS OR Address Y
344 nil ; 34 Name And Optional UID Y
345 nil ; 35 Name Form Description Y
346 nil ; 36 Numeric String Y
347 nil ; 37 Object Class Description Y
348 nil ; 38 OID Y
349 nil ; 39 Other Mailbox Y
350 nil ; 40 Octet String Y
351 ldap-decode-address ; 41 Postal Address Y
352 nil ; 42 Protocol Information Y
353 nil ; 43 Presentation Address Y
354 ldap-decode-string ; 44 Printable String Y
355 nil ; 45 Subtree Specification Y
356 nil ; 46 Supplier Information Y
357 nil ; 47 Supplier Or Consumer Y
358 nil ; 48 Supplier And Consumer Y
359 nil ; 49 Supported Algorithm N
360 nil ; 50 Telephone Number Y
361 nil ; 51 Teletex Terminal Identifier Y
362 nil ; 52 Telex Number Y
363 nil ; 53 UTC Time Y
364 nil ; 54 LDAP Syntax Description Y
365 nil ; 55 Modify Rights Y
366 nil ; 56 LDAP Schema Definition Y
367 nil ; 57 LDAP Schema Description Y
368 nil ; 58 Substring Assertion Y
369 ]
370 "A vector of functions used to decode LDAP attribute values.
371 The sequence of functions corresponds to the sequence of LDAP attribute syntax
372 object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
373 RFC2252 section 4.3.2")
374
375 (defvar ldap-attribute-syntaxes-alist
376 '((createtimestamp . 24)
377 (modifytimestamp . 24)
378 (creatorsname . 12)
379 (modifiersname . 12)
380 (subschemasubentry . 12)
381 (attributetypes . 3)
382 (objectclasses . 37)
383 (matchingrules . 30)
384 (matchingruleuse . 31)
385 (namingcontexts . 12)
386 (altserver . 26)
387 (supportedextension . 38)
388 (supportedcontrol . 38)
389 (supportedsaslmechanisms . 15)
390 (supportedldapversion . 27)
391 (ldapsyntaxes . 16)
392 (ditstructurerules . 17)
393 (nameforms . 35)
394 (ditcontentrules . 16)
395 (objectclass . 38)
396 (aliasedobjectname . 12)
397 (cn . 15)
398 (sn . 15)
399 (serialnumber . 44)
400 (c . 15)
401 (l . 15)
402 (st . 15)
403 (street . 15)
404 (o . 15)
405 (ou . 15)
406 (title . 15)
407 (description . 15)
408 (searchguide . 25)
409 (businesscategory . 15)
410 (postaladdress . 41)
411 (postalcode . 15)
412 (postofficebox . 15)
413 (physicaldeliveryofficename . 15)
414 (telephonenumber . 50)
415 (telexnumber . 52)
416 (telexterminalidentifier . 51)
417 (facsimiletelephonenumber . 22)
418 (x121address . 36)
419 (internationalisdnnumber . 36)
420 (registeredaddress . 41)
421 (destinationindicator . 44)
422 (preferreddeliverymethod . 14)
423 (presentationaddress . 43)
424 (supportedapplicationcontext . 38)
425 (member . 12)
426 (owner . 12)
427 (roleoccupant . 12)
428 (seealso . 12)
429 (userpassword . 40)
430 (usercertificate . 8)
431 (cacertificate . 8)
432 (authorityrevocationlist . 9)
433 (certificaterevocationlist . 9)
434 (crosscertificatepair . 10)
435 (name . 15)
436 (givenname . 15)
437 (initials . 15)
438 (generationqualifier . 15)
439 (x500uniqueidentifier . 6)
440 (dnqualifier . 44)
441 (enhancedsearchguide . 21)
442 (protocolinformation . 42)
443 (distinguishedname . 12)
444 (uniquemember . 34)
445 (houseidentifier . 15)
446 (supportedalgorithms . 49)
447 (deltarevocationlist . 9)
448 (dmdname . 15))
449 "A map of LDAP attribute names to their type object id minor number.
450 This table is built from RFC2252 Section 5 and RFC2256 Section 5")
451
452 ;;; LDAP primitive functions.
453 ;;
454 ;; LDAP object is
455 ;; (__ldap-object HOSTNAME PLIST)
456
457 (defun ldapp (object)
458 "Return t if OBJECT is a LDAP connection."
459 (and (listp object)
460 (eq (car object) '__ldap-object)))
461
462 (defun ldap-open (host &optional plist)
463 "Open a LDAP connection to HOST.
464 PLIST is a plist containing additional parameters for the connection.
465 Valid keys in that list are:
466 `port' the TCP port to use for the connection if different from
467 `ldap-default-port'.
468 `auth' is the authentication method to use, possible values depend on
469 the LDAP library: `simple', `krbv41' and `krbv42'.
470 `binddn' is the distinguished name of the user to bind as
471 (in RFC 1779 syntax).
472 `passwd' is the password to use for simple authentication.
473 `deref' is one of the symbols `never', `always', `search' or `find'.
474 `timelimit' is the timeout limit for the connection in seconds.
475 `sizelimit' is the maximum number of matches to return."
476 (list '__ldap-object host plist))
477
478 (defun ldap-host (ldap)
479 "Return the server host of the connection LDAP, as a string."
480 (nth 1 ldap))
481
482 (defun ldap-close (ldap)
483 "Close an LDAP connection."
484 t)
485
486 (defun ldap-delete (ldap dn)
487 "Delete an entry to an LDAP directory.
488 LDAP is an LDAP connection object created with `ldap-open'.
489 DN is the distinguished name of the entry to delete."
490 (let* ((plist (or (nth 2 ldap)
491 (cdr (assoc (ldap-host ldap)
492 ldap-host-parameters-alist))))
493 (port (plist-get plist 'port))
494 (binddn (plist-get plist 'binddn))
495 (passwd (plist-get plist 'passwd))
496 arglist ret)
497 (setq arglist (list (format "-h%s" (ldap-host ldap))))
498 (if (and port (not (equal 389 port)))
499 (setq arglist (nconc arglist (list (format "-p%d" port)))))
500 (if (and binddn
501 (not (equal "" binddn)))
502 (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
503 (if (and passwd
504 (not (equal "" passwd)))
505 (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
506 (with-temp-buffer
507 (setq ret (apply 'call-process
508 ldap-delete-program
509 nil (current-buffer) t
510 (append arglist
511 (list dn))))
512 (cond ((integerp ret)
513 (or (zerop ret)
514 (error "%s" (car (split-string (buffer-string) "\n")))))
515 ((and (setq ret (buffer-string)); Nemacs
516 (string-match "ldap_delete:" ret))
517 (error "%s" (car (split-string ret "\n"))))))))
518
519 (defmacro ldap/ldif-insert-field (attr value)
520 `(if (not (ldap/ldif-safe-string-p ,value))
521 (insert ,attr ":: " (base64-encode-string ,value) "\n")
522 (insert ,attr ": " ,value "\n")))
523
524 (defun ldap-modify (ldap dn mods)
525 "Add an entry to an LDAP directory.
526 LDAP is an LDAP connection object created with `ldap-open'.
527 DN is the distinguished name of the entry to modify.
528 MODS is a list of modifications to apply.
529 A modification is a list of the form (MOD-OP ATTR VALUE1 VALUE2 ...)
530 MOD-OP and ATTR are mandatory, VALUEs are optional depending on MOD-OP.
531 MOD-OP is the type of modification, one of the symbols `add', `delete'
532 or `replace'. ATTR is the LDAP attribute type to modify."
533 (let* ((plist (or (nth 2 ldap)
534 (cdr (assoc (ldap-host ldap)
535 ldap-host-parameters-alist))))
536 (port (plist-get plist 'port))
537 (binddn (plist-get plist 'binddn))
538 (passwd (plist-get plist 'passwd))
539 arglist ret)
540 (setq arglist (list (format "-h%s" (ldap-host ldap))))
541 (if (and port (not (equal 389 port)))
542 (setq arglist (nconc arglist (list (format "-p%d" port)))))
543 (if (and binddn
544 (not (equal "" binddn)))
545 (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
546 (if (and passwd
547 (not (equal "" passwd)))
548 (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
549 (with-temp-buffer
550 (ldap/ldif-insert-field "dn" dn)
551 (insert "changetype: modify\n")
552 (while mods
553 (cond
554 ((eq (nth 0 (car mods)) 'add)
555 (insert "add: " (nth 1 (car mods)) "\n")
556 (ldap/ldif-insert-field (nth 1 (car mods)) (nth 2 (car mods)))
557 (insert "-\n"))
558 ((eq (nth 0 (car mods)) 'delete)
559 (insert "delete: " (nth 1 (car mods)) "\n-\n"))
560 ((eq (nth 0 (car mods)) 'replace)
561 (insert "replace: " (nth 1 (car mods)) "\n")
562 (ldap/ldif-insert-field (nth 1 (car mods)) (nth 2 (car mods)))
563 (insert "-\n")))
564 (setq mods (cdr mods)))
565 (setq ret (apply 'call-process-region
566 (point-min) (point-max)
567 ldap-modify-program
568 t t nil
569 arglist))
570 (cond ((integerp ret)
571 (or (zerop ret)
572 (error "%s" (car (split-string (buffer-string) "\n")))))
573 ((and (setq ret (buffer-string)); Nemacs
574 (string-match "ldap_modify:" ret))
575 (error "%s" (car (split-string ret "\n"))))))))
576
577 (defun ldap-add (ldap dn entry)
578 "Add an entry to an LDAP directory.
579 LDAP is an LDAP connection object created with `ldap-open'.
580 DN is the distinguished name of the entry to add.
581 ENTRY is an entry specification, i.e., a list of cons cells
582 containing attribute/value string pairs."
583 (let* ((plist (or (nth 2 ldap)
584 (cdr (assoc (ldap-host ldap)
585 ldap-host-parameters-alist))))
586 (port (plist-get plist 'port))
587 (binddn (plist-get plist 'binddn))
588 (passwd (plist-get plist 'passwd))
589 arglist ret)
590 (setq arglist (list (format "-h%s" (ldap-host ldap))))
591 (if (and port (not (equal 389 port)))
592 (setq arglist (nconc arglist (list (format "-p%d" port)))))
593 (if (and binddn
594 (not (equal "" binddn)))
595 (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
596 (if (and passwd
597 (not (equal "" passwd)))
598 (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
599 (with-temp-buffer
600 (set-buffer-multibyte nil)
601 (ldap/ldif-insert-field "dn" dn)
602 (while entry
603 (ldap/ldif-insert-field (car (car entry)) (cdr (car entry)))
604 (setq entry (cdr entry)))
605 (setq ret (apply 'call-process-region
606 (point-min) (point-max)
607 ldap-add-program
608 t t nil
609 arglist))
610 (cond ((integerp ret)
611 (or (zerop ret)
612 (error "%s" (car (split-string (buffer-string) "\n")))))
613 ((and (setq ret (buffer-string)) ; Nemacs
614 (string-match "ldap_add:" ret))
615 (error "%s" (car (split-string ret "\n"))))))))
616
617 (defun ldap-search-basic (ldap filter base scope
618 &optional attrs attrsonly withdn verbose)
619 "Perform a search on a LDAP server. (Use external program `ldapsearch')
620 FILTER is a filter string for the search as described in RFC 1558.
621 BASE is the distinguished name at which to start the search.
622 SCOPE is one of the symbols `base', `onelevel' or `subtree' indicating
623 the scope of the search.
624 ATTRS is a list of strings indicating which attributes to retrieve
625 for each matching entry. If nil return all available attributes.
626 If ATTRSONLY is non-nil then only the attributes are retrieved, not
627 the associated values.
628 If WITHDN is non-nil each entry in the result will be prepended with
629 its distinguished name DN.
630 If VERBOSE is non-nil progress messages will be echoed.
631 The function returns a list of matching entries. Each entry is itself
632 an alist of attribute/value pairs optionally preceded by the DN of the
633 entry according to the value of WITHDN."
634 (let* ((plist (or (nth 2 ldap)
635 (cdr (assoc (ldap-host ldap)
636 ldap-host-parameters-alist))))
637 (port (plist-get plist 'port))
638 (base (or base (plist-get plist 'base) ldap-default-base))
639 (scope (or scope (plist-get plist 'scope)))
640 (binddn (plist-get plist 'binddn))
641 (passwd (plist-get plist 'passwd))
642 (deref (plist-get plist 'deref))
643 (timelimit (plist-get plist 'timelimit))
644 (sizelimit (plist-get plist 'sizelimit))
645 start value attrs-result
646 (i 0)
647 result arglist ret)
648 (setq arglist (list (format "-h%s" (ldap-host ldap))))
649 (if (and port (not (equal 389 port)))
650 (setq arglist (nconc arglist (list (format "-p%d" port)))))
651 (if (and base
652 (not (equal "" base)))
653 (setq arglist (nconc arglist (list (format "-b%s" base)))))
654 (if (and scope
655 (not (equal "" scope)))
656 (setq
657 arglist
658 (nconc
659 arglist
660 (list (format "-s%s"
661 (cond ((eq scope 'onelevel) "one")
662 ((eq scope 'base) "base")
663 ((eq scope 'subtree) "sub")
664 ((null scope) "sub")
665 (t (error "Invalid scope: %s" scope))))))))
666 (if (and binddn
667 (not (equal "" binddn)))
668 (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
669 (if (and passwd
670 (not (equal "" passwd)))
671 (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
672 (if (and deref
673 (not (equal "" deref)))
674 (setq arglist (nconc arglist (list (format "-a%s" deref)))))
675 (if (and timelimit
676 (not (equal "" timelimit)))
677 (setq arglist (nconc arglist (list (format "-l%s" timelimit)))))
678 (if (and sizelimit
679 (not (equal "" sizelimit)))
680 (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
681 (with-temp-buffer
682 (set-buffer-multibyte nil)
683 (setq ret (apply 'call-process
684 ldap-search-program
685 nil (current-buffer) t
686 (append arglist
687 ldap-search-program-arguments
688 (list filter)
689 attrs)))
690 (if (and (integerp ret)
691 (not (zerop ret))
692 ;; When openldap's `ldapsearch' exceeds response size limit,
693 ;; it's exit status becomes `4'.
694 (/= ret 4)
695 ;; When openldap's `ldapsearch' uses referral,
696 ;; it's exit status becomes `32'.
697 (/= ret 32))
698 (error "LDAP error: \"No such object\""))
699 (goto-char (point-min))
700 (setq start (point))
701 (while (and (not (eobp))
702 (re-search-forward "^$" nil t)) ; empty line is a delimiter.
703 (if verbose
704 (message "Parsing ldap results...%d" (setq i (+ i 1))))
705 (save-excursion
706 (save-restriction
707 (narrow-to-region start (point))
708 (if attrs
709 (setq attrs-result (delq
710 nil
711 (mapcar
712 (lambda (attr)
713 ;; dn is not an attribute.
714 (unless (string= attr "dn")
715 (if (setq value
716 (ldap/field-body attr))
717 (if attrsonly
718 (list attr)
719 (nconc (list attr) value)))))
720 attrs)))
721 (setq attrs-result (ldap/collect-field "dn"))
722 (if attrsonly
723 (setq attrs-result (mapcar (lambda (x) (list (car x)))
724 attrs-result))))
725 (setq result
726 (cons
727 (if withdn
728 (if attrs-result
729 (nconc (ldap/field-body "dn") attrs-result)
730 (ldap/field-body "dn"))
731 attrs-result)
732 result))))
733 (if (not (eobp)) (forward-char 1))
734 (setq start (point)))
735 (if verbose
736 (message "Parsing ldap results...done"))
737 (delq nil (nreverse result)))))
738
739 (defun ldap/field-end ()
740 "Move to end of field and return this point."
741 (if (re-search-forward ldap-ldif-next-field-head-regexp nil t)
742 (goto-char (match-beginning 0))
743 (if (re-search-forward "^$" nil t)
744 (goto-char (1- (match-beginning 0)))
745 (end-of-line)))
746 (point))
747
748 (defun ldap/field-body (name)
749 "Return field body list of NAME."
750 (save-excursion
751 (goto-char (point-min))
752 (let ((case-fold-search t)
753 (field-body nil)
754 body)
755 ;; search for the line which have name with options.
756 (while (re-search-forward (concat "^" name
757 "\\(;[a-zA-Z0-9-]+\\)?:[ \t]*") nil t)
758 ;; Base64
759 (if (string-match "^:[ \t]*" (setq body
760 (buffer-substring-no-properties
761 (match-end 0)
762 (ldap/field-end))))
763 (setq body (base64-decode-string (substring body (match-end 0)))))
764 (setq field-body (nconc field-body (list body))))
765 field-body)))
766
767 (defun ldap/collect-field (without)
768 "Collect fields without WITHOUT."
769 (goto-char (point-min))
770 (let ((regexp (concat "\\(" ldap-ldif-field-head-regexp "\\)[ \t]*"))
771 dest name name-option body entry)
772 (while (re-search-forward regexp nil t)
773 ;; name with options.
774 (setq name-option (split-string (downcase (buffer-substring-no-properties
775 (match-beginning 1)
776 (1- (match-end 1))))
777 ";"))
778 ;; XXX options are discarded.
779 (setq name (car name-option))
780 (setq body (buffer-substring-no-properties
781 (match-end 0) (ldap/field-end)))
782 (if (string-match "^:[ \t]*" body)
783 (setq body (base64-decode-string (substring body (match-end 0)))))
784 (unless (string= name without)
785 (if (setq entry (assoc name dest))
786 (nconc entry (list body))
787 (setq dest (cons (list name body) dest)))))
788 (nreverse dest)))
789
790 ;;; Coding/decoding functions
791 ;;
792 (defun ldap-encode-boolean (bool)
793 "Encode BOOL to LDAP type."
794 (if bool
795 "TRUE"
796 "FALSE"))
797
798 (defun ldap-decode-boolean (str)
799 "Decode STR to elisp type."
800 (cond
801 ((string-equal str "TRUE")
802 t)
803 ((string-equal str "FALSE")
804 nil)
805 (t
806 (error "Wrong LDAP boolean string: %s" str))))
807
808 (defun ldap-encode-country-string (str)
809 "Encode STR to LDAP country string."
810 ;; We should do something useful here...
811 (if (not (= 2 (length str)))
812 (error "Invalid country string: %s" str)))
813
814 (defun ldap-decode-string (str)
815 "Decode LDAP STR."
816 (if (and (fboundp 'decode-coding-string)
817 ldap-coding-system)
818 (decode-coding-string str ldap-coding-system)
819 str))
820
821 (defun ldap-encode-string (str)
822 "Encode LDAP STR."
823 (if (and (fboundp 'encode-coding-string)
824 ldap-coding-system)
825 (encode-coding-string str ldap-coding-system)
826 str))
827
828 (defun ldap-decode-address (str)
829 "Decode LDAP address STR."
830 (mapconcat 'ldap-decode-string
831 (split-string str "\\$")
832 "\n"))
833
834 (defun ldap-encode-address (str)
835 "Encode address STR to LDAP type."
836 (mapconcat 'ldap-encode-string
837 (split-string str "\n")
838 "$"))
839
840 ;;; LDAP protocol functions
841 ;;
842 (defun ldap-get-host-parameter (host parameter)
843 "Get HOST's PARAMETER in `ldap-host-parameters-alist'."
844 (plist-get (cdr (assoc host ldap-host-parameters-alist))
845 parameter))
846
847 (defun ldap-encode-attribute (attr)
848 "Encode the attribute/value pair ATTR according to LDAP rules.
849 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
850 and the corresponding decoder is then retrieved from
851 `ldap-attribute-syntax-encoders' and applied on the value(s)."
852 (let* ((name (car attr))
853 (values (cdr attr))
854 (syntax-id (cdr (assq (intern (downcase name))
855 ldap-attribute-syntaxes-alist)))
856 encoder)
857 (if syntax-id
858 (setq encoder (aref ldap-attribute-syntax-encoders
859 (1- syntax-id)))
860 (setq encoder ldap-default-attribute-encoder))
861 (if encoder
862 (cons name (mapcar encoder values))
863 attr)))
864
865 (defun ldap-decode-attribute (attr)
866 "Decode the attribute/value pair ATTR according to LDAP rules.
867 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
868 and the corresponding decoder is then retrieved from
869 `ldap-attribute-syntax-decoders' and applied on the value(s)."
870 (if (consp attr)
871 (let* ((name (car attr))
872 (values (cdr attr))
873 (syntax-id (cdr (assq (intern (downcase name))
874 ldap-attribute-syntaxes-alist)))
875 decoder)
876 (if syntax-id
877 (setq decoder (aref ldap-attribute-syntax-decoders
878 (1- syntax-id)))
879 (setq decoder ldap-default-attribute-decoder))
880 (if decoder
881 (cons name (mapcar decoder values))
882 attr))
883 attr))
884
885 (defun ldap-search (arg1 &rest args)
886 "Perform an LDAP search.if ARG1 is LDAP object, invoke `ldap-search-basic'.
887 Otherwise, invoke `ldap-search-entries'. ARGS are passed to each function."
888 (apply (if (ldapp arg1)
889 'ldap-search-basic
890 'ldap-search-entries) arg1 args))
891
892 (make-obsolete 'ldap-search
893 "Use `ldap-search-entries' instead or
894 `ldap-search-basic' for the low-level search API.")
895
896 (defun ldap-search-entries (filter &optional host attributes attrsonly withdn)
897 "Perform an LDAP search.
898 FILTER is the search filter in RFC1558 syntax, i.e., something that
899 looks like \"(cn=John Smith)\".
900 HOST is the LDAP host on which to perform the search.
901 ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all.
902 If ATTRSONLY is non nil, the attributes will be retrieved without
903 the associated values.
904 If WITHDN is non-nil each entry in the result will be prepennded with
905 its distinguished name DN.
906 Additional search parameters can be specified through
907 `ldap-host-parameters-alist' which see.
908 The function returns a list of matching entries. Each entry is itself
909 an alist of attribute/value pairs optionally preceded by the DN of the
910 entry according to the value of WITHDN."
911 (interactive "sFilter:")
912 (or host
913 (setq host ldap-default-host)
914 (error "No LDAP host specified"))
915 (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
916 ldap
917 result)
918 (if ldap-verbose
919 (message "Opening LDAP connection to %s..." host))
920 (setq ldap (ldap-open host host-plist))
921 (if ldap-verbose
922 (message "Searching with LDAP on %s..." host))
923 (setq result (ldap-search ldap (ldap-encode-string filter)
924 (plist-get host-plist 'base)
925 (plist-get host-plist 'scope)
926 attributes attrsonly withdn
927 ldap-verbose))
928 (ldap-close ldap)
929 (with-temp-buffer
930 (set-buffer-multibyte nil)
931 (if ldap-ignore-attribute-codings
932 result
933 (mapcar (function
934 (lambda (record)
935 (mapcar 'ldap-decode-attribute record)))
936 result)))))
937
938 (defun ldap-add-entries (entries &optional host binddn passwd)
939 "Add entries to an LDAP directory.
940 ENTRIES is a list of entry specifications of
941 the form (DN (ATTR . VALUE) (ATTR . VALUE) ...) where
942 DN is the distinguished name of an entry to add, the following
943 are cons cells containing attribute/value string pairs.
944 HOST is the LDAP host, defaulting to `ldap-default-host'
945 BINDDN is the DN to bind as to the server
946 PASSWD is the corresponding password"
947 (or host
948 (setq host ldap-default-host)
949 (error "No LDAP host specified"))
950 (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
951 ldap
952 (i 1))
953 (if (or binddn passwd)
954 (setq host-plist (copy-seq host-plist)))
955 (if binddn
956 (setq host-plist (plist-put host-plist 'binddn binddn)))
957 (if passwd
958 (setq host-plist (plist-put host-plist 'passwd passwd)))
959 (if ldap-verbose
960 (message "Opening LDAP connection to %s..." host))
961 (setq ldap (ldap-open host host-plist))
962 (if ldap-verbose
963 (message "Adding LDAP entries..."))
964 (mapcar (lambda (thisentry)
965 (setcdr thisentry
966 (mapcar
967 (lambda (add-spec)
968 (setq add-spec (ldap-encode-attribute
969 (list (car add-spec)
970 (cdr add-spec))))
971 (cons (nth 0 add-spec)
972 (nth 1 add-spec)))
973 (cdr thisentry)))
974 (setq thisentry (ldap-encode-attribute thisentry))
975 (ldap-add ldap (car thisentry) (cdr thisentry))
976 (if ldap-verbose
977 (message "%d added" i))
978 (setq i (1+ i)))
979 entries)
980 (ldap-close ldap)))
981
982 (defun ldap-modify-entries (entry-mods &optional host binddn passwd)
983 "Modify entries of an LDAP directory.
984 ENTRY-MODS is a list of entry modifications of the form
985 \(DN MOD-SPEC1 MOD-SPEC2 ...\) where DN is the distinguished name of
986 the entry to modify, the following are modification specifications.
987 A modification specification is itself a list of the form
988 \(MOD-OP ATTR VALUE1 VALUE2 ...\) MOD-OP and ATTR are mandatory,
989 VALUEs are optional depending on MOD-OP.
990 MOD-OP is the type of modification, one of the symbols `add', `delete'
991 or `replace'. ATTR is the LDAP attribute type to modify.
992 HOST is the LDAP host, defaulting to `ldap-default-host'
993 BINDDN is the DN to bind as to the server
994 PASSWD is the corresponding password"
995 (or host
996 (setq host ldap-default-host)
997 (error "No LDAP host specified"))
998 (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
999 ldap
1000 (i 1))
1001 (if (or binddn passwd)
1002 (setq host-plist (copy-seq host-plist)))
1003 (if binddn
1004 (setq host-plist (plist-put host-plist 'binddn binddn)))
1005 (if passwd
1006 (setq host-plist (plist-put host-plist 'passwd passwd)))
1007 (if ldap-verbose
1008 (message "Opening LDAP connection to %s..." host))
1009 (setq ldap (ldap-open host host-plist))
1010 (if ldap-verbose
1011 (message "Modifying LDAP entries..."))
1012 (mapcar (lambda (thisentry)
1013 (setcdr thisentry
1014 (mapcar
1015 (lambda (mod-spec)
1016 (if (or (eq (car mod-spec) 'add)
1017 (eq (car mod-spec) 'replace))
1018 (append (list (nth 0 mod-spec))
1019 (ldap-encode-attribute
1020 (cdr mod-spec)))))
1021 (cdr thisentry)))
1022 (ldap-modify ldap (car thisentry) (cdr thisentry))
1023 (if ldap-verbose
1024 (message "%d modified" i))
1025 (setq i (1+ i)))
1026 entry-mods)
1027 (ldap-close ldap)))
1028
1029 (defun ldap-delete-entries (dn &optional host binddn passwd)
1030 "Delete an entry from an LDAP directory.
1031 DN is the distinguished name of an entry to delete or
1032 a list of those.
1033 HOST is the LDAP host, defaulting to `ldap-default-host'
1034 BINDDN is the DN to bind as to the server
1035 PASSWD is the corresponding password."
1036 (or host
1037 (setq host ldap-default-host)
1038 (error "No LDAP host specified"))
1039 (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
1040 ldap)
1041 (if (or binddn passwd)
1042 (setq host-plist (copy-seq host-plist)))
1043 (if binddn
1044 (setq host-plist (plist-put host-plist 'binddn binddn)))
1045 (if passwd
1046 (setq host-plist (plist-put host-plist 'passwd passwd)))
1047 (if ldap-verbose
1048 (message "Opening LDAP connection to %s..." host))
1049 (setq ldap (ldap-open host host-plist))
1050 (if (consp dn)
1051 (let ((i 1))
1052 (if ldap-verbose
1053 (message "Deleting LDAP entries..."))
1054 (mapcar (function
1055 (lambda (thisdn)
1056 (ldap-delete ldap thisdn)
1057 (if ldap-verbose
1058 (message "%d deleted" i))
1059 (setq i (1+ i))))
1060 dn))
1061 (if ldap-verbose
1062 (message "Deleting LDAP entry..."))
1063 (ldap-delete ldap dn))
1064 (ldap-close ldap)))
1065 ;; end of ldap-static-if
1066 )
1067
1068 (provide 'pldap)
1069
1070 ;;; pldap.el ends here
Patches for Wanderlust