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