eudc.el 42.6 KB
Newer Older
1
;;; eudc.el --- Emacs Unified Directory Client -*- coding: utf-8 -*-
Gerd Moellmann's avatar
Gerd Moellmann committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
Gerd Moellmann's avatar
Gerd Moellmann committed
4

5
;; Author: Oscar Figueiredo <oscar@cpe.fr>
6
;; Maintainer: Pavel Janík <Pavel@Janik.cz>
7
;; Keywords: comm
Gerd Moellmann's avatar
Gerd Moellmann committed
8 9 10

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
15 16 17 18 19 20 21

;; 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
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38

;;; Commentary:
;;    This package provides a common interface to query directory servers using
;;    different protocols such as LDAP, CCSO PH/QI or BBDB.  Queries can be
;;    made through an interactive form or inline. Inline query strings in
;;    buffers are expanded with appropriately formatted query results
;;    (especially used to expand email addresses in message buffers).  EUDC
;;    also interfaces with the BBDB package to let you register query results
;;    into your own BBDB database.

;;; Usage:
;;    EUDC comes with an extensive documentation, please refer to it.
;;
;;    The main entry points of EUDC are:
;;      `eudc-query-form': Query a directory server from a query form
;;      `eudc-expand-inline': Query a directory server for the e-mail address
Juanma Barranquero's avatar
Juanma Barranquero committed
39
;;                            of the name before cursor and insert it in the
Gerd Moellmann's avatar
Gerd Moellmann committed
40 41 42 43 44 45 46 47 48 49 50
;;                            buffer
;;      `eudc-get-phone': Get a phone number from a directory server
;;      `eudc-get-email': Get an e-mail address from a directory server
;;      `eudc-customize': Customize various aspects of EUDC

;;; Code:

(require 'wid-edit)

(eval-and-compile
  (if (not (fboundp 'make-overlay))
51
      (require 'overlay)))
Gerd Moellmann's avatar
Gerd Moellmann committed
52 53 54 55 56 57 58 59 60 61 62 63 64

(unless (fboundp 'custom-menu-create)
  (autoload 'custom-menu-create "cus-edit"))

(require 'eudc-vars)



;;{{{      Internal cooking

;;{{{      Internal variables and compatibility tricks

(defvar eudc-form-widget-list nil)
65 66 67 68 69 70 71 72 73 74 75

(defvar eudc-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "q" 'kill-this-buffer)
    (define-key map "x" 'kill-this-buffer)
    (define-key map "f" 'eudc-query-form)
    (define-key map "b" 'eudc-try-bbdb-insert)
    (define-key map "n" 'eudc-move-to-next-record)
    (define-key map "p" 'eudc-move-to-previous-record)
    map))
(set-keymap-parent eudc-mode-map widget-keymap)
Gerd Moellmann's avatar
Gerd Moellmann committed
76

77 78
(defvar mode-popup-menu)

Gerd Moellmann's avatar
Gerd Moellmann committed
79 80 81
;; List of variables that have server- or protocol-local bindings
(defvar eudc-local-vars nil)

82
;; Protocol local. Query function
Gerd Moellmann's avatar
Gerd Moellmann committed
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
(defvar eudc-query-function nil)

;; Protocol local.  A function that retrieves a list of valid attribute names
(defvar eudc-list-attributes-function nil)

;; Protocol local. A mapping between EUDC attribute names and corresponding
;; protocol specific names.  The following names are defined by EUDC and may be
;; included in that list: `name' , `firstname', `email', `phone'
(defvar eudc-protocol-attributes-translation-alist nil)

;; Protocol local. Mapping between protocol attribute names and BBDB field
;; names
(defvar eudc-bbdb-conversion-alist nil)

;; Protocol/Server local. Hook called upon switching to that server
(defvar eudc-switch-to-server-hook nil)

;; Protocol/Server local. Hook called upon switching from that server
(defvar eudc-switch-from-server-hook nil)

;; Protocol local. Whether the protocol supports queries with no specified
;; attribute name
(defvar eudc-protocol-has-default-query-attributes nil)

(defun eudc-cadr (obj)
  (car (cdr obj)))

(defun eudc-cdar (obj)
  (cdr (car obj)))

(defun eudc-caar (obj)
  (car (car obj)))

(defun eudc-cdaar (obj)
  (cdr (car (car obj))))

(defun eudc-plist-member (plist prop)
  "Return t if PROP has a value specified in PLIST."
  (if (not (= 0 (% (length plist) 2)))
      (error "Malformed plist"))
  (catch 'found
    (while plist
      (if (eq prop (car plist))
	  (throw 'found t))
      (setq plist (cdr (cdr plist))))
    nil))

130
;; Emacs's plist-get lacks third parameter
Gerd Moellmann's avatar
Gerd Moellmann committed
131 132 133
(defun eudc-plist-get (plist prop &optional default)
  "Extract a value from a property list.
PLIST is a property list, which is a list of the form
134
\(PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
Gerd Moellmann's avatar
Gerd Moellmann committed
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
corresponding to the given PROP, or DEFAULT if PROP is not
one of the properties on the list."
  (if (eudc-plist-member plist prop)
      (plist-get plist prop)
    default))

(defun eudc-lax-plist-get (plist prop &optional default)
  "Extract a value from a lax property list.

PLIST is a lax property list, which is a list of the form (PROP1
VALUE1 PROP2 VALUE2...), where comparisons between properties are done
using `equal' instead of `eq'.  This function returns the value
corresponding to PROP, or DEFAULT if PROP is not one of the
properties on the list."
  (if (not (= 0 (% (length plist) 2)))
      (error "Malformed plist"))
  (catch 'found
    (while plist
      (if (equal prop (car plist))
	  (throw 'found (car (cdr plist))))
      (setq plist (cdr (cdr plist))))
    default))

(if (not (fboundp 'split-string))
    (defun split-string (string &optional pattern)
      "Return a list of substrings of STRING which are separated by PATTERN.
If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
  (or pattern
      (setq pattern "[ \f\t\n\r\v]+"))
  (let (parts (start 0))
    (when (string-match pattern string 0)
      (if (> (match-beginning 0) 0)
	  (setq parts (cons (substring string 0 (match-beginning 0)) nil)))
      (setq start (match-end 0))
      (while (and (string-match pattern string start)
		  (> (match-end 0) start))
	(setq parts (cons (substring string start (match-beginning 0)) parts)
	      start (match-end 0))))
    (nreverse (if (< start (length string))
		  (cons (substring string start) parts)
		parts)))))

(defun eudc-replace-in-string (str regexp newtext)
  "Replace all matches in STR for REGEXP with NEWTEXT.
Value is the new string."
  (let ((rtn-str "")
	(start 0)
	match prev-start)
    (while (setq match (string-match regexp str start))
      (setq prev-start start
	    start (match-end 0)
	    rtn-str
	    (concat rtn-str
		    (substring str prev-start match)
		    newtext)))
    (concat rtn-str (substring str start))))

192
;;}}}
Gerd Moellmann's avatar
Gerd Moellmann committed
193 194 195 196 197 198 199 200 201 202 203 204 205 206

;;{{{ Server and Protocol Variable Routines

(defun eudc-server-local-variable-p (var)
  "Return non-nil if VAR has server-local bindings."
  (eudc-plist-member (get var 'eudc-locals) 'server))

(defun eudc-protocol-local-variable-p (var)
  "Return non-nil if VAR has protocol-local bindings."
  (eudc-plist-member (get var 'eudc-locals) 'protocol))

(defun eudc-default-set (var val)
  "Set the EUDC default value of VAR to VAL.
The current binding of VAR is not changed."
Juanma Barranquero's avatar
Juanma Barranquero committed
207
  (put var 'eudc-locals
Gerd Moellmann's avatar
Gerd Moellmann committed
208 209 210 211 212 213 214 215 216 217 218 219 220
       (plist-put (get var 'eudc-locals) 'default val))
  (add-to-list 'eudc-local-vars var))

(defun eudc-protocol-set (var val &optional protocol)
  "Set the PROTOCOL-local binding of VAR to VAL.
If omitted PROTOCOL defaults to the current value of `eudc-protocol'.
The current binding of VAR is changed only if PROTOCOL is omitted."
  (if (eq 'unbound (eudc-variable-default-value var))
      (eudc-default-set var (symbol-value var)))
  (let* ((eudc-locals (get var 'eudc-locals))
	 (protocol-locals (eudc-plist-get eudc-locals 'protocol)))
    (setq protocol-locals (plist-put protocol-locals (or protocol
							 eudc-protocol) val))
Juanma Barranquero's avatar
Juanma Barranquero committed
221
    (setq eudc-locals
Gerd Moellmann's avatar
Gerd Moellmann committed
222 223 224 225 226
	  (plist-put eudc-locals 'protocol protocol-locals))
    (put var 'eudc-locals eudc-locals)
    (add-to-list 'eudc-local-vars var)
    (unless protocol
      (eudc-update-variable var))))
227

Gerd Moellmann's avatar
Gerd Moellmann committed
228 229 230 231 232 233 234 235 236 237
(defun eudc-server-set (var val &optional server)
  "Set the SERVER-local binding of VAR to VAL.
If omitted SERVER defaults to the current value of `eudc-server'.
The current binding of VAR is changed only if SERVER is omitted."
  (if (eq 'unbound (eudc-variable-default-value var))
      (eudc-default-set var (symbol-value var)))
  (let* ((eudc-locals (get var 'eudc-locals))
	 (server-locals (eudc-plist-get eudc-locals 'server)))
    (setq server-locals (plist-put server-locals (or server
						     eudc-server) val))
238
    (setq eudc-locals
Gerd Moellmann's avatar
Gerd Moellmann committed
239 240 241 242 243 244 245 246 247 248
	  (plist-put eudc-locals 'server server-locals))
    (put var 'eudc-locals eudc-locals)
    (add-to-list 'eudc-local-vars var)
    (unless server
      (eudc-update-variable var))))


(defun eudc-set (var val)
  "Set the most local (server, protocol or default) binding of VAR to VAL.
The current binding of VAR is also set to VAL"
249
  (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277
   ((not (eq 'unbound (eudc-variable-server-value var)))
    (eudc-server-set var val))
   ((not (eq 'unbound (eudc-variable-protocol-value var)))
    (eudc-protocol-set var val))
   (t
    (eudc-default-set var val)))
  (set var val))

(defun eudc-variable-default-value (var)
  "Return the default binding of VAR.
Return `unbound' if VAR has no EUDC default value."
  (let ((eudc-locals (get var 'eudc-locals)))
    (if (and (boundp var)
	     eudc-locals)
	(eudc-plist-get eudc-locals 'default 'unbound)
      'unbound)))

(defun eudc-variable-protocol-value (var &optional protocol)
  "Return the value of VAR local to PROTOCOL.
Return `unbound' if VAR has no value local to PROTOCOL.
PROTOCOL defaults to `eudc-protocol'"
  (let* ((eudc-locals (get var 'eudc-locals))
	 protocol-locals)
    (if (not (and  (boundp var)
		   eudc-locals
		   (eudc-plist-member eudc-locals 'protocol)))
	'unbound
      (setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
278
      (eudc-lax-plist-get protocol-locals
Gerd Moellmann's avatar
Gerd Moellmann committed
279 280 281 282 283 284 285 286 287 288 289 290 291 292
			  (or protocol
			      eudc-protocol) 'unbound))))

(defun eudc-variable-server-value (var &optional server)
  "Return the value of VAR local to SERVER.
Return `unbound' if VAR has no value local to SERVER.
SERVER defaults to `eudc-server'"
  (let* ((eudc-locals (get var 'eudc-locals))
	 server-locals)
    (if (not (and (boundp var)
		  eudc-locals
		  (eudc-plist-member eudc-locals 'server)))
	'unbound
      (setq server-locals (eudc-plist-get eudc-locals 'server))
Juanma Barranquero's avatar
Juanma Barranquero committed
293
      (eudc-lax-plist-get server-locals
Gerd Moellmann's avatar
Gerd Moellmann committed
294 295 296 297 298 299 300 301 302
			  (or server
			      eudc-server) 'unbound))))

(defun eudc-update-variable (var)
  "Set the value of VAR according to its locals.
If the VAR has a server- or protocol-local value corresponding
to the current `eudc-server' and `eudc-protocol' then it is set
accordingly. Otherwise it is set to its EUDC default binding"
  (let (val)
303
    (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
     ((not (eq 'unbound (setq val (eudc-variable-server-value var))))
      (set var val))
     ((not (eq 'unbound (setq val (eudc-variable-protocol-value var))))
      (set var val))
     ((not (eq 'unbound (setq val (eudc-variable-default-value var))))
      (set var val)))))

(defun eudc-update-local-variables ()
  "Update all EUDC variables according to their local settings."
  (interactive)
  (mapcar 'eudc-update-variable eudc-local-vars))

(eudc-default-set 'eudc-query-function nil)
(eudc-default-set 'eudc-list-attributes-function nil)
(eudc-default-set 'eudc-protocol-attributes-translation-alist nil)
(eudc-default-set 'eudc-bbdb-conversion-alist nil)
(eudc-default-set 'eudc-switch-to-server-hook nil)
(eudc-default-set 'eudc-switch-from-server-hook nil)
(eudc-default-set 'eudc-protocol-has-default-query-attributes nil)
(eudc-default-set 'eudc-attribute-display-method-alist nil)

;;}}}


;; Add PROTOCOL to the list of supported protocols
(defun eudc-register-protocol (protocol)
  (unless (memq protocol eudc-supported-protocols)
331
    (setq eudc-supported-protocols
Gerd Moellmann's avatar
Gerd Moellmann committed
332
	  (cons protocol eudc-supported-protocols))
333
    (put 'eudc-protocol 'custom-type
Gerd Moellmann's avatar
Gerd Moellmann committed
334
	 `(choice :menu-tag "Protocol"
335
		  ,@(mapcar (lambda (s)
Gerd Moellmann's avatar
Gerd Moellmann committed
336 337 338 339 340 341 342 343 344 345 346 347
			      (list 'string ':tag (symbol-name s)))
			    eudc-supported-protocols))))
  (or (memq protocol eudc-known-protocols)
      (setq eudc-known-protocols
	    (cons protocol eudc-known-protocols))))


(defun eudc-translate-query (query)
  "Translate attribute names of QUERY.
The translation is done according to
`eudc-protocol-attributes-translation-alist'."
  (if eudc-protocol-attributes-translation-alist
348 349 350 351 352 353
      (mapcar (lambda (attribute)
                (let ((trans (assq (car attribute)
                                   (symbol-value eudc-protocol-attributes-translation-alist))))
                  (if trans
                      (cons (cdr trans) (cdr attribute))
                    attribute)))
Gerd Moellmann's avatar
Gerd Moellmann committed
354
	      query)
355
    query))
Gerd Moellmann's avatar
Gerd Moellmann committed
356 357 358 359 360 361 362

(defun eudc-translate-attribute-list (list)
  "Translate a list of attribute names LIST.
The translation is done according to
`eudc-protocol-attributes-translation-alist'."
  (if eudc-protocol-attributes-translation-alist
      (let (trans)
363
	(mapcar (lambda (attribute)
Gerd Moellmann's avatar
Gerd Moellmann committed
364 365 366 367 368 369 370 371
		   (setq trans (assq attribute
				     (symbol-value eudc-protocol-attributes-translation-alist)))
		   (if trans
		       (cdr trans)
		     attribute))
		list))
    list))

372 373 374 375 376
(defun eudc-select (choices beg end)
  "Choose one from CHOICES using a completion.
BEG and END delimit the text which is to be replaced."
  (let ((replacement))
   (setq replacement
377
	 (completing-read "Multiple matches found; choose one: "
378 379 380
			  (mapcar 'list choices)))
   (delete-region beg end)
   (insert replacement)))
Gerd Moellmann's avatar
Gerd Moellmann committed
381 382 383 384 385

(defun eudc-query (query &optional return-attributes no-translation)
   "Query the current directory server with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
name and VALUE the corresponding value.
386
If NO-TRANSLATION is non-nil, ATTR is translated according to
Gerd Moellmann's avatar
Gerd Moellmann committed
387
`eudc-protocol-attributes-translation-alist'.
388
RETURN-ATTRIBUTES is a list of attributes to return defaulting to
Gerd Moellmann's avatar
Gerd Moellmann committed
389 390 391 392 393 394
`eudc-default-return-attributes'."
   (unless eudc-query-function
     (error "Don't know how to perform the query"))
   (if no-translation
       (funcall eudc-query-function query (or return-attributes
					      eudc-default-return-attributes))
395 396

     (funcall eudc-query-function
Gerd Moellmann's avatar
Gerd Moellmann committed
397
	      (eudc-translate-query query)
398
	      (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
399 400 401 402 403 404 405 406 407
	       (return-attributes
		(eudc-translate-attribute-list return-attributes))
	       ((listp eudc-default-return-attributes)
		(eudc-translate-attribute-list eudc-default-return-attributes))
	       (t
		eudc-default-return-attributes)))))

(defun eudc-format-attribute-name-for-display (attribute)
  "Format a directory attribute name for display.
408
ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
Gerd Moellmann's avatar
Gerd Moellmann committed
409 410 411 412 413
by the corresponding user name if any.  Otherwise it is capitalized and
underscore characters are replaced by spaces."
  (let ((match (assq attribute eudc-user-attribute-names-alist)))
    (if match
	(cdr match)
414 415
      (capitalize
       (mapconcat 'identity
Gerd Moellmann's avatar
Gerd Moellmann committed
416 417 418 419 420
		  (split-string (symbol-name attribute) "_")
		  " ")))))

(defun eudc-print-attribute-value (field)
  "Insert the value of the directory FIELD at point.
421 422
The directory attribute name in car of FIELD is looked up in
`eudc-attribute-display-method-alist' and the corresponding method,
Gerd Moellmann's avatar
Gerd Moellmann committed
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
if any, is called to print the value in cdr of FIELD."
  (let ((match (assoc (downcase (car field))
		      eudc-attribute-display-method-alist))
	(col (current-column))
	(val (cdr field)))
    (if match
	(progn
	  (eval (list (cdr match) val))
	  (insert "\n"))
      (mapcar
       (function
	(lambda (val-elem)
	  (indent-to col)
	  (insert val-elem "\n")))
       (cond
	((listp val) val)
	((stringp val) (split-string val "\n"))
	((null val) '(""))
	(t (list val)))))))

(defun eudc-print-record-field (field column-width)
  "Print the record field FIELD.
FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
446
COLUMN-WIDTH is the width of the first display column containing the
Gerd Moellmann's avatar
Gerd Moellmann committed
447 448 449 450 451
attribute name ATTR."
  (let ((field-beg (point)))
;; The record field that is passed to this function has already been processed
;; by `eudc-format-attribute-name-for-display' so we don't need to call it
;; again to display the attribute name
452
    (insert (format (concat "%" (int-to-string column-width) "s: ")
Gerd Moellmann's avatar
Gerd Moellmann committed
453 454 455 456 457 458
		    (car field)))
    (put-text-property field-beg (point) 'face 'bold)
    (indent-to (+ 2 column-width))
    (eudc-print-attribute-value field)))

(defun eudc-display-records (records &optional raw-attr-names)
459
  "Display the record list RECORDS in a formatted buffer.
Gerd Moellmann's avatar
Gerd Moellmann committed
460 461
If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
otherwise they are formatted according to `eudc-user-attribute-names-alist'."
462
  (let (inhibit-read-only
Gerd Moellmann's avatar
Gerd Moellmann committed
463 464 465 466 467
	precords
	(width 0)
	beg
	first-record
	attribute-name)
468 469 470 471 472 473 474 475 476 477 478 479 480 481
    (with-output-to-temp-buffer "*Directory Query Results*"
      (with-current-buffer standard-output
	(setq buffer-read-only t)
	(setq inhibit-read-only t)
	(erase-buffer)
	(insert "Directory Query Result\n")
	(insert "======================\n\n\n")
	(if (null records)
	    (insert "No match found.\n"
		    (if eudc-strict-return-matches
			"Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n"
		      ""))
	  ;; Replace field names with user names, compute max width
	  (setq precords
482
		(mapcar
Gerd Moellmann's avatar
Gerd Moellmann committed
483
		 (function
484 485 486 487 488 489 490 491 492 493 494 495 496 497 498
		  (lambda (record)
		    (mapcar
		     (function
		      (lambda (field)
			(setq attribute-name
			      (if raw-attr-names
				  (symbol-name (car field))
				(eudc-format-attribute-name-for-display (car field))))
			(if (> (length attribute-name) width)
			    (setq width (length attribute-name)))
			(cons attribute-name (cdr field))))
		     record)))
		 records))
	  ;; Display the records
	  (setq first-record (point))
Glenn Morris's avatar
Glenn Morris committed
499
	  (mapc
500 501 502 503
	   (function
	    (lambda (record)
	      (setq beg (point))
	      ;; Map over the record fields to print the attribute/value pairs
Glenn Morris's avatar
Glenn Morris committed
504 505 506 507
	      (mapc (function
		     (lambda (field)
		       (eudc-print-record-field field width)))
		    record)
508 509 510 511 512 513 514 515 516
	      ;; Store the record internal format in some convenient place
	      (overlay-put (make-overlay beg (point))
			   'eudc-record
			   (car records))
	      (setq records (cdr records))
	      (insert "\n")))
	   precords))
	(insert "\n")
	(widget-create 'push-button
Daniel Hackney's avatar
Daniel Hackney committed
517
		       :notify (lambda (&rest _ignore)
518 519 520 521
				 (eudc-query-form))
		       "New query")
	(widget-insert " ")
	(widget-create 'push-button
Daniel Hackney's avatar
Daniel Hackney committed
522
		       :notify (lambda (&rest _ignore)
523 524 525 526 527 528
				 (kill-this-buffer))
		       "Quit")
	(eudc-mode)
	(widget-setup)
	(if first-record
	    (goto-char first-record))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
529 530 531 532 533 534 535 536

(defun eudc-process-form ()
  "Process the query form in current buffer and display the results."
  (let (query-alist
	value)
    (if (not (and (boundp 'eudc-form-widget-list)
		  eudc-form-widget-list))
	(error "Not in a directory query form buffer")
Glenn Morris's avatar
Glenn Morris committed
537 538 539 540 541 542 543
      (mapc (function
	     (lambda (wid-field)
	       (setq value (widget-value (cdr wid-field)))
	       (if (not (string= value ""))
		   (setq query-alist (cons (cons (car wid-field) value)
					   query-alist)))))
	    eudc-form-widget-list)
Gerd Moellmann's avatar
Gerd Moellmann committed
544 545
      (kill-buffer (current-buffer))
      (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names))))
546

Gerd Moellmann's avatar
Gerd Moellmann committed
547 548 549 550 551 552 553 554 555 556 557 558 559 560 561

(defun eudc-filter-duplicate-attributes (record)
  "Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
  (let ((rec record)
	unique
	duplicates
	result)

    ;; Search for multiple records
    (while (and rec
		(not (listp (eudc-cdar rec))))
      (setq rec (cdr rec)))

    (if (null (eudc-cdar rec))
	(list record)			; No duplicate attrs in this record
Glenn Morris's avatar
Glenn Morris committed
562 563 564 565 566 567
      (mapc (function
	     (lambda (field)
	       (if (listp (cdr field))
		   (setq duplicates (cons field duplicates))
		 (setq unique (cons field unique)))))
	    record)
Gerd Moellmann's avatar
Gerd Moellmann committed
568 569
      (setq result (list unique))
      ;; Map over the record fields that have multiple values
Glenn Morris's avatar
Glenn Morris committed
570
      (mapc
Gerd Moellmann's avatar
Gerd Moellmann committed
571 572 573
       (function
	(lambda (field)
	  (let ((method (if (consp eudc-duplicate-attribute-handling-method)
574 575 576 577 578
			    (cdr
			     (assq
			      (or
			       (car
				(rassq
Gerd Moellmann's avatar
Gerd Moellmann committed
579
				 (car field)
580
				 (symbol-value
Gerd Moellmann's avatar
Gerd Moellmann committed
581 582 583 584 585 586
				  eudc-protocol-attributes-translation-alist)))
			       (car field))
			      eudc-duplicate-attribute-handling-method))
			  eudc-duplicate-attribute-handling-method)))
	    (cond
	     ((or (null method) (eq 'list method))
587
	      (setq result
Gerd Moellmann's avatar
Gerd Moellmann committed
588 589
		    (eudc-add-field-to-records field result)))
	     ((eq 'first method)
590 591 592
	      (setq result
		    (eudc-add-field-to-records (cons (car field)
						     (eudc-cadr field))
Gerd Moellmann's avatar
Gerd Moellmann committed
593 594
					       result)))
	     ((eq 'concat method)
595
	      (setq result
Gerd Moellmann's avatar
Gerd Moellmann committed
596
		    (eudc-add-field-to-records (cons (car field)
597
						     (mapconcat
Gerd Moellmann's avatar
Gerd Moellmann committed
598 599 600 601 602 603 604 605 606 607
						      'identity
						      (cdr field)
						      "\n")) result)))
	     ((eq 'duplicate method)
	      (setq result
		    (eudc-distribute-field-on-records field result)))))))
       duplicates)
      result)))

(defun eudc-filter-partial-records (records attrs)
608
  "Eliminate records that do not contain all ATTRS from RECORDS."
609 610 611
  (delq nil
	(mapcar
	 (function
Gerd Moellmann's avatar
Gerd Moellmann committed
612
	  (lambda (rec)
613 614 615
	    (if (eval (cons 'and
		       (mapcar
			(function
Gerd Moellmann's avatar
Gerd Moellmann committed
616 617 618 619 620
			 (lambda (attr)
			   (consp (assq attr rec))))
			attrs)))
		rec)))
	 records)))
621

Gerd Moellmann's avatar
Gerd Moellmann committed
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637
(defun eudc-add-field-to-records (field records)
  "Add FIELD to each individual record in RECORDS and return the resulting list."
  (mapcar (function
	   (lambda (r)
	     (cons field r)))
	  records))

(defun eudc-distribute-field-on-records (field records)
  "Duplicate each individual record in RECORDS according to value of FIELD.
Each copy is added a new field containing one of the values of FIELD."
  (let (result
	(values (cdr field)))
    ;; Uniquify values first
    (while values
      (setcdr values (delete (car values) (cdr values)))
      (setq values (cdr values)))
Glenn Morris's avatar
Glenn Morris committed
638
    (mapc
Gerd Moellmann's avatar
Gerd Moellmann committed
639 640 641
     (function
      (lambda (value)
	(let ((result-list (copy-sequence records)))
642
	  (setq result-list (eudc-add-field-to-records
Gerd Moellmann's avatar
Gerd Moellmann committed
643 644 645 646 647 648 649 650
			     (cons (car field) value)
			     result-list))
	  (setq result (append result-list result))
		 )))
	    (cdr field))
    result))


651
(define-derived-mode eudc-mode special-mode "EUDC"
Gerd Moellmann's avatar
Gerd Moellmann committed
652 653 654 655 656 657 658 659 660 661
  "Major mode used in buffers displaying the results of directory queries.
There is no sense in calling this command from a buffer other than
one containing the results of a directory query.

These are the special commands of EUDC mode:
    q -- Kill this buffer.
    f -- Display a form to query the current directory server.
    n -- Move to next record.
    p -- Move to previous record.
    b -- Insert record at point into the BBDB database."
662
  (if (not (featurep 'xemacs))
Gerd Moellmann's avatar
Gerd Moellmann committed
663
      (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))
664
    (setq mode-popup-menu (eudc-menu))))
Gerd Moellmann's avatar
Gerd Moellmann committed
665

666
;;}}}
Gerd Moellmann's avatar
Gerd Moellmann committed
667 668 669 670 671 672 673 674 675 676 677

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

(defun eudc-customize ()
  "Customize the EUDC package."
  (interactive)
  (customize-group 'eudc))

;;;###autoload
(defun eudc-set-server (server protocol &optional no-save)
  "Set the directory server to SERVER using PROTOCOL.
678
Unless NO-SAVE is non-nil, the server is saved as the default
Gerd Moellmann's avatar
Gerd Moellmann committed
679 680 681
server for future sessions."
  (interactive (list
		(read-from-minibuffer "Directory Server: ")
682
		(intern (completing-read "Protocol: "
683
					 (mapcar (lambda (elt)
Gerd Moellmann's avatar
Gerd Moellmann committed
684 685 686
						    (cons (symbol-name elt)
							  elt))
						 eudc-known-protocols)))))
687 688
  (unless (or (null protocol)
	      (member protocol
Gerd Moellmann's avatar
Gerd Moellmann committed
689 690 691 692 693 694 695 696
		      eudc-supported-protocols)
	      (load (concat "eudcb-" (symbol-name protocol)) t))
    (error "Unsupported protocol: %s" protocol))
  (run-hooks 'eudc-switch-from-server-hook)
  (setq eudc-protocol protocol)
  (setq eudc-server server)
  (eudc-update-local-variables)
  (run-hooks 'eudc-switch-to-server-hook)
697
  (if (called-interactively-p 'interactive)
Gerd Moellmann's avatar
Gerd Moellmann committed
698 699 700 701 702
      (message "Current directory server is now %s (%s)" eudc-server eudc-protocol))
  (if (null no-save)
      (eudc-save-options)))

;;;###autoload
703 704 705 706
(defun eudc-get-email (name &optional error)
  "Get the email field of NAME from the directory server.
If ERROR is non-nil, report an error if there is none."
  (interactive "sName: \np")
Gerd Moellmann's avatar
Gerd Moellmann committed
707 708 709 710
  (or eudc-server
      (call-interactively 'eudc-set-server))
  (let ((result (eudc-query (list (cons 'name name)) '(email)))
	email)
711
    (if (null (cdr result))
Gerd Moellmann's avatar
Gerd Moellmann committed
712
	(setq email (eudc-cdaar result))
713 714
      (error "Multiple match--use the query form"))
    (if error
Gerd Moellmann's avatar
Gerd Moellmann committed
715 716 717 718 719 720
	(if email
	    (message "%s" email)
	  (error "No record matching %s" name)))
    email))

;;;###autoload
721 722 723 724
(defun eudc-get-phone (name &optional error)
  "Get the phone field of NAME from the directory server.
If ERROR is non-nil, report an error if there is none."
  (interactive "sName: \np")
Gerd Moellmann's avatar
Gerd Moellmann committed
725 726 727 728
  (or eudc-server
      (call-interactively 'eudc-set-server))
  (let ((result (eudc-query (list (cons 'name name)) '(phone)))
	phone)
729
    (if (null (cdr result))
Gerd Moellmann's avatar
Gerd Moellmann committed
730
	(setq phone (eudc-cdaar result))
731 732
      (error "Multiple match--use the query form"))
    (if error
Gerd Moellmann's avatar
Gerd Moellmann committed
733 734 735 736 737 738 739 740 741 742 743
	(if phone
	    (message "%s" phone)
	  (error "No record matching %s" name)))
    phone))

(defun eudc-get-attribute-list ()
  "Return a list of valid attributes for the current server.
When called interactively the list is formatted in a dedicated buffer
otherwise a list of symbols is returned."
  (interactive)
  (if eudc-list-attributes-function
744 745
      (let ((entries (funcall eudc-list-attributes-function
			      (called-interactively-p 'interactive))))
746
	(if entries
747
	    (if (called-interactively-p 'interactive)
Gerd Moellmann's avatar
Gerd Moellmann committed
748 749 750 751 752 753 754 755 756 757 758 759
		(eudc-display-records entries t)
	      entries)))
    (error "The %s protocol has no support for listing attributes" eudc-protocol)))

(defun eudc-format-query (words format)
  "Use FORMAT to build a EUDC query from WORDS."
  (let (query
	query-alist
	key val cell)
    (if format
	(progn
	  (while (and words format)
760
	    (setq query-alist (cons (cons (car format) (car words))
Gerd Moellmann's avatar
Gerd Moellmann committed
761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784
				    query-alist))
	    (setq words (cdr words)
		  format (cdr format)))
	  ;; If the same attribute appears more than once, merge
	  ;; the corresponding values
	  (while query-alist
	    (setq key (eudc-caar query-alist)
		  val (eudc-cdar query-alist)
		  cell (assq key query))
	    (if cell
		(setcdr cell (concat (cdr cell) " " val))
	      (setq query (cons (car query-alist) query)))
	    (setq query-alist (cdr query-alist)))
	  query)
      (if eudc-protocol-has-default-query-attributes
	  (mapconcat 'identity words " ")
	(list (cons 'name (mapconcat 'identity words " ")))))))

(defun eudc-extract-n-word-formats (format-list n)
  "Extract a list of N-long formats from FORMAT-LIST.
If none try N - 1 and so forth."
  (let (formats)
    (while (and (null formats)
		(> n 0))
Juanma Barranquero's avatar
Juanma Barranquero committed
785
      (setq formats
Gerd Moellmann's avatar
Gerd Moellmann committed
786
	    (delq nil
787
		  (mapcar (lambda (format)
Gerd Moellmann's avatar
Gerd Moellmann committed
788 789 790 791 792 793 794 795 796 797 798 799 800
			     (if (= n
				    (length format))
				 format
			       nil))
			  format-list)))
      (setq n (1- n)))
    formats))


;;;###autoload
(defun eudc-expand-inline (&optional replace)
  "Query the directory server, and expand the query string before point.
The query string consists of the buffer substring from the point back to
801 802
the preceding comma, colon or beginning of line.
The variable `eudc-inline-query-format' controls how to associate the
Gerd Moellmann's avatar
Gerd Moellmann committed
803
individual inline query words with directory attribute names.
804
After querying the server for the given string, the expansion specified by
Gerd Moellmann's avatar
Gerd Moellmann committed
805
`eudc-inline-expansion-format' is inserted in the buffer at point.
806 807
If REPLACE is non-nil, then this expansion replaces the name in the buffer.
`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE.
808
Multiple servers can be tried with the same query until one finds a match,
Gerd Moellmann's avatar
Gerd Moellmann committed
809 810
see `eudc-inline-expansion-servers'"
  (interactive)
811 812 813 814 815 816 817 818 819 820
  (cond
   ((eq eudc-inline-expansion-servers 'current-server)
    (or eudc-server
	(call-interactively 'eudc-set-server)))
   ((eq eudc-inline-expansion-servers 'server-then-hotlist)
    (or eudc-server
	;; Allow server to be nil if hotlist is set.
	eudc-server-hotlist
	(call-interactively 'eudc-set-server)))
   ((eq eudc-inline-expansion-servers 'hotlist)
Gerd Moellmann's avatar
Gerd Moellmann committed
821 822
    (or eudc-server-hotlist
	(error "No server in the hotlist")))
823 824 825
   (t
    (error "Wrong value for `eudc-inline-expansion-servers': %S"
	   eudc-inline-expansion-servers)))
Gerd Moellmann's avatar
Gerd Moellmann committed
826 827
  (let* ((end (point))
	 (beg (save-excursion
828
		(if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
829
					(point-at-bol) 'move)
Gerd Moellmann's avatar
Gerd Moellmann committed
830 831
		    (goto-char (match-end 0)))
		(point)))
832 833
	 (query-words (split-string (buffer-substring-no-properties beg end)
				    "[ \t]+"))
Gerd Moellmann's avatar
Gerd Moellmann committed
834 835 836 837 838 839 840 841 842 843 844
	 query-formats
	 response
	 response-string
	 response-strings
	 (eudc-former-server eudc-server)
	 (eudc-former-protocol eudc-protocol)
	 servers)

    ;; Prepare the list of servers to query
    (setq servers (copy-sequence eudc-server-hotlist))
    (setq servers
845
	  (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
846 847 848
	   ((eq eudc-inline-expansion-servers 'hotlist)
	    eudc-server-hotlist)
	   ((eq eudc-inline-expansion-servers 'server-then-hotlist)
849 850 851 852
	    (if eudc-server
		(cons (cons eudc-server eudc-protocol)
		      (delete (cons eudc-server eudc-protocol) servers))
	      eudc-server-hotlist))
Gerd Moellmann's avatar
Gerd Moellmann committed
853
	   ((eq eudc-inline-expansion-servers 'current-server)
854
	    (list (cons eudc-server eudc-protocol)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
855 856 857 858
    (if (and eudc-max-servers-to-query
	     (> (length servers) eudc-max-servers-to-query))
	(setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil))

859
    (unwind-protect
Gerd Moellmann's avatar
Gerd Moellmann committed
860
	(progn
861
	  (setq response
Gerd Moellmann's avatar
Gerd Moellmann committed
862 863 864 865
		(catch 'found
		  ;; Loop on the servers
		  (while servers
		    (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
866

Gerd Moellmann's avatar
Gerd Moellmann committed
867 868
		    ;; Determine which formats apply in the query-format list
		    (setq query-formats
869
			  (or
Gerd Moellmann's avatar
Gerd Moellmann committed
870 871 872 873
			   (eudc-extract-n-word-formats eudc-inline-query-format
							(length query-words))
			   (if (null eudc-protocol-has-default-query-attributes)
			       '(name))))
874

Gerd Moellmann's avatar
Gerd Moellmann committed
875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891
		    ;; Loop on query-formats
		    (while query-formats
		      (setq response
			    (eudc-query
			     (eudc-format-query query-words (car query-formats))
			     (eudc-translate-attribute-list
			      (cdr eudc-inline-expansion-format))))
		      (if response
			  (throw 'found response))
		      (setq query-formats (cdr query-formats)))
		    (setq servers (cdr servers)))
		  ;; No more servers to try... no match found
		  nil))


	  (if (null response)
	      (error "No match")
892

Gerd Moellmann's avatar
Gerd Moellmann committed
893 894
	    ;; Process response through eudc-inline-expansion-format
	    (while response
895 896 897 898 899 900 901 902 903
	      (setq response-string
                    (apply 'format
                           (car eudc-inline-expansion-format)
                           (mapcar (function
                                    (lambda (field)
                                      (or (cdr (assq field (car response)))
                                          "")))
                                   (eudc-translate-attribute-list
                                    (cdr eudc-inline-expansion-format)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
904 905 906 907
	      (if (> (length response-string) 0)
		  (setq response-strings
			(cons response-string response-strings)))
	      (setq response (cdr response)))
908

Gerd Moellmann's avatar
Gerd Moellmann committed
909 910 911
	    (if (or
		 (and replace (not eudc-expansion-overwrites-query))
		 (and (not replace) eudc-expansion-overwrites-query))
912
		(kill-ring-save beg end))
913
	    (cond
Gerd Moellmann's avatar
Gerd Moellmann committed
914 915 916
	     ((or (= (length response-strings) 1)
		  (null eudc-multiple-match-handling-method)
		  (eq eudc-multiple-match-handling-method 'first))
917
	      (delete-region beg end)
Gerd Moellmann's avatar
Gerd Moellmann committed
918 919
	      (insert (car response-strings)))
	     ((eq eudc-multiple-match-handling-method 'select)
920
	      (eudc-select response-strings beg end))
Gerd Moellmann's avatar
Gerd Moellmann committed
921
	     ((eq eudc-multiple-match-handling-method 'all)
922
	      (delete-region beg end)
Gerd Moellmann's avatar
Gerd Moellmann committed
923 924
	      (insert (mapconcat 'identity response-strings ", ")))
	     ((eq eudc-multiple-match-handling-method 'abort)
925
	      (error "There is more than one match for the query")))))
926 927 928
      (or (and (equal eudc-server eudc-former-server)
	       (equal eudc-protocol eudc-former-protocol))
	  (eudc-set-server eudc-former-server eudc-former-protocol t)))))
929

Gerd Moellmann's avatar
Gerd Moellmann committed
930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952
;;;###autoload
(defun eudc-query-form (&optional get-fields-from-server)
  "Display a form to query the directory server.
If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first
queries the server for the existing fields and displays a corresponding form."
  (interactive "P")
  (let ((fields (or (and get-fields-from-server
			 (eudc-get-attribute-list))
		    eudc-query-form-attributes))
	(buffer (get-buffer-create "*Directory Query Form*"))
	prompts
	widget
	(width 0)
	inhibit-read-only
	pt)
    (switch-to-buffer buffer)
    (setq inhibit-read-only t)
    (erase-buffer)
    (kill-all-local-variables)
    (make-local-variable 'eudc-form-widget-list)
    (widget-insert "Directory Query Form\n")
    (widget-insert "====================\n\n")
    (widget-insert "Current server is: " (or eudc-server
953
					     (progn
Gerd Moellmann's avatar
Gerd Moellmann committed
954 955 956 957 958 959 960 961 962 963 964 965 966 967
					       (call-interactively 'eudc-set-server)
					       eudc-server))
					     "\n")
    (widget-insert "Protocol         : " (symbol-name eudc-protocol) "\n")
    ;; Build the list of prompts
    (setq prompts (if eudc-use-raw-directory-names
		      (mapcar 'symbol-name (eudc-translate-attribute-list fields))
		    (mapcar (function
			     (lambda (field)
			       (or (and (assq field eudc-user-attribute-names-alist)
					(cdr (assq field eudc-user-attribute-names-alist)))
				   (capitalize (symbol-name field)))))
			    fields)))
    ;; Loop over prompt strings to find the longest one
Glenn Morris's avatar
Glenn Morris committed
968 969 970 971 972
    (mapc (function
	   (lambda (prompt)
	     (if (> (length prompt) width)
		 (setq width (length prompt)))))
	  prompts)
973 974
    ;; Insert the first widget out of the mapcar to leave the cursor
    ;; in the first field
Gerd Moellmann's avatar
Gerd Moellmann committed
975 976 977 978 979 980 981
    (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
    (setq pt (point))
    (setq widget (widget-create 'editable-field :size 15))
    (setq eudc-form-widget-list (cons (cons (car fields) widget)
				      eudc-form-widget-list))
    (setq fields (cdr fields))
    (setq prompts (cdr prompts))
Glenn Morris's avatar
Glenn Morris committed
982 983 984 985 986 987 988 989 990
    (mapc (function
	   (lambda (field)
	     (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
	     (setq widget (widget-create 'editable-field
					 :size 15))
	     (setq eudc-form-widget-list (cons (cons field widget)
					       eudc-form-widget-list))
	     (setq prompts (cdr prompts))))
	  fields)
Gerd Moellmann's avatar
Gerd Moellmann committed
991 992
    (widget-insert "\n\n")
    (widget-create 'push-button
Daniel Hackney's avatar
Daniel Hackney committed
993
		   :notify (lambda (&rest _ignore)
Gerd Moellmann's avatar
Gerd Moellmann committed
994 995 996 997
			     (eudc-process-form))
		   "Query Server")
    (widget-insert " ")
    (widget-create 'push-button
Daniel Hackney's avatar
Daniel Hackney committed
998
		   :notify (lambda (&rest _ignore)
Gerd Moellmann's avatar
Gerd Moellmann committed
999 1000 1001 1002
			     (eudc-query-form))
		   "Reset Form")
    (widget-insert " ")
    (widget-create 'push-button
Daniel Hackney's avatar
Daniel Hackney committed
1003
		   :notify (lambda (&rest _ignore)
Gerd Moellmann's avatar
Gerd Moellmann committed
1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027
			     (kill-this-buffer))
		   "Quit")
    (goto-char pt)
    (use-local-map widget-keymap)
    (widget-setup))
  )

(defun eudc-bookmark-server (server protocol)
  "Add SERVER using PROTOCOL to the EUDC `servers' hotlist."
  (interactive "sDirectory server: \nsProtocol: ")
  (if (member (cons server protocol) eudc-server-hotlist)
      (error "%s:%s is already in the hotlist" protocol server)
    (setq eudc-server-hotlist (cons (cons server protocol) eudc-server-hotlist))
    (eudc-install-menu)
    (eudc-save-options)))

(defun eudc-bookmark-current-server ()
  "Add current server to the EUDC `servers' hotlist."
  (interactive)
  (eudc-bookmark-server eudc-server eudc-protocol))

(defun eudc-save-options ()
  "Save options to `eudc-options-file'."
  (interactive)
1028
  (with-current-buffer (find-file-noselect eudc-options-file t)
Gerd Moellmann's avatar
Gerd Moellmann committed
1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081
    (goto-char (point-min))
    ;; delete the previous setq
    (let ((standard-output (current-buffer))
	  provide-p
	  set-hotlist-p
	  set-server-p)
      (catch 'found
	(while t
	  (let ((sexp (condition-case nil
			  (read (current-buffer))
			(end-of-file (throw 'found nil)))))
	    (if (listp sexp)
		(cond
		 ((eq (car sexp)  'eudc-set-server)
		  (delete-region (save-excursion
				   (backward-sexp)
				   (point))
				 (point))
		  (setq set-server-p t))
		 ((and (eq (car sexp)  'setq)
		       (eq (eudc-cadr sexp) 'eudc-server-hotlist))
		  (delete-region (save-excursion
				   (backward-sexp)
				   (point))
				 (point))
		  (setq set-hotlist-p t))
		 ((and (eq (car sexp)  'provide)
		       (equal (eudc-cadr sexp) '(quote eudc-options-file)))
		  (setq provide-p t)))
	      (if (and provide-p
		       set-hotlist-p
		       set-server-p)
		  (throw 'found t))))))
      (if (eq (point-min) (point-max))
	  (princ ";; This file was automatically generated by eudc.el.\n\n"))
      (or provide-p
	  (princ "(provide 'eudc-options-file)\n"))
      (or (bolp)
	  (princ "\n"))
      (delete-blank-lines)
      (princ "(eudc-set-server ")
      (prin1 eudc-server)
      (princ " '")
      (prin1 eudc-protocol)
      (princ " t)\n")
      (princ "(setq eudc-server-hotlist '")
      (prin1 eudc-server-hotlist)
      (princ ")\n")
      (save-buffer))))

(defun eudc-move-to-next-record ()
  "Move to next record, in a buffer displaying directory query results."
  (interactive)
1082
  (if (not (derived-mode-p 'eudc-mode))
Gerd Moellmann's avatar
Gerd Moellmann committed
1083 1084 1085 1086 1087 1088 1089 1090 1091
      (error "Not in a EUDC buffer")
    (let ((pt (next-overlay-change (point))))
      (if (< pt (point-max))
	  (goto-char (1+ pt))
	(error "No more records after point")))))

(defun eudc-move-to-previous-record ()
  "Move to previous record, in a buffer displaying directory query results."
  (interactive)
1092
  (if (not (derived-mode-p 'eudc-mode))
Gerd Moellmann's avatar
Gerd Moellmann committed
1093 1094 1095 1096 1097 1098 1099 1100
      (error "Not in a EUDC buffer")
    (let ((pt (previous-overlay-change (point))))
      (if (> pt (point-min))
	  (goto-char pt)
	(error "No more records before point")))))

;;}}}

Juanma Barranquero's avatar
Juanma Barranquero committed
1101
;;{{{      Menus and keymaps
Gerd Moellmann's avatar
Gerd Moellmann committed
1102 1103 1104 1105 1106

(require 'easymenu)

(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))

1107
(defconst eudc-tail-menu
Gerd Moellmann's avatar
Gerd Moellmann committed
1108
  `(["---" nil nil]
1109 1110 1111 1112
    ["Query with Form" eudc-query-form
     :help "Display a form to query the directory server"]
    ["Expand Inline Query" eudc-expand-inline
     :help "Query the directory server, and expand the query string before point"]
1113
    ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
Gerd Moellmann's avatar
Gerd Moellmann committed
1114 1115 1116
     (and (or (featurep 'bbdb)
	      (prog1 (locate-library "bbdb") (message "")))
	  (overlays-at (point))
1117 1118
	  (overlay-get (car (overlays-at (point))) 'eudc-record))
     :help "Insert record at point into the BBDB database"]
1119
    ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
1120
     (and (derived-mode-p 'eudc-mode)
Gerd Moellmann's avatar
Gerd Moellmann committed
1121
	  (or (featurep 'bbdb)
1122 1123
	      (prog1 (locate-library "bbdb") (message ""))))
     :help "Insert all the records returned by a directory query into BBDB"]
Gerd Moellmann's avatar
Gerd Moellmann committed
1124
    ["---" nil nil]
1125 1126 1127 1128 1129 1130
    ["Get Email" eudc-get-email
     :help "Get the email field of NAME from the directory server"]
    ["Get Phone" eudc-get-phone
     :help "Get the phone field of name from the directory server"]
    ["List Valid Attribute Names" eudc-get-attribute-list
     :help "Return a list of valid attributes for the current server"]
Gerd Moellmann's avatar
Gerd Moellmann committed
1131 1132 1133
    ["---" nil nil]
    ,(cons "Customize" eudc-custom-generated-menu)))

1134 1135

(defconst eudc-server-menu
Gerd Moellmann's avatar
Gerd Moellmann committed
1136
  '(["---" nil nil]
1137 1138 1139 1140 1141 1142
    ["Bookmark Current Server" eudc-bookmark-current-server
     :help "Add current server to the EUDC `servers' hotlist"]
    ["Edit Server List" eudc-edit-hotlist
     :help "Edit the hotlist of directory servers in a specialized buffer"]
    ["New Server" eudc-set-server
     :help "Set the directory server to SERVER using PROTOCOL"]))
Gerd Moellmann's avatar
Gerd Moellmann committed
1143 1144 1145 1146 1147

(defun eudc-menu ()
  (let (command)
    (append '("Directory Search")
	    (list
1148
	     (append
Gerd Moellmann's avatar
Gerd Moellmann committed
1149
	      '("Server")
1150 1151
	      (mapcar
	       (function
Gerd Moellmann's avatar
Gerd Moellmann committed
1152 1153 1154 1155
		(lambda (servspec)
		  (let* ((server (car servspec))
			 (protocol (cdr servspec))
			 (proto-name (symbol-name protocol)))
1156 1157 1158
		    (setq command (intern (concat "eudc-set-server-"
						  server
						  "-"
Gerd Moellmann's avatar
Gerd Moellmann committed
1159 1160
						  proto-name)))
		    (if (not (fboundp command))
1161
			(fset command
Gerd Moellmann's avatar
Gerd Moellmann committed
1162 1163 1164
			      `(lambda ()
				 (interactive)
				 (eudc-set-server ,server (quote ,protocol))
1165 1166
				 (message "Selected directory server is now %s (%s)"
					  ,server
Gerd Moellmann's avatar
Gerd Moellmann committed
1167 1168 1169 1170 1171 1172 1173 1174 1175 1176
					  ,proto-name))))
		    (vector (format "%s (%s)" server proto-name)
			    command
			    :style 'radio
			    :selected `(equal eudc-server ,server)))))
	       eudc-server-hotlist)
	      eudc-server-menu))
	    eudc-tail-menu)))

(defun eudc-install-menu ()
1177
  (cond
1178
   ((and (featurep 'xemacs) (featurep 'menubar))
Gerd Moellmann's avatar
Gerd Moellmann committed
1179
    (add-submenu '("Tools") (eudc-menu)))
1180
   ((not (featurep 'xemacs))
1181
    (cond
1182 1183 1184 1185 1186 1187
     ((fboundp 'easy-menu-create-menu)
      (define-key
	global-map
	[menu-bar tools directory-search]
	(cons "Directory Search"
	      (easy-menu-create-menu "Directory Search" (cdr (eudc-menu))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
1188 1189 1190 1191 1192 1193
     ((fboundp 'easy-menu-add-item)
      (let ((menu (eudc-menu)))
	(easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
								  (cdr menu)))))
     ((fboundp 'easy-menu-create-keymaps)
      (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu))
1194
      (define-key
Gerd Moellmann's avatar
Gerd Moellmann committed
1195
	global-map
1196
	[menu-bar tools eudc]
Gerd Moellmann's avatar
Gerd Moellmann committed
1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208
	(cons "Directory Search"
	      (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
     (t
      (error "Unknown version of easymenu"))))
   ))


;;; Load time initializations :

;;; Load the options file
(if (and (not noninteractive)
	 (and (locate-library eudc-options-file)
1209
	      (progn (message "") t))   ; Remove mode line message
Gerd Moellmann's avatar
Gerd Moellmann committed
1210 1211
	 (not (featurep 'eudc-options-file)))
    (load eudc-options-file))
1212

Gerd Moellmann's avatar
Gerd Moellmann committed
1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226
;;; Install the full menu
(unless (featurep 'infodock)
  (eudc-install-menu))


;;; The following installs a short menu for EUDC at XEmacs startup.

;;;###autoload
(defun eudc-load-eudc ()
  "Load the Emacs Unified Directory Client.
This does nothing except loading eudc by autoload side-effect."
  (interactive)
  nil)