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