Mercurial > emacs
comparison lisp/net/eudcb-ldap.el @ 42570:78a4068d960a
Remove unnecessary whitespaces.
author | Pavel Janík <Pavel@Janik.cz> |
---|---|
date | Sun, 06 Jan 2002 15:08:06 +0000 |
parents | ede718edd19b |
children | fcac9cd201ad |
comparison
equal
deleted
inserted
replaced
42569:df3f717a3933 | 42570:78a4068d960a |
---|---|
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
24 ;; Boston, MA 02111-1307, USA. | 24 ;; Boston, MA 02111-1307, USA. |
25 | 25 |
26 ;;; Commentary: | 26 ;;; Commentary: |
27 ;; This library provides specific LDAP protocol support for the | 27 ;; This library provides specific LDAP protocol support for the |
28 ;; Emacs Unified Directory Client package | 28 ;; Emacs Unified Directory Client package |
29 | 29 |
30 ;;; Installation: | 30 ;;; Installation: |
31 ;; Install EUDC first. See EUDC documentation. | 31 ;; Install EUDC first. See EUDC documentation. |
32 | 32 |
51 (firstname . givenname) | 51 (firstname . givenname) |
52 (email . mail) | 52 (email . mail) |
53 (phone . telephonenumber)) | 53 (phone . telephonenumber)) |
54 "Alist mapping EUDC attribute names to LDAP names.") | 54 "Alist mapping EUDC attribute names to LDAP names.") |
55 | 55 |
56 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal | 56 (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal |
57 'ldap) | 57 'ldap) |
58 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list | 58 (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list |
59 'ldap) | 59 'ldap) |
60 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist | 60 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist |
61 'eudc-ldap-attributes-translation-alist 'ldap) | 61 'eudc-ldap-attributes-translation-alist 'ldap) |
62 (eudc-protocol-set 'eudc-bbdb-conversion-alist | 62 (eudc-protocol-set 'eudc-bbdb-conversion-alist |
63 'eudc-ldap-bbdb-conversion-alist | 63 'eudc-ldap-bbdb-conversion-alist |
64 'ldap) | 64 'ldap) |
65 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) | 65 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap) |
66 (eudc-protocol-set 'eudc-attribute-display-method-alist | 66 (eudc-protocol-set 'eudc-attribute-display-method-alist |
67 '(("jpegphoto" . eudc-display-jpeg-inline) | 67 '(("jpegphoto" . eudc-display-jpeg-inline) |
68 ("labeledurl" . eudc-display-url) | 68 ("labeledurl" . eudc-display-url) |
69 ("audio" . eudc-display-sound) | 69 ("audio" . eudc-display-sound) |
70 ("labeleduri" . eudc-display-url) | 70 ("labeleduri" . eudc-display-url) |
71 ("url" . eudc-display-url)) | 71 ("url" . eudc-display-url)) |
72 'ldap) | 72 'ldap) |
73 (eudc-protocol-set 'eudc-switch-to-server-hook | 73 (eudc-protocol-set 'eudc-switch-to-server-hook |
74 '(eudc-ldap-check-base) | 74 '(eudc-ldap-check-base) |
75 'ldap) | 75 'ldap) |
76 | 76 |
77 (defun eudc-ldap-cleanup-record-simple (record) | 77 (defun eudc-ldap-cleanup-record-simple (record) |
78 "Do some cleanup in a RECORD to make it suitable for EUDC." | 78 "Do some cleanup in a RECORD to make it suitable for EUDC." |
79 (mapcar | 79 (mapcar |
80 (function | 80 (function |
81 (lambda (field) | 81 (lambda (field) |
82 (cons (intern (car field)) | 82 (cons (intern (car field)) |
83 (if (cdr (cdr field)) | 83 (if (cdr (cdr field)) |
84 (cdr field) | 84 (cdr field) |
85 (car (cdr field)))))) | 85 (car (cdr field)))))) |
90 | 90 |
91 ;; Cleanup a LDAP record to make it suitable for EUDC: | 91 ;; Cleanup a LDAP record to make it suitable for EUDC: |
92 ;; Make the record a cons-cell instead of a list if the it's single-valued | 92 ;; Make the record a cons-cell instead of a list if the it's single-valued |
93 ;; Filter the $ character in addresses into \n if not done by the LDAP lib | 93 ;; Filter the $ character in addresses into \n if not done by the LDAP lib |
94 (defun eudc-ldap-cleanup-record-filtering-addresses (record) | 94 (defun eudc-ldap-cleanup-record-filtering-addresses (record) |
95 (mapcar | 95 (mapcar |
96 (function | 96 (function |
97 (lambda (field) | 97 (lambda (field) |
98 (let ((name (intern (car field))) | 98 (let ((name (intern (car field))) |
99 (value (cdr field))) | 99 (value (cdr field))) |
100 (if (memq name '(postaladdress registeredaddress)) | 100 (if (memq name '(postaladdress registeredaddress)) |
101 (setq value (mapcar 'eudc-filter-$ value))) | 101 (setq value (mapcar 'eudc-filter-$ value))) |
105 (car value)))))) | 105 (car value)))))) |
106 record)) | 106 record)) |
107 | 107 |
108 (defun eudc-ldap-simple-query-internal (query &optional return-attrs) | 108 (defun eudc-ldap-simple-query-internal (query &optional return-attrs) |
109 "Query the LDAP server with QUERY. | 109 "Query the LDAP server with QUERY. |
110 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid | 110 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid |
111 LDAP attribute names. | 111 LDAP attribute names. |
112 RETURN-ATTRS is a list of attributes to return, defaulting to | 112 RETURN-ATTRS is a list of attributes to return, defaulting to |
113 `eudc-default-return-attributes'." | 113 `eudc-default-return-attributes'." |
114 (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) | 114 (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) |
115 eudc-server | 115 eudc-server |
116 (if (listp return-attrs) | 116 (if (listp return-attrs) |
117 (mapcar 'symbol-name return-attrs)))) | 117 (mapcar 'symbol-name return-attrs)))) |
118 final-result) | 118 final-result) |
119 (if (or (not (boundp 'ldap-ignore-attribute-codings)) | 119 (if (or (not (boundp 'ldap-ignore-attribute-codings)) |
120 ldap-ignore-attribute-codings) | 120 ldap-ignore-attribute-codings) |
121 (setq result | 121 (setq result |
122 (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) | 122 (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) |
123 (setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) | 123 (setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) |
124 | 124 |
125 (if (and eudc-strict-return-matches | 125 (if (and eudc-strict-return-matches |
126 return-attrs | 126 return-attrs |
127 (not (eq 'all return-attrs))) | 127 (not (eq 'all return-attrs))) |
128 (setq result (eudc-filter-partial-records result return-attrs))) | 128 (setq result (eudc-filter-partial-records result return-attrs))) |
129 ;; Apply eudc-duplicate-attribute-handling-method | 129 ;; Apply eudc-duplicate-attribute-handling-method |
130 (if (not (eq 'list eudc-duplicate-attribute-handling-method)) | 130 (if (not (eq 'list eudc-duplicate-attribute-handling-method)) |
131 (mapcar | 131 (mapcar |
132 (function (lambda (record) | 132 (function (lambda (record) |
133 (setq final-result | 133 (setq final-result |
134 (append (eudc-filter-duplicate-attributes record) | 134 (append (eudc-filter-duplicate-attributes record) |
135 final-result)))) | 135 final-result)))) |
136 result)) | 136 result)) |
137 final-result)) | 137 final-result)) |
138 | 138 |
141 OBJECTCLASS is the LDAP object class for which the valid | 141 OBJECTCLASS is the LDAP object class for which the valid |
142 attribute names are returned. Default to `person'" | 142 attribute names are returned. Default to `person'" |
143 (interactive) | 143 (interactive) |
144 (or eudc-server | 144 (or eudc-server |
145 (call-interactively 'eudc-set-server)) | 145 (call-interactively 'eudc-set-server)) |
146 (let ((ldap-host-parameters-alist | 146 (let ((ldap-host-parameters-alist |
147 (list (cons eudc-server | 147 (list (cons eudc-server |
148 '(scope subtree sizelimit 1))))) | 148 '(scope subtree sizelimit 1))))) |
149 (mapcar 'eudc-ldap-cleanup-record | 149 (mapcar 'eudc-ldap-cleanup-record |
150 (ldap-search | 150 (ldap-search |
151 (eudc-ldap-format-query-as-rfc1558 | 151 (eudc-ldap-format-query-as-rfc1558 |
152 (list (cons "objectclass" | 152 (list (cons "objectclass" |
153 (or objectclass | 153 (or objectclass |
154 "person")))) | 154 "person")))) |
155 eudc-server nil t)))) | 155 eudc-server nil t)))) |
156 | 156 |
157 (defun eudc-ldap-escape-query-special-chars (string) | 157 (defun eudc-ldap-escape-query-special-chars (string) |
158 "Value is STRING with characters forbidden in LDAP queries escaped." | 158 "Value is STRING with characters forbidden in LDAP queries escaped." |
159 ;; Note that * should also be escaped but in most situations I suppose | 159 ;; Note that * should also be escaped but in most situations I suppose |
160 ;; the user doesn't want this | 160 ;; the user doesn't want this |
161 (eudc-replace-in-string | 161 (eudc-replace-in-string |
162 (eudc-replace-in-string | 162 (eudc-replace-in-string |
163 (eudc-replace-in-string | 163 (eudc-replace-in-string |
164 (eudc-replace-in-string | 164 (eudc-replace-in-string |
165 string | 165 string |
166 "\\\\" "\\5c") | 166 "\\\\" "\\5c") |
167 "(" "\\28") | 167 "(" "\\28") |
168 ")" "\\29") | 168 ")" "\\29") |
169 (char-to-string ?\0) "\\00")) | 169 (char-to-string ?\0) "\\00")) |
170 | 170 |
171 (defun eudc-ldap-format-query-as-rfc1558 (query) | 171 (defun eudc-ldap-format-query-as-rfc1558 (query) |
172 "Format the EUDC QUERY list as a RFC1558 LDAP search filter." | 172 "Format the EUDC QUERY list as a RFC1558 LDAP search filter." |
173 (format "(&%s)" | 173 (format "(&%s)" |
174 (apply 'concat | 174 (apply 'concat |
175 (mapcar '(lambda (item) | 175 (mapcar '(lambda (item) |
176 (format "(%s=%s)" | 176 (format "(%s=%s)" |
177 (car item) | 177 (car item) |
178 (eudc-ldap-escape-query-special-chars (cdr item)))) | 178 (eudc-ldap-escape-query-special-chars (cdr item)))) |
179 query)))) | 179 query)))) |
180 | 180 |
181 | 181 |
182 ;;}}} | 182 ;;}}} |
183 | 183 |
184 ;;{{{ High-level interfaces (interactive functions) | 184 ;;{{{ High-level interfaces (interactive functions) |
185 | 185 |
186 (defun eudc-ldap-customize () | 186 (defun eudc-ldap-customize () |
187 "Customize the EUDC LDAP support." | 187 "Customize the EUDC LDAP support." |
194 ldap-default-base | 194 ldap-default-base |
195 (null (y-or-n-p "No search base defined. Configure it now ?"))) | 195 (null (y-or-n-p "No search base defined. Configure it now ?"))) |
196 ;; If the server is not in ldap-host-parameters-alist we add it for the | 196 ;; If the server is not in ldap-host-parameters-alist we add it for the |
197 ;; user | 197 ;; user |
198 (if (null (assoc eudc-server ldap-host-parameters-alist)) | 198 (if (null (assoc eudc-server ldap-host-parameters-alist)) |
199 (setq ldap-host-parameters-alist | 199 (setq ldap-host-parameters-alist |
200 (cons (list eudc-server) ldap-host-parameters-alist))) | 200 (cons (list eudc-server) ldap-host-parameters-alist))) |
201 (customize-variable 'ldap-host-parameters-alist))) | 201 (customize-variable 'ldap-host-parameters-alist))) |
202 | 202 |
203 ;;;}}} | 203 ;;}}} |
204 | 204 |
205 | 205 |
206 (eudc-register-protocol 'ldap) | 206 (eudc-register-protocol 'ldap) |
207 | 207 |
208 (provide 'eudcb-ldap) | 208 (provide 'eudcb-ldap) |