Mercurial > emacs
annotate lisp/net/eudcb-ldap.el @ 70323:810cd69c168f
(tool-bar-setup): Put Help and Preferences items in the default tool-bar-map.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Mon, 01 May 2006 20:15:56 +0000 |
parents | 067115a6e738 |
children | f7702c5f335d c5406394f567 |
rev | line source |
---|---|
27313 | 1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend |
2 | |
64701
34bd8e434dd7
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
3 ;; Copyright (C) 1998, 1999, 2000, 2002, 2003, 2004, |
68648
067115a6e738
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
65689
diff
changeset
|
4 ;; 2005, 2006 Free Software Foundation, Inc. |
27313 | 5 |
42779
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
6 ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
7 ;; Maintainer: Pavel Janík <Pavel@Janik.cz> |
42574 | 8 ;; Keywords: comm |
27313 | 9 |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation; either version 2, or (at your option) | |
15 ;; any later version. | |
16 | |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
64085 | 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 ;; Boston, MA 02110-1301, USA. | |
27313 | 26 |
27 ;;; Commentary: | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
28 ;; This library provides specific LDAP protocol support for the |
27313 | 29 ;; Emacs Unified Directory Client package |
30 | |
31 ;;; Installation: | |
32 ;; Install EUDC first. See EUDC documentation. | |
33 | |
34 ;;; Code: | |
35 | |
36 (require 'eudc) | |
37 (require 'ldap) | |
38 | |
39 | |
40 ;;{{{ Internal cooking | |
41 | |
42 (eval-and-compile | |
43 (if (fboundp 'ldap-get-host-parameter) | |
44 (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter) | |
45 (defun eudc-ldap-get-host-parameter (host parameter) | |
46 "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'." | |
47 (plist-get (cdr (assoc host ldap-host-parameters-alist)) | |
48 parameter)))) | |
49 | |
50 (defvar eudc-ldap-attributes-translation-alist | |
51 '((name . sn) | |
52 (firstname . givenname) | |
53 (email . mail) | |
54 (phone . telephonenumber)) | |
55 "Alist mapping EUDC attribute names to LDAP names.") | |
56 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
57 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
27313 | 58 'ldap) |
59 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list | |
60 'ldap) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
61 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
27313 | 62 'eudc-ldap-attributes-translation-alist 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
63 (eudc-protocol-set 'eudc-bbdb-conversion-alist |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
64 'eudc-ldap-bbdb-conversion-alist |
27313 | 65 'ldap) |
66 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
67 (eudc-protocol-set 'eudc-attribute-display-method-alist |
27313 | 68 '(("jpegphoto" . eudc-display-jpeg-inline) |
69 ("labeledurl" . eudc-display-url) | |
70 ("audio" . eudc-display-sound) | |
42565
ede718edd19b
(eudc-attribute-display-method-alist): Use proper attribute name labeledUri
Pavel Janík <Pavel@Janik.cz>
parents:
27313
diff
changeset
|
71 ("labeleduri" . eudc-display-url) |
42779
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
72 ("mail" . eudc-display-mail) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
73 ("url" . eudc-display-url)) |
27313 | 74 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
75 (eudc-protocol-set 'eudc-switch-to-server-hook |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
76 '(eudc-ldap-check-base) |
27313 | 77 'ldap) |
78 | |
79 (defun eudc-ldap-cleanup-record-simple (record) | |
80 "Do some cleanup in a RECORD to make it suitable for EUDC." | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
81 (mapcar |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
82 (function |
27313 | 83 (lambda (field) |
84 (cons (intern (car field)) | |
85 (if (cdr (cdr field)) | |
86 (cdr field) | |
87 (car (cdr field)))))) | |
88 record)) | |
89 | |
90 (defun eudc-filter-$ (string) | |
91 (mapconcat 'identity (split-string string "\\$") "\n")) | |
92 | |
93 ;; Cleanup a LDAP record to make it suitable for EUDC: | |
42578
281571076b02
(eudc-ldap-get-field-list): Do not try to call non-existent function.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
94 ;; Make the record a cons-cell instead of a list if it is single-valued |
27313 | 95 ;; Filter the $ character in addresses into \n if not done by the LDAP lib |
96 (defun eudc-ldap-cleanup-record-filtering-addresses (record) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
97 (mapcar |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
98 (function |
27313 | 99 (lambda (field) |
100 (let ((name (intern (car field))) | |
101 (value (cdr field))) | |
102 (if (memq name '(postaladdress registeredaddress)) | |
103 (setq value (mapcar 'eudc-filter-$ value))) | |
104 (cons name | |
105 (if (cdr value) | |
106 value | |
107 (car value)))))) | |
108 record)) | |
109 | |
110 (defun eudc-ldap-simple-query-internal (query &optional return-attrs) | |
111 "Query the LDAP server with QUERY. | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
112 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
113 LDAP attribute names. |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
114 RETURN-ATTRS is a list of attributes to return, defaulting to |
27313 | 115 `eudc-default-return-attributes'." |
116 (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) | |
117 eudc-server | |
118 (if (listp return-attrs) | |
119 (mapcar 'symbol-name return-attrs)))) | |
120 final-result) | |
121 (if (or (not (boundp 'ldap-ignore-attribute-codings)) | |
122 ldap-ignore-attribute-codings) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
123 (setq result |
27313 | 124 (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) |
125 (setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) | |
126 | |
127 (if (and eudc-strict-return-matches | |
128 return-attrs | |
129 (not (eq 'all return-attrs))) | |
130 (setq result (eudc-filter-partial-records result return-attrs))) | |
131 ;; Apply eudc-duplicate-attribute-handling-method | |
132 (if (not (eq 'list eudc-duplicate-attribute-handling-method)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
133 (mapcar |
27313 | 134 (function (lambda (record) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
135 (setq final-result |
27313 | 136 (append (eudc-filter-duplicate-attributes record) |
137 final-result)))) | |
138 result)) | |
139 final-result)) | |
140 | |
141 (defun eudc-ldap-get-field-list (dummy &optional objectclass) | |
142 "Return a list of valid attribute names for the current server. | |
143 OBJECTCLASS is the LDAP object class for which the valid | |
144 attribute names are returned. Default to `person'" | |
145 (interactive) | |
146 (or eudc-server | |
147 (call-interactively 'eudc-set-server)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
148 (let ((ldap-host-parameters-alist |
27313 | 149 (list (cons eudc-server |
150 '(scope subtree sizelimit 1))))) | |
42578
281571076b02
(eudc-ldap-get-field-list): Do not try to call non-existent function.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
151 (mapcar 'eudc-ldap-cleanup-record-simple |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
152 (ldap-search |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
153 (eudc-ldap-format-query-as-rfc1558 |
27313 | 154 (list (cons "objectclass" |
155 (or objectclass | |
156 "person")))) | |
157 eudc-server nil t)))) | |
158 | |
159 (defun eudc-ldap-escape-query-special-chars (string) | |
160 "Value is STRING with characters forbidden in LDAP queries escaped." | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
161 ;; Note that * should also be escaped but in most situations I suppose |
27313 | 162 ;; the user doesn't want this |
163 (eudc-replace-in-string | |
164 (eudc-replace-in-string | |
165 (eudc-replace-in-string | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
166 (eudc-replace-in-string |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
167 string |
27313 | 168 "\\\\" "\\5c") |
169 "(" "\\28") | |
170 ")" "\\29") | |
171 (char-to-string ?\0) "\\00")) | |
172 | |
173 (defun eudc-ldap-format-query-as-rfc1558 (query) | |
174 "Format the EUDC QUERY list as a RFC1558 LDAP search filter." | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
175 (format "(&%s)" |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
176 (apply 'concat |
27313 | 177 (mapcar '(lambda (item) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
178 (format "(%s=%s)" |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
179 (car item) |
27313 | 180 (eudc-ldap-escape-query-special-chars (cdr item)))) |
181 query)))) | |
182 | |
183 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
184 ;;}}} |
27313 | 185 |
186 ;;{{{ High-level interfaces (interactive functions) | |
187 | |
188 (defun eudc-ldap-customize () | |
189 "Customize the EUDC LDAP support." | |
190 (interactive) | |
191 (customize-group 'eudc-ldap)) | |
192 | |
193 (defun eudc-ldap-check-base () | |
194 "Check if the current LDAP server has a configured search base." | |
195 (unless (or (eudc-ldap-get-host-parameter eudc-server 'base) | |
196 ldap-default-base | |
65689
96187e7edd1b
2005-09-25 Romain Francoise <romain@orebokech.com>
Romain Francoise <romain@orebokech.com>
parents:
64701
diff
changeset
|
197 (null (y-or-n-p "No search base defined. Configure it now? "))) |
27313 | 198 ;; If the server is not in ldap-host-parameters-alist we add it for the |
199 ;; user | |
200 (if (null (assoc eudc-server ldap-host-parameters-alist)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
201 (setq ldap-host-parameters-alist |
27313 | 202 (cons (list eudc-server) ldap-host-parameters-alist))) |
203 (customize-variable 'ldap-host-parameters-alist))) | |
204 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
205 ;;}}} |
27313 | 206 |
207 | |
208 (eudc-register-protocol 'ldap) | |
209 | |
210 (provide 'eudcb-ldap) | |
211 | |
52401 | 212 ;;; arch-tag: 0f254dc0-7378-4fd4-ae26-18666184e96b |
27313 | 213 ;;; eudcb-ldap.el ends here |