Mercurial > emacs
view lisp/net/eudcb-ldap.el @ 87170:e50a2e215441
* erc-stamp.el (erc-echo-timestamp):
* erc-lang.el (language):
* erc-backend.el (erc-server-connect): Fix buggy call to `message'.
* gnus-sum.el (gnus-summary-simplify-subject-query):
* ecomplete.el (ecomplete-display-matches): Fix buggy call to
`message'.
* textmodes/reftex.el (reftex-select-with-char):
* textmodes/reftex-toc.el (reftex-toc-do-promote)
(reftex-toc-visit-location, reftex-toc-find-section):
* textmodes/reftex-index.el (reftex-index-show-entry):
* textmodes/org.el (org-cycle-hide-archived-subtrees)
(org-table-rotate-recalc-marks, org-mark-ring-push)
(org-follow-info-link, org-mhe-get-message-folder-from-index)
(org-auto-repeat-maybe, org-store-log-note, org-delete-property)
(org-evaluate-time-range, org-edit-agenda-file-list):
* textmodes/artist.el (artist-select-next-op-in-list)
(artist-select-prev-op-in-list):
* term/mac-win.el (mac-service-insert-text):
* startup.el (fancy-about-screen):
* progmodes/vhdl-mode.el (vhdl-decision-query):
* progmodes/idlwave.el (idlwave-template)
(idlwave-scroll-completions, idlwave-display-completion-list):
* progmodes/ebrowse.el (ebrowse-show-progress):
* progmodes/cperl-mode.el (cperl-find-pods-heres):
* progmodes/antlr-mode.el (antlr-insert-option-do):
* play/mpuz.el (mpuz-close-game):
* net/rcirc.el (rcirc-next-active-buffer):
* mail/reporter.el (reporter-update-status):
* kmacro.el (kmacro-display):
* international/ja-dic-cnv.el (skkdic-set-okuri-nasi):
* emulation/viper-util.el (viper-save-setting):
* emacs-lisp/lisp-mnt.el (lm-verify):
* emacs-lisp/edebug.el (edebug-set-mode):
* emacs-lisp/checkdoc.el (checkdoc-rogue-spaces, checkdoc-defun):
* calendar/calendar.el (calendar-print-day-of-year):
* calc/calcalg3.el (calc-curve-fit):
* calc/calcalg2.el (math-integral):
* calc/calc.el (calc-read-key-sequence, calc-version):
* calc/calc-mode.el (calc-set-simplify-mode):
* calc/calc-ext.el (calc-fancy-prefix): Fix buggy call to
`message'.
author | David Kastrup <dak@gnu.org> |
---|---|
date | Sat, 08 Dec 2007 01:02:29 +0000 |
parents | d1f4134ad896 |
children | 107ccd98fa12 d38543a1c0f9 |
line wrap: on
line source
;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007 Free Software Foundation, Inc. ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm ;; This file is part of GNU Emacs. ;; GNU Emacs 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 3, or (at your option) ;; any later version. ;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This library provides specific LDAP protocol support for the ;; Emacs Unified Directory Client package ;;; Installation: ;; Install EUDC first. See EUDC documentation. ;;; Code: (require 'eudc) (require 'ldap) ;;{{{ Internal cooking (eval-and-compile (if (fboundp 'ldap-get-host-parameter) (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter) (defun eudc-ldap-get-host-parameter (host parameter) "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'." (plist-get (cdr (assoc host ldap-host-parameters-alist)) parameter)))) (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) (eudc-protocol-set 'eudc-attribute-display-method-alist '(("jpegphoto" . eudc-display-jpeg-inline) ("labeledurl" . eudc-display-url) ("audio" . eudc-display-sound) ("labeleduri" . eudc-display-url) ("mail" . eudc-display-mail) ("url" . eudc-display-url)) 'ldap) (eudc-protocol-set 'eudc-switch-to-server-hook '(eudc-ldap-check-base) 'ldap) (defun eudc-ldap-cleanup-record-simple (record) "Do some cleanup in a RECORD to make it suitable for EUDC." (mapcar (function (lambda (field) (cons (intern (car field)) (if (cdr (cdr field)) (cdr field) (car (cdr field)))))) record)) (defun eudc-filter-$ (string) (mapconcat 'identity (split-string string "\\$") "\n")) ;; Cleanup a LDAP record to make it suitable for EUDC: ;; Make the record a cons-cell instead of a list if it is single-valued ;; Filter the $ character in addresses into \n if not done by the LDAP lib (defun eudc-ldap-cleanup-record-filtering-addresses (record) (mapcar (function (lambda (field) (let ((name (intern (car field))) (value (cdr field))) (if (memq name '(postaladdress registeredaddress)) (setq value (mapcar 'eudc-filter-$ value))) (cons name (if (cdr value) value (car value)))))) 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 (ldap-search (eudc-ldap-format-query-as-rfc1558 query) eudc-server (if (listp return-attrs) (mapcar 'symbol-name return-attrs)))) final-result) (if (or (not (boundp 'ldap-ignore-attribute-codings)) ldap-ignore-attribute-codings) (setq result (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) (setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) (if (and eudc-strict-return-matches return-attrs (not (eq 'all return-attrs))) (setq result (eudc-filter-partial-records result return-attrs))) ;; Apply eudc-duplicate-attribute-handling-method (if (not (eq 'list eudc-duplicate-attribute-handling-method)) (mapc (function (lambda (record) (setq final-result (append (eudc-filter-duplicate-attributes record) final-result)))) result)) final-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-simple (ldap-search (eudc-ldap-format-query-as-rfc1558 (list (cons "objectclass" (or objectclass "person")))) eudc-server nil t)))) (defun eudc-ldap-escape-query-special-chars (string) "Value is STRING with characters forbidden in LDAP queries escaped." ;; Note that * should also be escaped but in most situations I suppose ;; the user doesn't want this (eudc-replace-in-string (eudc-replace-in-string (eudc-replace-in-string (eudc-replace-in-string string "\\\\" "\\5c") "(" "\\28") ")" "\\29") (char-to-string ?\0) "\\00")) (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) (eudc-ldap-escape-query-special-chars (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-check-base () "Check if the current LDAP server has a configured search base." (unless (or (eudc-ldap-get-host-parameter eudc-server 'base) ldap-default-base (null (y-or-n-p "No search base defined. Configure it now? "))) ;; If the server is not in ldap-host-parameters-alist we add it for the ;; user (if (null (assoc eudc-server ldap-host-parameters-alist)) (setq ldap-host-parameters-alist (cons (list eudc-server) ldap-host-parameters-alist))) (customize-variable 'ldap-host-parameters-alist))) ;;}}} (eudc-register-protocol 'ldap) (provide 'eudcb-ldap) ;;; arch-tag: 0f254dc0-7378-4fd4-ae26-18666184e96b ;;; eudcb-ldap.el ends here