Function: url-ldap

url-ldap is an autoloaded and byte-compiled function defined in url-ldap.el.gz.

Signature

(url-ldap URL)

Documentation

Perform an LDAP search specified by URL.

The return value is a buffer displaying the search results in HTML. URL can be a URL string, or a URL record of the type returned by url-generic-parse-url.

Source Code

;; Defined in /usr/src/emacs/lisp/url/url-ldap.el.gz
;;;###autoload
(defun url-ldap (url)
  "Perform an LDAP search specified by URL.
The return value is a buffer displaying the search results in HTML.
URL can be a URL string, or a URL record of the type returned by
`url-generic-parse-url'."
  (if (stringp url)
      (setq url (url-generic-parse-url (url-unhex-string url)))
    (if (not (url-p url))
        (error "Argument is not a valid URL")))
  (with-current-buffer (generate-new-buffer " *url-ldap*")
    (setq url-current-object url)
    (insert "Content-type: text/html\r\n\r\n")
    (if (not (fboundp 'ldap-search-internal))
	(insert "<html>\n"
		" <head>\n"
		"  <title>LDAP Not Supported</title>\n"
		"  <base href='" (url-recreate-url url) "'>\n"
		" </head>\n"
		" <body>\n"
		"  <h1>LDAP Not Supported</h1>\n"
		"  <p>\n"
		"    This version of Emacs does not support LDAP.\n"
		"  </p>\n"
		" </body>\n"
		"</html>\n")
      (let* ((binddn nil)
	     (data (url-filename url))
	     (host (url-host url))
	     (port (url-port url))
	     (base-object nil)
	     (attributes nil)
	     (scope nil)
	     (filter nil)
	     (extensions nil)
	     (results nil))

	;; Get rid of leading /
	(if (string-match "^/" data)
	    (setq data (substring data 1)))

	(setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
	      base-object (nth 0 data)
	      attributes (nth 1 data)
	      scope (nth 2 data)
	      filter (nth 3 data)
	      extensions (nth 4 data))

	;; fill in the defaults
	(setq base-object (url-unhex-string (or base-object ""))
	      scope (intern (url-unhex-string (or scope "base")))
	      filter (url-unhex-string (or filter "(objectClass=*)")))

	(if (not (memq scope '(base one sub)))
	    (error "Malformed LDAP URL: Unknown scope: %S" scope))

	;; Convert to the internal LDAP support scoping names.
	(setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))

	(if attributes
	    (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))

	;; Parse out the extensions.
	(if extensions
	    (setq extensions (mapcar (lambda (ext)
				       (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
					   (cons (match-string 1 ext) (match-string 2 ext))
					 (cons ext ext)))
				     (split-string extensions ","))
		  extensions (mapcar (lambda (ext)
				       (cons (url-unhex-string (car ext))
					     (url-unhex-string (cdr ext))))
				     extensions)))

	(setq binddn (cdr-safe (or (assoc "bindname" extensions)
				   (assoc "!bindname" extensions))))

	;; Now, let's actually do something with it.
	(setq results (cdr (ldap-search-internal
		       (list 'host (concat host ":" (number-to-string port))
			     'base base-object
			     'attributes attributes
			     'scope scope
			     'filter filter
			     'binddn binddn))))

	(insert "<html>\n"
		" <head>\n"
		"  <title>LDAP Search Results</title>\n"
		"  <base href='" (url-recreate-url url) "'>\n"
		" </head>\n"
		" <body>\n"
		"  <h1>" (int-to-string (length results)) " matches</h1>\n")

	(mapc (lambda (obj)
		(insert "  <hr>\n"
			"  <table border=1>\n")
		(mapc (lambda (attr)
			(if (= (length (cdr attr)) 1)
			    ;; single match, easy
			    (insert "   <tr><td>"
				    (url-ldap-attribute-pretty-name (car attr))
				    "</td><td>"
				    (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
				    "</td></tr>\n")
			  ;; Multiple matches, slightly uglier
			  (insert "   <tr>\n"
				  "    <td valign=top>"
				  (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
				  (mapconcat (lambda (x)
					       (url-ldap-attribute-pretty-desc (car attr) x))
					     (cdr attr)
					     "<br>\n")
				  "</td>"
				  "   </tr>\n")))
                      obj)
		(insert "  </table>\n"))
	      results)

	(insert "  <hr>\n"
		" </body>\n"
		"</html>\n")))
    (current-buffer)))