code.delx.au - gnu-emacs/blob - lisp/net/eudc.el

   1 ;;; eudc.el --- Emacs Unified Directory Client
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   7 ;; Maintainer: Pavel Janík <Pavel@Janik.cz>
   8 ;; Keywords: comm
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28 ;;    This package provides a common interface to query directory servers using
  29 ;;    different protocols such as LDAP, CCSO PH/QI or BBDB.  Queries can be
  30 ;;    made through an interactive form or inline. Inline query strings in
  31 ;;    buffers are expanded with appropriately formatted query results
  32 ;;    (especially used to expand email addresses in message buffers).  EUDC
  33 ;;    also interfaces with the BBDB package to let you register query results
  34 ;;    into your own BBDB database.
  35
  36 ;;; Usage:
  37 ;;    EUDC comes with an extensive documentation, please refer to it.
  38 ;;
  39 ;;    The main entry points of EUDC are:
  40 ;;      `eudc-query-form': Query a directory server from a query form
  41 ;;      `eudc-expand-inline': Query a directory server for the e-mail address
  42 ;;                            of the name before cursor and insert it in the
  43 ;;                            buffer
  44 ;;      `eudc-get-phone': Get a phone number from a directory server
  45 ;;      `eudc-get-email': Get an e-mail address from a directory server
  46 ;;      `eudc-customize': Customize various aspects of EUDC
  47
  48 ;;; Code:
  49
  50 (require 'wid-edit)
  51
  52 (eval-and-compile
  53   (if (not (fboundp 'make-overlay))
  54       (require 'overlay))
  55   (if (not (fboundp 'unless))
  56       (require 'cl)))
  57
  58 (unless (fboundp 'custom-menu-create)
  59   (autoload 'custom-menu-create "cus-edit"))
  60
  61 (require 'eudc-vars)
  62
  63
  64
  65 ;;{{{      Internal cooking
  66
  67 ;;{{{      Internal variables and compatibility tricks
  68
  69 (defvar eudc-form-widget-list nil)
  70 (defvar eudc-mode-map nil)
  71
  72 (defvar mode-popup-menu)
  73
  74 ;; List of known servers
  75 ;; Alist of (SERVER . PROTOCOL)
  76 (defvar eudc-server-hotlist nil)
  77
  78 ;; List of variables that have server- or protocol-local bindings
  79 (defvar eudc-local-vars nil)
  80
  81 ;; Protocol local. Query function
  82 (defvar eudc-query-function nil)
  83
  84 ;; Protocol local.  A function that retrieves a list of valid attribute names
  85 (defvar eudc-list-attributes-function nil)
  86
  87 ;; Protocol local. A mapping between EUDC attribute names and corresponding
  88 ;; protocol specific names.  The following names are defined by EUDC and may be
  89 ;; included in that list: `name' , `firstname', `email', `phone'
  90 (defvar eudc-protocol-attributes-translation-alist nil)
  91
  92 ;; Protocol local. Mapping between protocol attribute names and BBDB field
  93 ;; names
  94 (defvar eudc-bbdb-conversion-alist nil)
  95
  96 ;; Protocol/Server local. Hook called upon switching to that server
  97 (defvar eudc-switch-to-server-hook nil)
  98
  99 ;; Protocol/Server local. Hook called upon switching from that server
 100 (defvar eudc-switch-from-server-hook nil)
 101
 102 ;; Protocol local. Whether the protocol supports queries with no specified
 103 ;; attribute name
 104 (defvar eudc-protocol-has-default-query-attributes nil)
 105
 106 (defun eudc-cadr (obj)
 107   (car (cdr obj)))
 108
 109 (defun eudc-cdar (obj)
 110   (cdr (car obj)))
 111
 112 (defun eudc-caar (obj)
 113   (car (car obj)))
 114
 115 (defun eudc-cdaar (obj)
 116   (cdr (car (car obj))))
 117
 118 (defun eudc-plist-member (plist prop)
 119   "Return t if PROP has a value specified in PLIST."
 120   (if (not (= 0 (% (length plist) 2)))
 121       (error "Malformed plist"))
 122   (catch 'found
 123     (while plist
 124       (if (eq prop (car plist))
 125           (throw 'found t))
 126       (setq plist (cdr (cdr plist))))
 127     nil))
 128
 129 ;; Emacs' plist-get lacks third parameter
 130 (defun eudc-plist-get (plist prop &optional default)
 131   "Extract a value from a property list.
 132 PLIST is a property list, which is a list of the form
 133 \(PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
 134 corresponding to the given PROP, or DEFAULT if PROP is not
 135 one of the properties on the list."
 136   (if (eudc-plist-member plist prop)
 137       (plist-get plist prop)
 138     default))
 139
 140 (defun eudc-lax-plist-get (plist prop &optional default)
 141   "Extract a value from a lax property list.
 142
 143 PLIST is a lax property list, which is a list of the form (PROP1
 144 VALUE1 PROP2 VALUE2...), where comparisons between properties are done
 145 using `equal' instead of `eq'.  This function returns the value
 146 corresponding to PROP, or DEFAULT if PROP is not one of the
 147 properties on the list."
 148   (if (not (= 0 (% (length plist) 2)))
 149       (error "Malformed plist"))
 150   (catch 'found
 151     (while plist
 152       (if (equal prop (car plist))
 153           (throw 'found (car (cdr plist))))
 154       (setq plist (cdr (cdr plist))))
 155     default))
 156
 157 (if (not (fboundp 'split-string))
 158     (defun split-string (string &optional pattern)
 159       "Return a list of substrings of STRING which are separated by PATTERN.
 160 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
 161   (or pattern
 162       (setq pattern "[ \f\t\n\r\v]+"))
 163   (let (parts (start 0))
 164     (when (string-match pattern string 0)
 165       (if (> (match-beginning 0) 0)
 166           (setq parts (cons (substring string 0 (match-beginning 0)) nil)))
 167       (setq start (match-end 0))
 168       (while (and (string-match pattern string start)
 169                   (> (match-end 0) start))
 170         (setq parts (cons (substring string start (match-beginning 0)) parts)
 171               start (match-end 0))))
 172     (nreverse (if (< start (length string))
 173                   (cons (substring string start) parts)
 174                 parts)))))
 175
 176 (defun eudc-replace-in-string (str regexp newtext)
 177   "Replace all matches in STR for REGEXP with NEWTEXT.
 178 Value is the new string."
 179   (let ((rtn-str "")
 180         (start 0)
 181         match prev-start)
 182     (while (setq match (string-match regexp str start))
 183       (setq prev-start start
 184             start (match-end 0)
 185             rtn-str
 186             (concat rtn-str
 187                     (substring str prev-start match)
 188                     newtext)))
 189     (concat rtn-str (substring str start))))
 190
 191 ;;}}}
 192
 193 ;;{{{ Server and Protocol Variable Routines
 194
 195 (defun eudc-server-local-variable-p (var)
 196   "Return non-nil if VAR has server-local bindings."
 197   (eudc-plist-member (get var 'eudc-locals) 'server))
 198
 199 (defun eudc-protocol-local-variable-p (var)
 200   "Return non-nil if VAR has protocol-local bindings."
 201   (eudc-plist-member (get var 'eudc-locals) 'protocol))
 202
 203 (defun eudc-default-set (var val)
 204   "Set the EUDC default value of VAR to VAL.
 205 The current binding of VAR is not changed."
 206   (put var 'eudc-locals
 207        (plist-put (get var 'eudc-locals) 'default val))
 208   (add-to-list 'eudc-local-vars var))
 209
 210 (defun eudc-protocol-set (var val &optional protocol)
 211   "Set the PROTOCOL-local binding of VAR to VAL.
 212 If omitted PROTOCOL defaults to the current value of `eudc-protocol'.
 213 The current binding of VAR is changed only if PROTOCOL is omitted."
 214   (if (eq 'unbound (eudc-variable-default-value var))
 215       (eudc-default-set var (symbol-value var)))
 216   (let* ((eudc-locals (get var 'eudc-locals))
 217          (protocol-locals (eudc-plist-get eudc-locals 'protocol)))
 218     (setq protocol-locals (plist-put protocol-locals (or protocol
 219                                                          eudc-protocol) val))
 220     (setq eudc-locals
 221           (plist-put eudc-locals 'protocol protocol-locals))
 222     (put var 'eudc-locals eudc-locals)
 223     (add-to-list 'eudc-local-vars var)
 224     (unless protocol
 225       (eudc-update-variable var))))
 226
 227 (defun eudc-server-set (var val &optional server)
 228   "Set the SERVER-local binding of VAR to VAL.
 229 If omitted SERVER defaults to the current value of `eudc-server'.
 230 The current binding of VAR is changed only if SERVER is omitted."
 231   (if (eq 'unbound (eudc-variable-default-value var))
 232       (eudc-default-set var (symbol-value var)))
 233   (let* ((eudc-locals (get var 'eudc-locals))
 234          (server-locals (eudc-plist-get eudc-locals 'server)))
 235     (setq server-locals (plist-put server-locals (or server
 236                                                      eudc-server) val))
 237     (setq eudc-locals
 238           (plist-put eudc-locals 'server server-locals))
 239     (put var 'eudc-locals eudc-locals)
 240     (add-to-list 'eudc-local-vars var)
 241     (unless server
 242       (eudc-update-variable var))))
 243
 244
 245 (defun eudc-set (var val)
 246   "Set the most local (server, protocol or default) binding of VAR to VAL.
 247 The current binding of VAR is also set to VAL"
 248   (cond
 249    ((not (eq 'unbound (eudc-variable-server-value var)))
 250     (eudc-server-set var val))
 251    ((not (eq 'unbound (eudc-variable-protocol-value var)))
 252     (eudc-protocol-set var val))
 253    (t
 254     (eudc-default-set var val)))
 255   (set var val))
 256
 257 (defun eudc-variable-default-value (var)
 258   "Return the default binding of VAR.
 259 Return `unbound' if VAR has no EUDC default value."
 260   (let ((eudc-locals (get var 'eudc-locals)))
 261     (if (and (boundp var)
 262              eudc-locals)
 263         (eudc-plist-get eudc-locals 'default 'unbound)
 264       'unbound)))
 265
 266 (defun eudc-variable-protocol-value (var &optional protocol)
 267   "Return the value of VAR local to PROTOCOL.
 268 Return `unbound' if VAR has no value local to PROTOCOL.
 269 PROTOCOL defaults to `eudc-protocol'"
 270   (let* ((eudc-locals (get var 'eudc-locals))
 271          protocol-locals)
 272     (if (not (and  (boundp var)
 273                    eudc-locals
 274                    (eudc-plist-member eudc-locals 'protocol)))
 275         'unbound
 276       (setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
 277       (eudc-lax-plist-get protocol-locals
 278                           (or protocol
 279                               eudc-protocol) 'unbound))))
 280
 281 (defun eudc-variable-server-value (var &optional server)
 282   "Return the value of VAR local to SERVER.
 283 Return `unbound' if VAR has no value local to SERVER.
 284 SERVER defaults to `eudc-server'"
 285   (let* ((eudc-locals (get var 'eudc-locals))
 286          server-locals)
 287     (if (not (and (boundp var)
 288                   eudc-locals
 289                   (eudc-plist-member eudc-locals 'server)))
 290         'unbound
 291       (setq server-locals (eudc-plist-get eudc-locals 'server))
 292       (eudc-lax-plist-get server-locals
 293                           (or server
 294                               eudc-server) 'unbound))))
 295
 296 (defun eudc-update-variable (var)
 297   "Set the value of VAR according to its locals.
 298 If the VAR has a server- or protocol-local value corresponding
 299 to the current `eudc-server' and `eudc-protocol' then it is set
 300 accordingly. Otherwise it is set to its EUDC default binding"
 301   (let (val)
 302     (cond
 303      ((not (eq 'unbound (setq val (eudc-variable-server-value var))))
 304       (set var val))
 305      ((not (eq 'unbound (setq val (eudc-variable-protocol-value var))))
 306       (set var val))
 307      ((not (eq 'unbound (setq val (eudc-variable-default-value var))))
 308       (set var val)))))
 309
 310 (defun eudc-update-local-variables ()
 311   "Update all EUDC variables according to their local settings."
 312   (interactive)
 313   (mapcar 'eudc-update-variable eudc-local-vars))
 314
 315 (eudc-default-set 'eudc-query-function nil)
 316 (eudc-default-set 'eudc-list-attributes-function nil)
 317 (eudc-default-set 'eudc-protocol-attributes-translation-alist nil)
 318 (eudc-default-set 'eudc-bbdb-conversion-alist nil)
 319 (eudc-default-set 'eudc-switch-to-server-hook nil)
 320 (eudc-default-set 'eudc-switch-from-server-hook nil)
 321 (eudc-default-set 'eudc-protocol-has-default-query-attributes nil)
 322 (eudc-default-set 'eudc-attribute-display-method-alist nil)
 323
 324 ;;}}}
 325
 326
 327 ;; Add PROTOCOL to the list of supported protocols
 328 (defun eudc-register-protocol (protocol)
 329   (unless (memq protocol eudc-supported-protocols)
 330     (setq eudc-supported-protocols
 331           (cons protocol eudc-supported-protocols))
 332     (put 'eudc-protocol 'custom-type
 333          `(choice :menu-tag "Protocol"
 334                   ,@(mapcar (lambda (s)
 335                               (list 'string ':tag (symbol-name s)))
 336                             eudc-supported-protocols))))
 337   (or (memq protocol eudc-known-protocols)
 338       (setq eudc-known-protocols
 339             (cons protocol eudc-known-protocols))))
 340
 341
 342 (defun eudc-translate-query (query)
 343   "Translate attribute names of QUERY.
 344 The translation is done according to
 345 `eudc-protocol-attributes-translation-alist'."
 346   (if eudc-protocol-attributes-translation-alist
 347       (mapcar '(lambda (attribute)
 348                  (let ((trans (assq (car attribute)
 349                                     (symbol-value eudc-protocol-attributes-translation-alist))))
 350                    (if trans
 351                        (cons (cdr trans) (cdr attribute))
 352                      attribute)))
 353               query)
 354     query))
 355
 356 (defun eudc-translate-attribute-list (list)
 357   "Translate a list of attribute names LIST.
 358 The translation is done according to
 359 `eudc-protocol-attributes-translation-alist'."
 360   (if eudc-protocol-attributes-translation-alist
 361       (let (trans)
 362         (mapcar '(lambda (attribute)
 363                    (setq trans (assq attribute
 364                                      (symbol-value eudc-protocol-attributes-translation-alist)))
 365                    (if trans
 366                        (cdr trans)
 367                      attribute))
 368                 list))
 369     list))
 370
 371 (defun eudc-select (choices beg end)
 372   "Choose one from CHOICES using a completion.
 373 BEG and END delimit the text which is to be replaced."
 374   (let ((replacement))
 375    (setq replacement
 376          (completing-read "Multiple matches found; choose one: "
 377                           (mapcar 'list choices)))
 378    (delete-region beg end)
 379    (insert replacement)))
 380
 381 (defun eudc-query (query &optional return-attributes no-translation)
 382    "Query the current directory server with QUERY.
 383 QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
 384 name and VALUE the corresponding value.
 385 If NO-TRANSLATION is non-nil, ATTR is translated according to
 386 `eudc-protocol-attributes-translation-alist'.
 387 RETURN-ATTRIBUTES is a list of attributes to return defaulting to
 388 `eudc-default-return-attributes'."
 389    (unless eudc-query-function
 390      (error "Don't know how to perform the query"))
 391    (if no-translation
 392        (funcall eudc-query-function query (or return-attributes
 393                                               eudc-default-return-attributes))
 394
 395      (funcall eudc-query-function
 396               (eudc-translate-query query)
 397               (cond
 398                (return-attributes
 399                 (eudc-translate-attribute-list return-attributes))
 400                ((listp eudc-default-return-attributes)
 401                 (eudc-translate-attribute-list eudc-default-return-attributes))
 402                (t
 403                 eudc-default-return-attributes)))))
 404
 405 (defun eudc-format-attribute-name-for-display (attribute)
 406   "Format a directory attribute name for display.
 407 ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
 408 by the corresponding user name if any.  Otherwise it is capitalized and
 409 underscore characters are replaced by spaces."
 410   (let ((match (assq attribute eudc-user-attribute-names-alist)))
 411     (if match
 412         (cdr match)
 413       (capitalize
 414        (mapconcat 'identity
 415                   (split-string (symbol-name attribute) "_")
 416                   " ")))))
 417
 418 (defun eudc-print-attribute-value (field)
 419   "Insert the value of the directory FIELD at point.
 420 The directory attribute name in car of FIELD is looked up in
 421 `eudc-attribute-display-method-alist' and the corresponding method,
 422 if any, is called to print the value in cdr of FIELD."
 423   (let ((match (assoc (downcase (car field))
 424                       eudc-attribute-display-method-alist))
 425         (col (current-column))
 426         (val (cdr field)))
 427     (if match
 428         (progn
 429           (eval (list (cdr match) val))
 430           (insert "\n"))
 431       (mapcar
 432        (function
 433         (lambda (val-elem)
 434           (indent-to col)
 435           (insert val-elem "\n")))
 436        (cond
 437         ((listp val) val)
 438         ((stringp val) (split-string val "\n"))
 439         ((null val) '(""))
 440         (t (list val)))))))
 441
 442 (defun eudc-print-record-field (field column-width)
 443   "Print the record field FIELD.
 444 FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
 445 COLUMN-WIDTH is the width of the first display column containing the
 446 attribute name ATTR."
 447   (let ((field-beg (point)))
 448 ;; The record field that is passed to this function has already been processed
 449 ;; by `eudc-format-attribute-name-for-display' so we don't need to call it
 450 ;; again to display the attribute name
 451     (insert (format (concat "%" (int-to-string column-width) "s: ")
 452                     (car field)))
 453     (put-text-property field-beg (point) 'face 'bold)
 454     (indent-to (+ 2 column-width))
 455     (eudc-print-attribute-value field)))
 456
 457 (defun eudc-display-records (records &optional raw-attr-names)
 458   "Display the record list RECORDS in a formatted buffer.
 459 If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
 460 otherwise they are formatted according to `eudc-user-attribute-names-alist'."
 461   (let (inhibit-read-only
 462         precords
 463         (width 0)
 464         beg
 465         first-record
 466         attribute-name)
 467     (with-output-to-temp-buffer "*Directory Query Results*"
 468       (with-current-buffer standard-output
 469         (setq buffer-read-only t)
 470         (setq inhibit-read-only t)
 471         (erase-buffer)
 472         (insert "Directory Query Result\n")
 473         (insert "======================\n\n\n")
 474         (if (null records)
 475             (insert "No match found.\n"
 476                     (if eudc-strict-return-matches
 477                         "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n"
 478                       ""))
 479           ;; Replace field names with user names, compute max width
 480           (setq precords
 481                 (mapcar
 482                  (function
 483                   (lambda (record)
 484                     (mapcar
 485                      (function
 486                       (lambda (field)
 487                         (setq attribute-name
 488                               (if raw-attr-names
 489                                   (symbol-name (car field))
 490                                 (eudc-format-attribute-name-for-display (car field))))
 491                         (if (> (length attribute-name) width)
 492                             (setq width (length attribute-name)))
 493                         (cons attribute-name (cdr field))))
 494                      record)))
 495                  records))
 496           ;; Display the records
 497           (setq first-record (point))
 498           (mapc
 499            (function
 500             (lambda (record)
 501               (setq beg (point))
 502               ;; Map over the record fields to print the attribute/value pairs
 503               (mapc (function
 504                      (lambda (field)
 505                        (eudc-print-record-field field width)))
 506                     record)
 507               ;; Store the record internal format in some convenient place
 508               (overlay-put (make-overlay beg (point))
 509                            'eudc-record
 510                            (car records))
 511               (setq records (cdr records))
 512               (insert "\n")))
 513            precords))
 514         (insert "\n")
 515         (widget-create 'push-button
 516                        :notify (lambda (&rest ignore)
 517                                  (eudc-query-form))
 518                        "New query")
 519         (widget-insert " ")
 520         (widget-create 'push-button
 521                        :notify (lambda (&rest ignore)
 522                                  (kill-this-buffer))
 523                        "Quit")
 524         (eudc-mode)
 525         (widget-setup)
 526         (if first-record
 527             (goto-char first-record))))))
 528
 529 (defun eudc-process-form ()
 530   "Process the query form in current buffer and display the results."
 531   (let (query-alist
 532         value)
 533     (if (not (and (boundp 'eudc-form-widget-list)
 534                   eudc-form-widget-list))
 535         (error "Not in a directory query form buffer")
 536       (mapc (function
 537              (lambda (wid-field)
 538                (setq value (widget-value (cdr wid-field)))
 539                (if (not (string= value ""))
 540                    (setq query-alist (cons (cons (car wid-field) value)
 541                                            query-alist)))))
 542             eudc-form-widget-list)
 543       (kill-buffer (current-buffer))
 544       (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names))))
 545
 546
 547 (defun eudc-filter-duplicate-attributes (record)
 548   "Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
 549   (let ((rec record)
 550         unique
 551         duplicates
 552         result)
 553
 554     ;; Search for multiple records
 555     (while (and rec
 556                 (not (listp (eudc-cdar rec))))
 557       (setq rec (cdr rec)))
 558
 559     (if (null (eudc-cdar rec))
 560         (list record)                   ; No duplicate attrs in this record
 561       (mapc (function
 562              (lambda (field)
 563                (if (listp (cdr field))
 564                    (setq duplicates (cons field duplicates))
 565                  (setq unique (cons field unique)))))
 566             record)
 567       (setq result (list unique))
 568       ;; Map over the record fields that have multiple values
 569       (mapc
 570        (function
 571         (lambda (field)
 572           (let ((method (if (consp eudc-duplicate-attribute-handling-method)
 573                             (cdr
 574                              (assq
 575                               (or
 576                                (car
 577                                 (rassq
 578                                  (car field)
 579                                  (symbol-value
 580                                   eudc-protocol-attributes-translation-alist)))
 581                                (car field))
 582                               eudc-duplicate-attribute-handling-method))
 583                           eudc-duplicate-attribute-handling-method)))
 584             (cond
 585              ((or (null method) (eq 'list method))
 586               (setq result
 587                     (eudc-add-field-to-records field result)))
 588              ((eq 'first method)
 589               (setq result
 590                     (eudc-add-field-to-records (cons (car field)
 591                                                      (eudc-cadr field))
 592                                                result)))
 593              ((eq 'concat method)
 594               (setq result
 595                     (eudc-add-field-to-records (cons (car field)
 596                                                      (mapconcat
 597                                                       'identity
 598                                                       (cdr field)
 599                                                       "\n")) result)))
 600              ((eq 'duplicate method)
 601               (setq result
 602                     (eudc-distribute-field-on-records field result)))))))
 603        duplicates)
 604       result)))
 605
 606 (defun eudc-filter-partial-records (records attrs)
 607   "Eliminate records that do not contain all ATTRS from RECORDS."
 608   (delq nil
 609         (mapcar
 610          (function
 611           (lambda (rec)
 612             (if (eval (cons 'and
 613                        (mapcar
 614                         (function
 615                          (lambda (attr)
 616                            (consp (assq attr rec))))
 617                         attrs)))
 618                 rec)))
 619          records)))
 620
 621 (defun eudc-add-field-to-records (field records)
 622   "Add FIELD to each individual record in RECORDS and return the resulting list."
 623   (mapcar (function
 624            (lambda (r)
 625              (cons field r)))
 626           records))
 627
 628 (defun eudc-distribute-field-on-records (field records)
 629   "Duplicate each individual record in RECORDS according to value of FIELD.
 630 Each copy is added a new field containing one of the values of FIELD."
 631   (let (result
 632         (values (cdr field)))
 633     ;; Uniquify values first
 634     (while values
 635       (setcdr values (delete (car values) (cdr values)))
 636       (setq values (cdr values)))
 637     (mapc
 638      (function
 639       (lambda (value)
 640         (let ((result-list (copy-sequence records)))
 641           (setq result-list (eudc-add-field-to-records
 642                              (cons (car field) value)
 643                              result-list))
 644           (setq result (append result-list result))
 645                  )))
 646             (cdr field))
 647     result))
 648
 649
 650 (defun eudc-mode ()
 651   "Major mode used in buffers displaying the results of directory queries.
 652 There is no sense in calling this command from a buffer other than
 653 one containing the results of a directory query.
 654
 655 These are the special commands of EUDC mode:
 656     q -- Kill this buffer.
 657     f -- Display a form to query the current directory server.
 658     n -- Move to next record.
 659     p -- Move to previous record.
 660     b -- Insert record at point into the BBDB database."
 661   (interactive)
 662   (kill-all-local-variables)
 663   (setq major-mode 'eudc-mode)
 664   (setq mode-name "EUDC")
 665   (use-local-map eudc-mode-map)
 666   (if (not (featurep 'xemacs))
 667       (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))
 668     (setq mode-popup-menu (eudc-menu)))
 669   (run-mode-hooks 'eudc-mode-hook))
 670
 671 ;;}}}
 672
 673 ;;{{{      High-level interfaces (interactive functions)
 674
 675 (defun eudc-customize ()
 676   "Customize the EUDC package."
 677   (interactive)
 678   (customize-group 'eudc))
 679
 680 ;;;###autoload
 681 (defun eudc-set-server (server protocol &optional no-save)
 682   "Set the directory server to SERVER using PROTOCOL.
 683 Unless NO-SAVE is non-nil, the server is saved as the default
 684 server for future sessions."
 685   (interactive (list
 686                 (read-from-minibuffer "Directory Server: ")
 687                 (intern (completing-read "Protocol: "
 688                                          (mapcar '(lambda (elt)
 689                                                     (cons (symbol-name elt)
 690                                                           elt))
 691                                                  eudc-known-protocols)))))
 692   (unless (or (member protocol
 693                       eudc-supported-protocols)
 694               (load (concat "eudcb-" (symbol-name protocol)) t))
 695     (error "Unsupported protocol: %s" protocol))
 696   (run-hooks 'eudc-switch-from-server-hook)
 697   (setq eudc-protocol protocol)
 698   (setq eudc-server server)
 699   (eudc-update-local-variables)
 700   (run-hooks 'eudc-switch-to-server-hook)
 701   (if (interactive-p)
 702       (message "Current directory server is now %s (%s)" eudc-server eudc-protocol))
 703   (if (null no-save)
 704       (eudc-save-options)))
 705
 706 ;;;###autoload
 707 (defun eudc-get-email (name &optional error)
 708   "Get the email field of NAME from the directory server.
 709 If ERROR is non-nil, report an error if there is none."
 710   (interactive "sName: \np")
 711   (or eudc-server
 712       (call-interactively 'eudc-set-server))
 713   (let ((result (eudc-query (list (cons 'name name)) '(email)))
 714         email)
 715     (if (null (cdr result))
 716         (setq email (eudc-cdaar result))
 717       (error "Multiple match--use the query form"))
 718     (if error
 719         (if email
 720             (message "%s" email)
 721           (error "No record matching %s" name)))
 722     email))
 723
 724 ;;;###autoload
 725 (defun eudc-get-phone (name &optional error)
 726   "Get the phone field of NAME from the directory server.
 727 If ERROR is non-nil, report an error if there is none."
 728   (interactive "sName: \np")
 729   (or eudc-server
 730       (call-interactively 'eudc-set-server))
 731   (let ((result (eudc-query (list (cons 'name name)) '(phone)))
 732         phone)
 733     (if (null (cdr result))
 734         (setq phone (eudc-cdaar result))
 735       (error "Multiple match--use the query form"))
 736     (if error
 737         (if phone
 738             (message "%s" phone)
 739           (error "No record matching %s" name)))
 740     phone))
 741
 742 (defun eudc-get-attribute-list ()
 743   "Return a list of valid attributes for the current server.
 744 When called interactively the list is formatted in a dedicated buffer
 745 otherwise a list of symbols is returned."
 746   (interactive)
 747   (if eudc-list-attributes-function
 748       (let ((entries (funcall eudc-list-attributes-function (interactive-p))))
 749         (if entries
 750             (if (interactive-p)
 751                 (eudc-display-records entries t)
 752               entries)))
 753     (error "The %s protocol has no support for listing attributes" eudc-protocol)))
 754
 755 (defun eudc-format-query (words format)
 756   "Use FORMAT to build a EUDC query from WORDS."
 757   (let (query
 758         query-alist
 759         key val cell)
 760     (if format
 761         (progn
 762           (while (and words format)
 763             (setq query-alist (cons (cons (car format) (car words))
 764                                     query-alist))
 765             (setq words (cdr words)
 766                   format (cdr format)))
 767           ;; If the same attribute appears more than once, merge
 768           ;; the corresponding values
 769           (setq query-alist (nreverse query-alist))
 770           (while query-alist
 771             (setq key (eudc-caar query-alist)
 772                   val (eudc-cdar query-alist)
 773                   cell (assq key query))
 774             (if cell
 775                 (setcdr cell (concat (cdr cell) " " val))
 776               (setq query (cons (car query-alist) query)))
 777             (setq query-alist (cdr query-alist)))
 778           query)
 779       (if eudc-protocol-has-default-query-attributes
 780           (mapconcat 'identity words " ")
 781         (list (cons 'name (mapconcat 'identity words " ")))))))
 782
 783 (defun eudc-extract-n-word-formats (format-list n)
 784   "Extract a list of N-long formats from FORMAT-LIST.
 785 If none try N - 1 and so forth."
 786   (let (formats)
 787     (while (and (null formats)
 788                 (> n 0))
 789       (setq formats
 790             (delq nil
 791                   (mapcar '(lambda (format)
 792                              (if (= n
 793                                     (length format))
 794                                  format
 795                                nil))
 796                           format-list)))
 797       (setq n (1- n)))
 798     formats))
 799
 800
 801 ;;;###autoload
 802 (defun eudc-expand-inline (&optional replace)
 803   "Query the directory server, and expand the query string before point.
 804 The query string consists of the buffer substring from the point back to
 805 the preceding comma, colon or beginning of line.
 806 The variable `eudc-inline-query-format' controls how to associate the
 807 individual inline query words with directory attribute names.
 808 After querying the server for the given string, the expansion specified by
 809 `eudc-inline-expansion-format' is inserted in the buffer at point.
 810 If REPLACE is non-nil, then this expansion replaces the name in the buffer.
 811 `eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE.
 812 Multiple servers can be tried with the same query until one finds a match,
 813 see `eudc-inline-expansion-servers'"
 814   (interactive)
 815   (if (memq eudc-inline-expansion-servers
 816             '(current-server server-then-hotlist))
 817       (or eudc-server
 818           (call-interactively 'eudc-set-server))
 819     (or eudc-server-hotlist
 820         (error "No server in the hotlist")))
 821   (let* ((end (point))
 822          (beg (save-excursion
 823                 (if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
 824                                         (save-excursion
 825                                           (beginning-of-line)
 826                                           (point))
 827                                         'move)
 828                     (goto-char (match-end 0)))
 829                 (point)))
 830          (query-words (split-string (buffer-substring beg end) "[ \t]+"))
 831          query-formats
 832          response
 833          response-string
 834          response-strings
 835          (eudc-former-server eudc-server)
 836          (eudc-former-protocol eudc-protocol)
 837          servers)
 838
 839     ;; Prepare the list of servers to query
 840     (setq servers (copy-sequence eudc-server-hotlist))
 841     (setq servers
 842           (cond
 843            ((eq eudc-inline-expansion-servers 'hotlist)
 844             eudc-server-hotlist)
 845            ((eq eudc-inline-expansion-servers 'server-then-hotlist)
 846             (cons (cons eudc-server eudc-protocol)
 847                   (delete (cons eudc-server eudc-protocol) servers)))
 848            ((eq eudc-inline-expansion-servers 'current-server)
 849             (list (cons eudc-server eudc-protocol)))
 850            (t
 851             (error "Wrong value for `eudc-inline-expansion-servers': %S"
 852                    eudc-inline-expansion-servers))))
 853     (if (and eudc-max-servers-to-query
 854              (> (length servers) eudc-max-servers-to-query))
 855         (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil))
 856
 857     (condition-case signal
 858         (progn
 859           (setq response
 860                 (catch 'found
 861                   ;; Loop on the servers
 862                   (while servers
 863                     (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
 864
 865                     ;; Determine which formats apply in the query-format list
 866                     (setq query-formats
 867                           (or
 868                            (eudc-extract-n-word-formats eudc-inline-query-format
 869                                                         (length query-words))
 870                            (if (null eudc-protocol-has-default-query-attributes)
 871                                '(name))))
 872
 873                     ;; Loop on query-formats
 874                     (while query-formats
 875                       (setq response
 876                             (eudc-query
 877                              (eudc-format-query query-words (car query-formats))
 878                              (eudc-translate-attribute-list
 879                               (cdr eudc-inline-expansion-format))))
 880                       (if response
 881                           (throw 'found response))
 882                       (setq query-formats (cdr query-formats)))
 883                     (setq servers (cdr servers)))
 884                   ;; No more servers to try... no match found
 885                   nil))
 886
 887
 888           (if (null response)
 889               (error "No match")
 890
 891             ;; Process response through eudc-inline-expansion-format
 892             (while response
 893               (setq response-string (apply 'format
 894                                            (car eudc-inline-expansion-format)
 895                                            (mapcar (function
 896                                                     (lambda (field)
 897                                                       (or (cdr (assq field (car response)))
 898                                                           "")))
 899                                                    (eudc-translate-attribute-list
 900                                                     (cdr eudc-inline-expansion-format)))))
 901               (if (> (length response-string) 0)
 902                   (setq response-strings
 903                         (cons response-string response-strings)))
 904               (setq response (cdr response)))
 905
 906             (if (or
 907                  (and replace (not eudc-expansion-overwrites-query))
 908                  (and (not replace) eudc-expansion-overwrites-query))
 909                 (kill-ring-save beg end))
 910             (cond
 911              ((or (= (length response-strings) 1)
 912                   (null eudc-multiple-match-handling-method)
 913                   (eq eudc-multiple-match-handling-method 'first))
 914               (delete-region beg end)
 915               (insert (car response-strings)))
 916              ((eq eudc-multiple-match-handling-method 'select)
 917               (eudc-select response-strings beg end))
 918              ((eq eudc-multiple-match-handling-method 'all)
 919               (delete-region beg end)
 920               (insert (mapconcat 'identity response-strings ", ")))
 921              ((eq eudc-multiple-match-handling-method 'abort)
 922               (error "There is more than one match for the query"))))
 923           (or (and (equal eudc-server eudc-former-server)
 924                    (equal eudc-protocol eudc-former-protocol))
 925               (eudc-set-server eudc-former-server eudc-former-protocol t)))
 926       (t
 927        (or (and (equal eudc-server eudc-former-server)
 928                 (equal eudc-protocol eudc-former-protocol))
 929            (eudc-set-server eudc-former-server eudc-former-protocol t))
 930        (signal (car signal) (cdr signal))))))
 931
 932 ;;;###autoload
 933 (defun eudc-query-form (&optional get-fields-from-server)
 934   "Display a form to query the directory server.
 935 If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first
 936 queries the server for the existing fields and displays a corresponding form."
 937   (interactive "P")
 938   (let ((fields (or (and get-fields-from-server
 939                          (eudc-get-attribute-list))
 940                     eudc-query-form-attributes))
 941         (buffer (get-buffer-create "*Directory Query Form*"))
 942         prompts
 943         widget
 944         (width 0)
 945         inhibit-read-only
 946         pt)
 947     (switch-to-buffer buffer)
 948     (setq inhibit-read-only t)
 949     (erase-buffer)
 950     (kill-all-local-variables)
 951     (make-local-variable 'eudc-form-widget-list)
 952     (widget-insert "Directory Query Form\n")
 953     (widget-insert "====================\n\n")
 954     (widget-insert "Current server is: " (or eudc-server
 955                                              (progn
 956                                                (call-interactively 'eudc-set-server)
 957                                                eudc-server))
 958                                              "\n")
 959     (widget-insert "Protocol         : " (symbol-name eudc-protocol) "\n")
 960     ;; Build the list of prompts
 961     (setq prompts (if eudc-use-raw-directory-names
 962                       (mapcar 'symbol-name (eudc-translate-attribute-list fields))
 963                     (mapcar (function
 964                              (lambda (field)
 965                                (or (and (assq field eudc-user-attribute-names-alist)
 966                                         (cdr (assq field eudc-user-attribute-names-alist)))
 967                                    (capitalize (symbol-name field)))))
 968                             fields)))
 969     ;; Loop over prompt strings to find the longest one
 970     (mapc (function
 971            (lambda (prompt)
 972              (if (> (length prompt) width)
 973                  (setq width (length prompt)))))
 974           prompts)
 975     ;; Insert the first widget out of the mapcar to leave the cursor
 976     ;; in the first field
 977     (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
 978     (setq pt (point))
 979     (setq widget (widget-create 'editable-field :size 15))
 980     (setq eudc-form-widget-list (cons (cons (car fields) widget)
 981                                       eudc-form-widget-list))
 982     (setq fields (cdr fields))
 983     (setq prompts (cdr prompts))
 984     (mapc (function
 985            (lambda (field)
 986              (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
 987              (setq widget (widget-create 'editable-field
 988                                          :size 15))
 989              (setq eudc-form-widget-list (cons (cons field widget)
 990                                                eudc-form-widget-list))
 991              (setq prompts (cdr prompts))))
 992           fields)
 993     (widget-insert "\n\n")
 994     (widget-create 'push-button
 995                    :notify (lambda (&rest ignore)
 996                              (eudc-process-form))
 997                    "Query Server")
 998     (widget-insert " ")
 999     (widget-create 'push-button
1000                    :notify (lambda (&rest ignore)
1001                              (eudc-query-form))
1002                    "Reset Form")
1003     (widget-insert " ")
1004     (widget-create 'push-button
1005                    :notify (lambda (&rest ignore)
1006                              (kill-this-buffer))
1007                    "Quit")
1008     (goto-char pt)
1009     (use-local-map widget-keymap)
1010     (widget-setup))
1011   )
1012
1013 (defun eudc-bookmark-server (server protocol)
1014   "Add SERVER using PROTOCOL to the EUDC `servers' hotlist."
1015   (interactive "sDirectory server: \nsProtocol: ")
1016   (if (member (cons server protocol) eudc-server-hotlist)
1017       (error "%s:%s is already in the hotlist" protocol server)
1018     (setq eudc-server-hotlist (cons (cons server protocol) eudc-server-hotlist))
1019     (eudc-install-menu)
1020     (eudc-save-options)))
1021
1022 (defun eudc-bookmark-current-server ()
1023   "Add current server to the EUDC `servers' hotlist."
1024   (interactive)
1025   (eudc-bookmark-server eudc-server eudc-protocol))
1026
1027 (defun eudc-save-options ()
1028   "Save options to `eudc-options-file'."
1029   (interactive)
1030   (save-excursion
1031     (set-buffer (find-file-noselect eudc-options-file t))
1032     (goto-char (point-min))
1033     ;; delete the previous setq
1034     (let ((standard-output (current-buffer))
1035           provide-p
1036           set-hotlist-p
1037           set-server-p)
1038       (catch 'found
1039         (while t
1040           (let ((sexp (condition-case nil
1041                           (read (current-buffer))
1042                         (end-of-file (throw 'found nil)))))
1043             (if (listp sexp)
1044                 (cond
1045                  ((eq (car sexp)  'eudc-set-server)
1046                   (delete-region (save-excursion
1047                                    (backward-sexp)
1048                                    (point))
1049                                  (point))
1050                   (setq set-server-p t))
1051                  ((and (eq (car sexp)  'setq)
1052                        (eq (eudc-cadr sexp) 'eudc-server-hotlist))
1053                   (delete-region (save-excursion
1054                                    (backward-sexp)
1055                                    (point))
1056                                  (point))
1057                   (setq set-hotlist-p t))
1058                  ((and (eq (car sexp)  'provide)
1059                        (equal (eudc-cadr sexp) '(quote eudc-options-file)))
1060                   (setq provide-p t)))
1061               (if (and provide-p
1062                        set-hotlist-p
1063                        set-server-p)
1064                   (throw 'found t))))))
1065       (if (eq (point-min) (point-max))
1066           (princ ";; This file was automatically generated by eudc.el.\n\n"))
1067       (or provide-p
1068           (princ "(provide 'eudc-options-file)\n"))
1069       (or (bolp)
1070           (princ "\n"))
1071       (delete-blank-lines)
1072       (princ "(eudc-set-server ")
1073       (prin1 eudc-server)
1074       (princ " '")
1075       (prin1 eudc-protocol)
1076       (princ " t)\n")
1077       (princ "(setq eudc-server-hotlist '")
1078       (prin1 eudc-server-hotlist)
1079       (princ ")\n")
1080       (save-buffer))))
1081
1082 (defun eudc-move-to-next-record ()
1083   "Move to next record, in a buffer displaying directory query results."
1084   (interactive)
1085   (if (not (eq major-mode 'eudc-mode))
1086       (error "Not in a EUDC buffer")
1087     (let ((pt (next-overlay-change (point))))
1088       (if (< pt (point-max))
1089           (goto-char (1+ pt))
1090         (error "No more records after point")))))
1091
1092 (defun eudc-move-to-previous-record ()
1093   "Move to previous record, in a buffer displaying directory query results."
1094   (interactive)
1095   (if (not (eq major-mode 'eudc-mode))
1096       (error "Not in a EUDC buffer")
1097     (let ((pt (previous-overlay-change (point))))
1098       (if (> pt (point-min))
1099           (goto-char pt)
1100         (error "No more records before point")))))
1101
1102 ;;}}}
1103
1104 ;;{{{      Menus and keymaps
1105
1106 (require 'easymenu)
1107
1108 (setq eudc-mode-map
1109       (let ((map (make-sparse-keymap)))
1110         (define-key map "q" 'kill-this-buffer)
1111         (define-key map "x" 'kill-this-buffer)
1112         (define-key map "f" 'eudc-query-form)
1113         (define-key map "b" 'eudc-try-bbdb-insert)
1114         (define-key map "n" 'eudc-move-to-next-record)
1115         (define-key map "p" 'eudc-move-to-previous-record)
1116         map))
1117 (set-keymap-parent eudc-mode-map widget-keymap)
1118
1119 (defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
1120
1121 (defconst eudc-tail-menu
1122   `(["---" nil nil]
1123     ["Query with Form" eudc-query-form t]
1124     ["Expand Inline Query" eudc-expand-inline t]
1125     ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
1126      (and (or (featurep 'bbdb)
1127               (prog1 (locate-library "bbdb") (message "")))
1128           (overlays-at (point))
1129           (overlay-get (car (overlays-at (point))) 'eudc-record))]
1130     ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
1131      (and (eq major-mode 'eudc-mode)
1132           (or (featurep 'bbdb)
1133               (prog1 (locate-library "bbdb") (message ""))))]
1134     ["---" nil nil]
1135     ["Get Email" eudc-get-email t]
1136     ["Get Phone" eudc-get-phone t]
1137     ["List Valid Attribute Names" eudc-get-attribute-list t]
1138     ["---" nil nil]
1139     ,(cons "Customize" eudc-custom-generated-menu)))
1140
1141
1142 (defconst eudc-server-menu
1143   '(["---" nil nil]
1144     ["Bookmark Current Server" eudc-bookmark-current-server t]
1145     ["Edit Server List" eudc-edit-hotlist t]
1146     ["New Server" eudc-set-server t]))
1147
1148 (defun eudc-menu ()
1149   (let (command)
1150     (append '("Directory Search")
1151             (list
1152              (append
1153               '("Server")
1154               (mapcar
1155                (function
1156                 (lambda (servspec)
1157                   (let* ((server (car servspec))
1158                          (protocol (cdr servspec))
1159                          (proto-name (symbol-name protocol)))
1160                     (setq command (intern (concat "eudc-set-server-"
1161                                                   server
1162                                                   "-"
1163                                                   proto-name)))
1164                     (if (not (fboundp command))
1165                         (fset command
1166                               `(lambda ()
1167                                  (interactive)
1168                                  (eudc-set-server ,server (quote ,protocol))
1169                                  (message "Selected directory server is now %s (%s)"
1170                                           ,server
1171                                           ,proto-name))))
1172                     (vector (format "%s (%s)" server proto-name)
1173                             command
1174                             :style 'radio
1175                             :selected `(equal eudc-server ,server)))))
1176                eudc-server-hotlist)
1177               eudc-server-menu))
1178             eudc-tail-menu)))
1179
1180 (defun eudc-install-menu ()
1181   (cond
1182    ((and (featurep 'xemacs) (featurep 'menubar))
1183     (add-submenu '("Tools") (eudc-menu)))
1184    ((not (featurep 'xemacs))
1185     (cond
1186      ((fboundp 'easy-menu-create-menu)
1187       (define-key
1188         global-map
1189         [menu-bar tools directory-search]
1190         (cons "Directory Search"
1191               (easy-menu-create-menu "Directory Search" (cdr (eudc-menu))))))
1192      ((fboundp 'easy-menu-add-item)
1193       (let ((menu (eudc-menu)))
1194         (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
1195                                                                   (cdr menu)))))
1196      ((fboundp 'easy-menu-create-keymaps)
1197       (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu))
1198       (define-key
1199         global-map
1200         [menu-bar tools eudc]
1201         (cons "Directory Search"
1202               (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
1203      (t
1204       (error "Unknown version of easymenu"))))
1205    ))
1206
1207
1208 ;;; Load time initializations :
1209
1210 ;;; Load the options file
1211 (if (and (not noninteractive)
1212          (and (locate-library eudc-options-file)
1213               (progn (message "") t))   ; Remove modeline message
1214          (not (featurep 'eudc-options-file)))
1215     (load eudc-options-file))
1216
1217 ;;; Install the full menu
1218 (unless (featurep 'infodock)
1219   (eudc-install-menu))
1220
1221
1222 ;;; The following installs a short menu for EUDC at XEmacs startup.
1223
1224 ;;;###autoload
1225 (defun eudc-load-eudc ()
1226   "Load the Emacs Unified Directory Client.
1227 This does nothing except loading eudc by autoload side-effect."
1228   (interactive)
1229   nil)
1230
1231 ;;;###autoload
1232 (cond ((not (featurep 'xemacs))
1233        (defvar eudc-tools-menu (make-sparse-keymap "Directory Search"))
1234        (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
1235        (define-key eudc-tools-menu [phone]
1236          '("Get Phone" . eudc-get-phone))
1237        (define-key eudc-tools-menu [email]
1238          '("Get Email" . eudc-get-email))
1239        (define-key eudc-tools-menu [separator-eudc-email]
1240          '("--"))
1241        (define-key eudc-tools-menu [expand-inline]
1242          '("Expand Inline Query" . eudc-expand-inline))
1243        (define-key eudc-tools-menu [query]
1244          '("Query with Form" . eudc-query-form))
1245        (define-key eudc-tools-menu [separator-eudc-query]
1246          '("--"))
1247        (define-key eudc-tools-menu [new]
1248          '("New Server" . eudc-set-server))
1249        (define-key eudc-tools-menu [load]
1250          '("Load Hotlist of Servers" . eudc-load-eudc)))
1251
1252       (t
1253        (let ((menu  '("Directory Search"
1254                       ["Load Hotlist of Servers" eudc-load-eudc t]
1255                       ["New Server" eudc-set-server t]
1256                       ["---" nil nil]
1257                       ["Query with Form" eudc-query-form t]
1258                       ["Expand Inline Query" eudc-expand-inline t]
1259                       ["---" nil nil]
1260                       ["Get Email" eudc-get-email t]
1261                       ["Get Phone" eudc-get-phone t])))
1262          (if (not (featurep 'eudc-autoloads))
1263              (if (featurep 'xemacs)
1264                  (if (and (featurep 'menubar)
1265                           (not (featurep 'infodock)))
1266                      (add-submenu '("Tools") menu))
1267                (require 'easymenu)
1268                (cond
1269                 ((fboundp 'easy-menu-add-item)
1270                  (easy-menu-add-item nil '("tools")
1271                                      (easy-menu-create-menu (car menu)
1272                                                             (cdr menu))))
1273                 ((fboundp 'easy-menu-create-keymaps)
1274                  (define-key
1275                    global-map
1276                    [menu-bar tools eudc]
1277                    (cons "Directory Search"
1278                          (easy-menu-create-keymaps "Directory Search"
1279                                                    (cdr menu)))))))))))
1280
1281 ;;}}}
1282
1283 (provide 'eudc)
1284
1285 ;;; arch-tag: e18872b6-db83-400b-869d-be54e9a4160c
1286 ;;; eudc.el ends here