Mercurial > emacs

comparison lisp/url/url-ldap.el @ 83286:9deb6323655c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged from miles@gnu.org--gnu-2005 (patch 59, 240-245) Patches applied: * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-240 Update from CVS * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-241 Update from CVS * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-242 Update from CVS * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-243 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-244 Update from CVS * miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-245 Update from CVS * miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-59 Update from CVS git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-326
author Karoly Lorentey <lorentey@elte.hu>
date Mon, 11 Apr 2005 12:40:15 +0000
parents e86fc76a45e4 49fd31d00693
children 6c13700d1c13
comparison
equal deleted inserted replaced
83285:865f9b91fdbe 83286:9deb6323655c
1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code 1 ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
2 ;; Copyright (c) 1998 - 1999, 2004 Free Software Foundation, Inc. 2 ;; Copyright (c) 1998, 1999, 2004, 2005 Free Software Foundation, Inc.
3 3
4 ;; Keywords: comm, data, processes 4 ;; Keywords: comm, data, processes
5 5
6 ;; This file is part of GNU Emacs. 6 ;; This file is part of GNU Emacs.
7 ;; 7 ;;
110 110
111 (defun url-ldap-image-formatter (data) 111 (defun url-ldap-image-formatter (data)
112 (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>" 112 (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
113 (url-hexify-string (base64-encode-string data)))) 113 (url-hexify-string (base64-encode-string data))))
114 114
115 ;; FIXME: This needs sorting out for the Emacs LDAP functions, specifically
116 ;; calls of ldap-open, ldap-close, ldap-search-internal
117 ;;;###autoload 115 ;;;###autoload
118 (defun url-ldap (url) 116 (defun url-ldap (url)
117 "Perform an LDAP search specified by URL.
118 The return value is a buffer displaying the search results in HTML.
119 URL can be a URL string, or a URL vector of the type returned by
120 `url-generic-parse-url'."
121 (if (stringp url)
122 (setq url (url-generic-parse-url (url-unhex-string url)))
123 (if (not (vectorp url))
124 (error "Argument is not a valid URL")))
119 (save-excursion 125 (save-excursion
120 (set-buffer (generate-new-buffer " *url-ldap*")) 126 (set-buffer (generate-new-buffer " *url-ldap*"))
121 (setq url-current-object url) 127 (setq url-current-object url)
122 (insert "Content-type: text/html\r\n\r\n") 128 (insert "Content-type: text/html\r\n\r\n")
123 (if (not (fboundp 'ldap-search-internal)) 129 (if (not (fboundp 'ldap-search-internal))
140 (base-object nil) 146 (base-object nil)
141 (attributes nil) 147 (attributes nil)
142 (scope nil) 148 (scope nil)
143 (filter nil) 149 (filter nil)
144 (extensions nil) 150 (extensions nil)
145 (connection nil) 151 (results nil))
146 (results nil)
147 (extract-dn (and (fboundp 'function-max-args)
148 (= (function-max-args 'ldap-search-internal) 7))))
149 152
150 ;; Get rid of leading / 153 ;; Get rid of leading /
151 (if (string-match "^/" data) 154 (if (string-match "^/" data)
152 (setq data (substring data 1))) 155 (setq data (substring data 1)))
153 156
161 ;; fill in the defaults 164 ;; fill in the defaults
162 (setq base-object (url-unhex-string (or base-object "")) 165 (setq base-object (url-unhex-string (or base-object ""))
163 scope (intern (url-unhex-string (or scope "base"))) 166 scope (intern (url-unhex-string (or scope "base")))
164 filter (url-unhex-string (or filter "(objectClass=*)"))) 167 filter (url-unhex-string (or filter "(objectClass=*)")))
165 168
166 (if (not (memq scope '(base one tree))) 169 (if (not (memq scope '(base one sub)))
167 (error "Malformed LDAP URL: Unknown scope: %S" scope)) 170 (error "Malformed LDAP URL: Unknown scope: %S" scope))
168 171
169 ;; Convert to the internal LDAP support scoping names. 172 ;; Convert to the internal LDAP support scoping names.
170 (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree))))) 173 (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
171 174
186 189
187 (setq binddn (cdr-safe (or (assoc "bindname" extensions) 190 (setq binddn (cdr-safe (or (assoc "bindname" extensions)
188 (assoc "!bindname" extensions)))) 191 (assoc "!bindname" extensions))))
189 192
190 ;; Now, let's actually do something with it. 193 ;; Now, let's actually do something with it.
191 (setq connection (ldap-open host (if binddn (list 'binddn binddn))) 194 (setq results (cdr (ldap-search-internal
192 results (if extract-dn 195 (list 'host (concat host ":" (number-to-string port))
193 (ldap-search-internal connection filter base-object scope attributes nil t) 196 'base base-object
194 (ldap-search-internal connection filter base-object scope attributes nil))) 197 'attributes attributes
195 198 'scope scope
196 (ldap-close connection) 199 'filter filter
200 'binddn binddn))))
201
197 (insert "<html>\n" 202 (insert "<html>\n"
198 " <head>\n" 203 " <head>\n"
199 " <title>LDAP Search Results</title>\n" 204 " <title>LDAP Search Results</title>\n"
200 " <base href='" (url-recreate-url url) "'>\n" 205 " <base href='" (url-recreate-url url) "'>\n"
201 " </head>\n" 206 " </head>\n"
203 " <h1>" (int-to-string (length results)) " matches</h1>\n") 208 " <h1>" (int-to-string (length results)) " matches</h1>\n")
204 209
205 (mapc (lambda (obj) 210 (mapc (lambda (obj)
206 (insert " <hr>\n" 211 (insert " <hr>\n"
207 " <table border=1>\n") 212 " <table border=1>\n")
208 (if extract-dn
209 (insert " <tr><th colspan=2>" (car obj) "</th></tr>\n"))
210 (mapc (lambda (attr) 213 (mapc (lambda (attr)
211 (if (= (length (cdr attr)) 1) 214 (if (= (length (cdr attr)) 1)
212 ;; single match, easy 215 ;; single match, easy
213 (insert " <tr><td>" 216 (insert " <tr><td>"
214 (url-ldap-attribute-pretty-name (car attr)) 217 (url-ldap-attribute-pretty-name (car attr))
223 (url-ldap-attribute-pretty-desc (car attr) x)) 226 (url-ldap-attribute-pretty-desc (car attr) x))
224 (cdr attr) 227 (cdr attr)
225 "<br>\n") 228 "<br>\n")
226 "</td>" 229 "</td>"
227 " </tr>\n"))) 230 " </tr>\n")))
228 (if extract-dn (cdr obj) obj)) 231 obj)
229 (insert " </table>\n")) 232 (insert " </table>\n"))
230 results) 233 results)
231 234
232 (insert " <hr>\n" 235 (insert " <hr>\n"
233 " </body>\n" 236 " </body>\n"