Lines Matching +defs:eudc +defs:list +defs:attributes +defs:function
0 ;;; eudc.el --- Emacs Unified Directory Client
40 ;; `eudc-query-form': Query a directory server from a query form
41 ;; `eudc-expand-inline': Query a directory server for the e-mail address
44 ;; `eudc-get-phone': Get a phone number from a directory server
45 ;; `eudc-get-email': Get an e-mail address from a directory server
46 ;; `eudc-customize': Customize various aspects of EUDC
61 (require 'eudc-vars)
69 (defconst eudc-xemacs-p (string-match "XEmacs" emacs-version))
70 (defconst eudc-emacs-p (not eudc-xemacs-p))
71 (defconst eudc-xemacs-mule-p (and eudc-xemacs-p
73 (defconst eudc-emacs-mule-p (and eudc-emacs-p
76 (defvar eudc-form-widget-list nil)
77 (defvar eudc-mode-map nil)
83 (defvar eudc-server-hotlist nil)
86 (defvar eudc-local-vars nil)
88 ;; Protocol local. Query function
89 (defvar eudc-query-function nil)
91 ;; Protocol local. A function that retrieves a list of valid attribute names
92 (defvar eudc-list-attributes-function nil)
96 ;; included in that list: `name' , `firstname', `email', `phone'
97 (defvar eudc-protocol-attributes-translation-alist nil)
101 (defvar eudc-bbdb-conversion-alist nil)
104 (defvar eudc-switch-to-server-hook nil)
107 (defvar eudc-switch-from-server-hook nil)
111 (defvar eudc-protocol-has-default-query-attributes nil)
113 (defun eudc-cadr (obj)
116 (defun eudc-cdar (obj)
119 (defun eudc-caar (obj)
122 (defun eudc-cdaar (obj)
125 (defun eudc-plist-member (plist prop)
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
142 one of the properties on the list."
143 (if (eudc-plist-member plist prop)
147 (defun eudc-lax-plist-get (plist prop &optional default)
148 "Extract a value from a lax property list.
150 PLIST is a lax property list, which is a list of the form (PROP1
152 using `equal' instead of `eq'. This function returns the value
154 properties on the list."
166 "Return a list of substrings of STRING which are separated by PATTERN.
183 (defun eudc-replace-in-string (str regexp newtext)
202 (defun eudc-server-local-variable-p (var)
204 (eudc-plist-member (get var 'eudc-locals) 'server))
206 (defun eudc-protocol-local-variable-p (var)
208 (eudc-plist-member (get var 'eudc-locals) 'protocol))
210 (defun eudc-default-set (var val)
213 (put var 'eudc-locals
214 (plist-put (get var 'eudc-locals) 'default val))
215 (add-to-list 'eudc-local-vars var))
217 (defun eudc-protocol-set (var val &optional protocol)
219 If omitted PROTOCOL defaults to the current value of `eudc-protocol'.
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)))
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)
232 (eudc-update-variable var))))
234 (defun eudc-server-set (var val &optional server)
236 If omitted SERVER defaults to the current value of `eudc-server'.
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)))
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)
249 (eudc-update-variable var))))
252 (defun eudc-set (var val)
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))
261 (eudc-default-set var val)))
264 (defun eudc-variable-default-value (var)
267 (let ((eudc-locals (get var 'eudc-locals)))
269 eudc-locals)
270 (eudc-plist-get eudc-locals 'default 'unbound)
273 (defun eudc-variable-protocol-value (var &optional protocol)
276 PROTOCOL defaults to `eudc-protocol'"
277 (let* ((eudc-locals (get var 'eudc-locals))
280 eudc-locals
281 (eudc-plist-member eudc-locals 'protocol)))
283 (setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
284 (eudc-lax-plist-get protocol-locals
286 eudc-protocol) 'unbound))))
288 (defun eudc-variable-server-value (var &optional server)
291 SERVER defaults to `eudc-server'"
292 (let* ((eudc-locals (get var 'eudc-locals))
295 eudc-locals
296 (eudc-plist-member eudc-locals 'server)))
298 (setq server-locals (eudc-plist-get eudc-locals 'server))
299 (eudc-lax-plist-get server-locals
301 eudc-server) 'unbound))))
303 (defun eudc-update-variable (var)
306 to the current `eudc-server' and `eudc-protocol' then it is set
310 ((not (eq 'unbound (setq val (eudc-variable-server-value var))))
312 ((not (eq 'unbound (setq val (eudc-variable-protocol-value var))))
314 ((not (eq 'unbound (setq val (eudc-variable-default-value var))))
317 (defun eudc-update-local-variables ()
320 (mapcar 'eudc-update-variable eudc-local-vars))
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)
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
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))))
349 (defun eudc-translate-query (query)
352 `eudc-protocol-attributes-translation-alist'."
353 (if eudc-protocol-attributes-translation-alist
356 (symbol-value eudc-protocol-attributes-translation-alist))))
363 (defun eudc-translate-attribute-list (list)
364 "Translate a list of attribute names LIST.
366 `eudc-protocol-attributes-translation-alist'."
367 (if eudc-protocol-attributes-translation-alist
371 (symbol-value eudc-protocol-attributes-translation-alist)))
375 list))
376 list))
378 (defun eudc-select (choices beg end)
384 (mapcar 'list choices)))
388 (defun eudc-query (query &optional return-attributes no-translation)
390 QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
393 `eudc-protocol-attributes-translation-alist'.
394 RETURN-ATTRIBUTES is a list of attributes to return defaulting to
395 `eudc-default-return-attributes'."
396 (unless eudc-query-function
399 (funcall eudc-query-function query (or return-attributes
400 eudc-default-return-attributes))
402 (funcall eudc-query-function
403 (eudc-translate-query query)
405 (return-attributes
406 (eudc-translate-attribute-list return-attributes))
407 ((listp eudc-default-return-attributes)
408 (eudc-translate-attribute-list eudc-default-return-attributes))
410 eudc-default-return-attributes)))))
412 (defun eudc-format-attribute-name-for-display (attribute)
414 ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
417 (let ((match (assq attribute eudc-user-attribute-names-alist)))
425 (defun eudc-print-attribute-value (field)
428 `eudc-attribute-display-method-alist' and the corresponding method,
431 eudc-attribute-display-method-alist))
436 (eval (list (cdr match) val))
439 (function
447 (t (list val)))))))
449 (defun eudc-print-record-field (field column-width)
451 FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
455 ;; The record field that is passed to this function has already been processed
456 ;; by `eudc-format-attribute-name-for-display' so we don't need to call it
462 (eudc-print-attribute-value field)))
464 (defun eudc-display-records (records &optional raw-attr-names)
465 "Display the record list RECORDS in a formatted buffer.
467 otherwise they are formatted according to `eudc-user-attribute-names-alist'."
483 (if eudc-strict-return-matches
484 "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n"
489 (function
492 (function
497 (eudc-format-attribute-name-for-display (car field))))
506 (function
510 (mapcar (function
512 (eudc-print-record-field field width)))
516 'eudc-record
524 (eudc-query-form))
531 (eudc-mode)
536 (defun eudc-process-form ()
540 (if (not (and (boundp 'eudc-form-widget-list)
541 eudc-form-widget-list))
543 (mapcar (function
549 eudc-form-widget-list)
551 (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names))))
554 (defun eudc-filter-duplicate-attributes (record)
555 "Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
563 (not (listp (eudc-cdar rec))))
566 (if (null (eudc-cdar rec))
567 (list record) ; No duplicate attrs in this record
568 (mapcar (function
574 (setq result (list unique))
577 (function
579 (let ((method (if (consp eudc-duplicate-attribute-handling-method)
587 eudc-protocol-attributes-translation-alist)))
589 eudc-duplicate-attribute-handling-method))
590 eudc-duplicate-attribute-handling-method)))
592 ((or (null method) (eq 'list method))
594 (eudc-add-field-to-records field result)))
597 (eudc-add-field-to-records (cons (car field)
598 (eudc-cadr field))
602 (eudc-add-field-to-records (cons (car field)
609 (eudc-distribute-field-on-records field result)))))))
613 (defun eudc-filter-partial-records (records attrs)
617 (function
621 (function
628 (defun eudc-add-field-to-records (field records)
629 "Add FIELD to each individual record in RECORDS and return the resulting list."
630 (mapcar (function
635 (defun eudc-distribute-field-on-records (field records)
645 (function
647 (let ((result-list (copy-sequence records)))
648 (setq result-list (eudc-add-field-to-records
650 result-list))
651 (setq result (append result-list result))
657 (defun eudc-mode ()
670 (setq major-mode 'eudc-mode)
672 (use-local-map eudc-mode-map)
673 (if eudc-emacs-p
674 (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))
675 (setq mode-popup-menu (eudc-menu)))
676 (run-mode-hooks 'eudc-mode-hook))
682 (defun eudc-customize ()
685 (customize-group 'eudc))
688 (defun eudc-set-server (server protocol &optional no-save)
692 (interactive (list
698 eudc-known-protocols)))))
700 eudc-supported-protocols)
703 (run-hooks 'eudc-switch-from-server-hook)
704 (setq eudc-protocol protocol)
705 (setq eudc-server server)
706 (eudc-update-local-variables)
707 (run-hooks 'eudc-switch-to-server-hook)
709 (message "Current directory server is now %s (%s)" eudc-server eudc-protocol))
711 (eudc-save-options)))
714 (defun eudc-get-email (name &optional error)
718 (or eudc-server
719 (call-interactively 'eudc-set-server))
720 (let ((result (eudc-query (list (cons 'name name)) '(email)))
723 (setq email (eudc-cdaar result))
732 (defun eudc-get-phone (name &optional error)
736 (or eudc-server
737 (call-interactively 'eudc-set-server))
738 (let ((result (eudc-query (list (cons 'name name)) '(phone)))
741 (setq phone (eudc-cdaar result))
749 (defun eudc-get-attribute-list ()
750 "Return a list of valid attributes for the current server.
751 When called interactively the list is formatted in a dedicated buffer
752 otherwise a list of symbols is returned."
754 (if eudc-list-attributes-function
755 (let ((entries (funcall eudc-list-attributes-function (interactive-p))))
758 (eudc-display-records entries t)
760 (error "The %s protocol has no support for listing attributes" eudc-protocol)))
762 (defun eudc-format-query (words format)
778 (setq key (eudc-caar query-alist)
779 val (eudc-cdar query-alist)
786 (if eudc-protocol-has-default-query-attributes
788 (list (cons 'name (mapconcat 'identity words " ")))))))
790 (defun eudc-extract-n-word-formats (format-list n)
791 "Extract a list of N-long formats from FORMAT-LIST.
803 format-list)))
809 (defun eudc-expand-inline (&optional replace)
813 The variable `eudc-inline-query-format' controls how to associate the
816 `eudc-inline-expansion-format' is inserted in the buffer at point.
818 `eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE.
820 see `eudc-inline-expansion-servers'"
822 (if (memq eudc-inline-expansion-servers
824 (or eudc-server
825 (call-interactively 'eudc-set-server))
826 (or eudc-server-hotlist
842 (eudc-former-server eudc-server)
843 (eudc-former-protocol eudc-protocol)
846 ;; Prepare the list of servers to query
847 (setq servers (copy-sequence eudc-server-hotlist))
850 ((eq eudc-inline-expansion-servers 'hotlist)
851 eudc-server-hotlist)
852 ((eq eudc-inline-expansion-servers 'server-then-hotlist)
853 (cons (cons eudc-server eudc-protocol)
854 (delete (cons eudc-server eudc-protocol) servers)))
855 ((eq eudc-inline-expansion-servers 'current-server)
856 (list (cons eudc-server eudc-protocol)))
858 (error "Wrong value for `eudc-inline-expansion-servers': %S"
859 eudc-inline-expansion-servers))))
860 (if (and eudc-max-servers-to-query
861 (> (length servers) eudc-max-servers-to-query))
862 (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil))
870 (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
872 ;; Determine which formats apply in the query-format list
875 (eudc-extract-n-word-formats eudc-inline-query-format
877 (if (null eudc-protocol-has-default-query-attributes)
883 (eudc-query
884 (eudc-format-query query-words (car query-formats))
885 (eudc-translate-attribute-list
886 (cdr eudc-inline-expansion-format))))
898 ;; Process response through eudc-inline-expansion-format
901 (car eudc-inline-expansion-format)
902 (mapcar (function
906 (eudc-translate-attribute-list
907 (cdr eudc-inline-expansion-format)))))
914 (and replace (not eudc-expansion-overwrites-query))
915 (and (not replace) eudc-expansion-overwrites-query))
919 (null eudc-multiple-match-handling-method)
920 (eq eudc-multiple-match-handling-method 'first))
923 ((eq eudc-multiple-match-handling-method 'select)
924 (eudc-select response-strings beg end))
925 ((eq eudc-multiple-match-handling-method 'all)
928 ((eq eudc-multiple-match-handling-method 'abort)
930 (or (and (equal eudc-server eudc-former-server)
931 (equal eudc-protocol eudc-former-protocol))
932 (eudc-set-server eudc-former-server eudc-former-protocol t)))
934 (or (and (equal eudc-server eudc-former-server)
935 (equal eudc-protocol eudc-former-protocol))
936 (eudc-set-server eudc-former-server eudc-former-protocol t))
940 (defun eudc-query-form (&optional get-fields-from-server)
942 If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first
946 (eudc-get-attribute-list))
947 eudc-query-form-attributes))
958 (make-local-variable 'eudc-form-widget-list)
961 (widget-insert "Current server is: " (or eudc-server
963 (call-interactively 'eudc-set-server)
964 eudc-server))
966 (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n")
967 ;; Build the list of prompts
968 (setq prompts (if eudc-use-raw-directory-names
969 (mapcar 'symbol-name (eudc-translate-attribute-list fields))
970 (mapcar (function
972 (or (and (assq field eudc-user-attribute-names-alist)
973 (cdr (assq field eudc-user-attribute-names-alist)))
977 (mapcar (function
987 (setq eudc-form-widget-list (cons (cons (car fields) widget)
988 eudc-form-widget-list))
991 (mapcar (function
996 (setq eudc-form-widget-list (cons (cons field widget)
997 eudc-form-widget-list))
1003 (eudc-process-form))
1008 (eudc-query-form))
1020 (defun eudc-bookmark-server (server protocol)
1023 (if (member (cons server protocol) eudc-server-hotlist)
1025 (setq eudc-server-hotlist (cons (cons server protocol) eudc-server-hotlist))
1026 (eudc-install-menu)
1027 (eudc-save-options)))
1029 (defun eudc-bookmark-current-server ()
1032 (eudc-bookmark-server eudc-server eudc-protocol))
1034 (defun eudc-save-options ()
1035 "Save options to `eudc-options-file'."
1038 (set-buffer (find-file-noselect eudc-options-file t))
1052 ((eq (car sexp) 'eudc-set-server)
1059 (eq (eudc-cadr sexp) 'eudc-server-hotlist))
1066 (equal (eudc-cadr sexp) '(quote eudc-options-file)))
1073 (princ ";; This file was automatically generated by eudc.el.\n\n"))
1075 (princ "(provide 'eudc-options-file)\n"))
1079 (princ "(eudc-set-server ")
1080 (prin1 eudc-server)
1082 (prin1 eudc-protocol)
1084 (princ "(setq eudc-server-hotlist '")
1085 (prin1 eudc-server-hotlist)
1089 (defun eudc-move-to-next-record ()
1092 (if (not (eq major-mode 'eudc-mode))
1099 (defun eudc-move-to-previous-record ()
1102 (if (not (eq major-mode 'eudc-mode))
1115 (setq eudc-mode-map
1119 (define-key map "f" 'eudc-query-form)
1120 (define-key map "b" 'eudc-try-bbdb-insert)
1121 (define-key map "n" 'eudc-move-to-next-record)
1122 (define-key map "p" 'eudc-move-to-previous-record)
1124 (set-keymap-parent eudc-mode-map widget-keymap)
1126 (defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
1128 (defconst eudc-tail-menu
1130 ["Query with Form" eudc-query-form t]
1131 ["Expand Inline Query" eudc-expand-inline t]
1132 ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
1136 (overlay-get (car (overlays-at (point))) 'eudc-record))]
1137 ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
1138 (and (eq major-mode 'eudc-mode)
1142 ["Get Email" eudc-get-email t]
1143 ["Get Phone" eudc-get-phone t]
1144 ["List Valid Attribute Names" eudc-get-attribute-list t]
1146 ,(cons "Customize" eudc-custom-generated-menu)))
1149 (defconst eudc-server-menu
1151 ["Bookmark Current Server" eudc-bookmark-current-server t]
1152 ["Edit Server List" eudc-edit-hotlist t]
1153 ["New Server" eudc-set-server t]))
1155 (defun eudc-menu ()
1158 (list
1162 (function
1167 (setq command (intern (concat "eudc-set-server-"
1175 (eudc-set-server ,server (quote ,protocol))
1182 :selected `(equal eudc-server ,server)))))
1183 eudc-server-hotlist)
1184 eudc-server-menu))
1185 eudc-tail-menu)))
1187 (defun eudc-install-menu ()
1189 ((and eudc-xemacs-p (featurep 'menubar))
1190 (add-submenu '("Tools") (eudc-menu)))
1191 (eudc-emacs-p
1198 (easy-menu-create-menu "Directory Search" (cdr (eudc-menu))))))
1200 (let ((menu (eudc-menu)))
1204 (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu))
1207 [menu-bar tools eudc]
1209 (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
1219 (and (locate-library eudc-options-file)
1221 (not (featurep 'eudc-options-file)))
1222 (load eudc-options-file))
1226 (eudc-install-menu))
1232 (defun eudc-load-eudc ()
1234 This does nothing except loading eudc by autoload side-effect."
1240 (defvar eudc-tools-menu (make-sparse-keymap "Directory Search"))
1241 (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
1242 (define-key eudc-tools-menu [phone]
1243 '("Get Phone" . eudc-get-phone))
1244 (define-key eudc-tools-menu [email]
1245 '("Get Email" . eudc-get-email))
1246 (define-key eudc-tools-menu [separator-eudc-email]
1248 (define-key eudc-tools-menu [expand-inline]
1249 '("Expand Inline Query" . eudc-expand-inline))
1250 (define-key eudc-tools-menu [query]
1251 '("Query with Form" . eudc-query-form))
1252 (define-key eudc-tools-menu [separator-eudc-query]
1254 (define-key eudc-tools-menu [new]
1255 '("New Server" . eudc-set-server))
1256 (define-key eudc-tools-menu [load]
1257 '("Load Hotlist of Servers" . eudc-load-eudc)))
1261 ["Load Hotlist of Servers" eudc-load-eudc t]
1262 ["New Server" eudc-set-server t]
1264 ["Query with Form" eudc-query-form t]
1265 ["Expand Inline Query" eudc-expand-inline t]
1267 ["Get Email" eudc-get-email t]
1268 ["Get Phone" eudc-get-phone t])))
1269 (if (not (featurep 'eudc-autoloads))
1270 (if eudc-xemacs-p
1283 [menu-bar tools eudc]
1290 (provide 'eudc)
1293 ;;; eudc.el ends here