lisp/net/eudc.el

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