cgit.sxemacs.org Git - packages/blob - xemacs-packages/eudc/eudc.el

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