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