Mercurial > emacs
annotate lisp/net/eudcb-ldap.el @ 110682:ba6a1c230532
gnus-html.el (gnus-html-prefetch-images): Adjust regexp to avoid regexp backtrace overflows.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Fri, 01 Oct 2010 13:33:03 +0000 |
parents | 280c8ae2476d |
children | 417b1e4d63cd |
rev | line source |
---|---|
27313 | 1 ;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend |
2 | |
74509 | 3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
106815 | 4 ;; 2005, 2006, 2007, 2008, 2009, 2010 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 |
110015
280c8ae2476d
Add "Package:" file headers to denote built-in packages.
Chong Yidong <cyd@stupidchicken.com>
parents:
106815
diff
changeset
|
9 ;; Package: eudc |
27313 | 10 |
11 ;; This file is part of GNU Emacs. | |
12 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
13 ;; GNU Emacs is free software: you can redistribute it and/or modify |
27313 | 14 ;; it under the terms of the GNU General Public License as published by |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
15 ;; the Free Software Foundation, either version 3 of the License, or |
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
16 ;; (at your option) any later version. |
27313 | 17 |
18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; You should have received a copy of the GNU General Public License | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
27313 | 25 |
26 ;;; Commentary: | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
27 ;; This library provides specific LDAP protocol support for the |
27313 | 28 ;; Emacs Unified Directory Client package |
29 | |
30 ;;; Installation: | |
31 ;; Install EUDC first. See EUDC documentation. | |
32 | |
33 ;;; Code: | |
34 | |
35 (require 'eudc) | |
36 (require 'ldap) | |
37 | |
38 | |
39 ;;{{{ Internal cooking | |
40 | |
41 (eval-and-compile | |
42 (if (fboundp 'ldap-get-host-parameter) | |
43 (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter) | |
44 (defun eudc-ldap-get-host-parameter (host parameter) | |
45 "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'." | |
46 (plist-get (cdr (assoc host ldap-host-parameters-alist)) | |
47 parameter)))) | |
48 | |
49 (defvar eudc-ldap-attributes-translation-alist | |
50 '((name . sn) | |
51 (firstname . givenname) | |
52 (email . mail) | |
53 (phone . telephonenumber)) | |
54 "Alist mapping EUDC attribute names to LDAP names.") | |
55 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
56 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
27313 | 57 'ldap) |
58 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list | |
59 'ldap) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
60 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
27313 | 61 'eudc-ldap-attributes-translation-alist 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
62 (eudc-protocol-set 'eudc-bbdb-conversion-alist |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
63 'eudc-ldap-bbdb-conversion-alist |
27313 | 64 'ldap) |
65 (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
|
66 (eudc-protocol-set 'eudc-attribute-display-method-alist |
27313 | 67 '(("jpegphoto" . eudc-display-jpeg-inline) |
68 ("labeledurl" . eudc-display-url) | |
69 ("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
|
70 ("labeleduri" . eudc-display-url) |
42779
897623591168
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42578
diff
changeset
|
71 ("mail" . eudc-display-mail) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
72 ("url" . eudc-display-url)) |
27313 | 73 'ldap) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
74 (eudc-protocol-set 'eudc-switch-to-server-hook |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
75 '(eudc-ldap-check-base) |
27313 | 76 'ldap) |
77 | |
78 (defun eudc-ldap-cleanup-record-simple (record) | |
79 "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
|
80 (mapcar |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
81 (function |
27313 | 82 (lambda (field) |
83 (cons (intern (car field)) | |
84 (if (cdr (cdr field)) | |
85 (cdr field) | |
86 (car (cdr field)))))) | |
87 record)) | |
88 | |
89 (defun eudc-filter-$ (string) | |
90 (mapconcat 'identity (split-string string "\\$") "\n")) | |
91 | |
92 ;; 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
|
93 ;; Make the record a cons-cell instead of a list if it is single-valued |
27313 | 94 ;; Filter the $ character in addresses into \n if not done by the LDAP lib |
95 (defun eudc-ldap-cleanup-record-filtering-addresses (record) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
96 (mapcar |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
97 (function |
27313 | 98 (lambda (field) |
99 (let ((name (intern (car field))) | |
100 (value (cdr field))) | |
101 (if (memq name '(postaladdress registeredaddress)) | |
102 (setq value (mapcar 'eudc-filter-$ value))) | |
103 (cons name | |
104 (if (cdr value) | |
105 value | |
106 (car value)))))) | |
107 record)) | |
108 | |
109 (defun eudc-ldap-simple-query-internal (query &optional return-attrs) | |
110 "Query the LDAP server with QUERY. | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
111 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
|
112 LDAP attribute names. |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
113 RETURN-ATTRS is a list of attributes to return, defaulting to |
27313 | 114 `eudc-default-return-attributes'." |
115 (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) | |
116 eudc-server | |
117 (if (listp return-attrs) | |
118 (mapcar 'symbol-name return-attrs)))) | |
119 final-result) | |
120 (if (or (not (boundp 'ldap-ignore-attribute-codings)) | |
121 ldap-ignore-attribute-codings) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
122 (setq result |
27313 | 123 (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) |
124 (setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) | |
125 | |
126 (if (and eudc-strict-return-matches | |
127 return-attrs | |
128 (not (eq 'all return-attrs))) | |
129 (setq result (eudc-filter-partial-records result return-attrs))) | |
130 ;; Apply eudc-duplicate-attribute-handling-method | |
131 (if (not (eq 'list eudc-duplicate-attribute-handling-method)) | |
85227
d1f4134ad896
(eudc-ldap-simple-query-internal): Use mapc rather than mapcar.
Glenn Morris <rgm@gnu.org>
parents:
78230
diff
changeset
|
132 (mapc |
27313 | 133 (function (lambda (record) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
134 (setq final-result |
27313 | 135 (append (eudc-filter-duplicate-attributes record) |
136 final-result)))) | |
137 result)) | |
138 final-result)) | |
139 | |
140 (defun eudc-ldap-get-field-list (dummy &optional objectclass) | |
141 "Return a list of valid attribute names for the current server. | |
142 OBJECTCLASS is the LDAP object class for which the valid | |
143 attribute names are returned. Default to `person'" | |
144 (interactive) | |
145 (or eudc-server | |
146 (call-interactively 'eudc-set-server)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
147 (let ((ldap-host-parameters-alist |
27313 | 148 (list (cons eudc-server |
149 '(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
|
150 (mapcar 'eudc-ldap-cleanup-record-simple |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
151 (ldap-search |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
152 (eudc-ldap-format-query-as-rfc1558 |
27313 | 153 (list (cons "objectclass" |
154 (or objectclass | |
155 "person")))) | |
156 eudc-server nil t)))) | |
157 | |
158 (defun eudc-ldap-escape-query-special-chars (string) | |
159 "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
|
160 ;; Note that * should also be escaped but in most situations I suppose |
27313 | 161 ;; the user doesn't want this |
162 (eudc-replace-in-string | |
163 (eudc-replace-in-string | |
164 (eudc-replace-in-string | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
165 (eudc-replace-in-string |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
166 string |
27313 | 167 "\\\\" "\\5c") |
168 "(" "\\28") | |
169 ")" "\\29") | |
170 (char-to-string ?\0) "\\00")) | |
171 | |
172 (defun eudc-ldap-format-query-as-rfc1558 (query) | |
173 "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
|
174 (format "(&%s)" |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
175 (apply 'concat |
27313 | 176 (mapcar '(lambda (item) |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
177 (format "(%s=%s)" |
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
178 (car item) |
27313 | 179 (eudc-ldap-escape-query-special-chars (cdr item)))) |
180 query)))) | |
181 | |
182 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
183 ;;}}} |
27313 | 184 |
185 ;;{{{ High-level interfaces (interactive functions) | |
186 | |
187 (defun eudc-ldap-customize () | |
188 "Customize the EUDC LDAP support." | |
189 (interactive) | |
190 (customize-group 'eudc-ldap)) | |
191 | |
192 (defun eudc-ldap-check-base () | |
193 "Check if the current LDAP server has a configured search base." | |
194 (unless (or (eudc-ldap-get-host-parameter eudc-server 'base) | |
195 ldap-default-base | |
65689
96187e7edd1b
2005-09-25 Romain Francoise <romain@orebokech.com>
Romain Francoise <romain@orebokech.com>
parents:
64701
diff
changeset
|
196 (null (y-or-n-p "No search base defined. Configure it now? "))) |
27313 | 197 ;; If the server is not in ldap-host-parameters-alist we add it for the |
198 ;; user | |
199 (if (null (assoc eudc-server ldap-host-parameters-alist)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
200 (setq ldap-host-parameters-alist |
27313 | 201 (cons (list eudc-server) ldap-host-parameters-alist))) |
202 (customize-variable 'ldap-host-parameters-alist))) | |
203 | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42565
diff
changeset
|
204 ;;}}} |
27313 | 205 |
206 | |
207 (eudc-register-protocol 'ldap) | |
208 | |
209 (provide 'eudcb-ldap) | |
210 | |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87649
diff
changeset
|
211 ;; arch-tag: 0f254dc0-7378-4fd4-ae26-18666184e96b |
27313 | 212 ;;; eudcb-ldap.el ends here |