Source

eudc / eudc-ldap.el

Full commit
;;; eudc-ldap.el --- Emacs Unified Directory Client - LDAP Backend

;; Copyright (C) 1998 Free Software Foundation, Inc.

;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
;; Created: Feb 1998
;; Version: $Revision$
;; Keywords: help

;; This file is part of XEmacs

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to 
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;;    This library provides specific LDAP protocol support for the 
;;    Emacs Unified Directory Client library.

;;; Installation:
;;    Install EUDC first. See EUDC documentation.

;;    This library runs under XEmacs 20 and under Emacs 19.34 and above

;;; Usage:

;;; Code:

(require 'eudc)
(require 'ldap)


;;{{{      Internal cooking

(defvar eudc-ldap-attributes-translation-alist
  '((name . sn)
    (firstname . givenname)
    (email . mail)
    (phone . telephonenumber))
  "Alist mapping EUDC attribute names to LDAP names.")

(eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal 'ldap)
(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list 'ldap)
(eudc-protocol-set 'eudc-protocol-attributes-translation-alist 
		   'eudc-ldap-attributes-translation-alist 'ldap)
(eudc-protocol-set 'eudc-bbdb-conversion-alist 'eudc-ldap-bbdb-conversion-alist 'ldap)
(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)

(defun eudc-filter-$ (string)
  (let ((res ""))
    (while (string-match " \\$ " string)
      (setq res (concat res 
			(substring string 0 (match-beginning 0))
			"\n"))
      (setq string (substring string (match-end 0))))
    (setq res (concat res string))))

(defun eudc-ldap-cleanup-record-field (field)
  "Do some cleanup in a record field to make it suitable for EUDC."
  ;; Make the field a cons-cell if it's single-valued
  (if (stringp (car (cdr field)))
      (cons (intern (car field)) 
	    (eudc-filter-$ (car (cdr field))))
    ;; Otherwise simply make the field name a symbol
    (cons (intern (car field)) (cdr field))))

(defun eudc-ldap-cleanup-record (record)
  (mapcar 'eudc-ldap-cleanup-record-field
	  record))

(defun eudc-ldap-simple-query-internal (query &optional return-attrs)
  "Query the LDAP server with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid 
LDAP attribute names.  
RETURN-ATTRS is a list of attributes to return, defaulting to 
`eudc-default-return-attributes'."
  (let ((result (mapcar 'eudc-ldap-cleanup-record
			(ldap-search (eudc-ldap-format-query-as-rfc1558 query)
				     eudc-server
				     (mapcar 'symbol-name return-attrs)))))
    (if (and eudc-strict-return-matches
	     return-attrs
	     (not (eq 'all return-attrs)))
	(eudc-filter-partial-records result return-attrs)
      result)))

(defun eudc-ldap-get-field-list (dummy &optional objectclass)
  "Return a list of valid attribute names for the current server.
OBJECTCLASS is the LDAP object class for which the valid
attribute names are returned. Default to `person'"
  (interactive)
  (or eudc-server
      (call-interactively 'eudc-set-server))
  (let ((ldap-host-parameters-alist 
	 (list (cons eudc-server
		     '(scope subtree sizelimit 1)))))
    (mapcar 'eudc-ldap-cleanup-record
	    (ldap-search 
	     (eudc-ldap-format-query-as-rfc1558 
	      (list (cons "objectclass"
			  (or objectclass
			      "person"))))
	     eudc-server nil t))))

(defun eudc-ldap-format-query-as-rfc1558 (query)
  "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
  (format "(&%s)" (apply 'concat (mapcar '(lambda (item)
					    (format "(%s=%s)" (car item) (cdr item)))
					 query))))


;;}}}        

;;{{{      High-level interfaces (interactive functions)

(defun eudc-ldap-customize ()
  "Customize the EUDC LDAP support."
  (interactive)
  (customize-group 'eudc-ldap))

(defun eudc-ldap-set-server (server)
  "Set the LDAP server to SERVER."
  (interactive "sNew LDAP Server: ")
  (eudc-set-server server 'ldap)
  (message "Selected LDAP server is now %s" server))

;;;}}}


(eudc-register-protocol 'ldap)

(provide 'eudc-ldap)

;;; eudc-ldap.el ends here