Skip to content
Snippets Groups Projects
Commit 49bc6151779c authored by oscarf's avatar oscarf
Browse files

(eudc-known-protocols): New variable

(eudc-local-vars): New variable
(eudc-protocol-has-default-query-attributes): New variable
(eudc-switch-to-server-hook): New variable
(eudc-switch-from-server-hook): New variable
(eudc-protocol-switch-init-function): Removed
(eudc-protocol-switch-exit-function): Removed
(eudc-protocol-locals): Removed
(eudc-server-local-variable-p): New function
(eudc-protocol-local-variable-p): New function
(eudc-default-set): New function
(eudc-protocol-set): New function
(eudc-server-set): New function
(eudc-set): New function
(eudc-variable-default-value): New function
(eudc-variable-server-value): New function
(eudc-variable-protocol-value): New function
(eudc-update-variable): New function
(eudc-update-local-variables): New function
(eudc-register-protocol): API change
(eudc-switch-to-protocol): Removed
(eudc-hotlist-mode): Add menu to top menubar
(eudc-set-server): Complete on limited list of protocols and not
the whole obarray
(eudc-expand-inline): Bug fixes.
Limit list of queried servers to `eudc-max-servers-to-query'
Report error signal if any.
(eudc-query-form): Complete on `eudc-known-protocols'
(eudc-save-options): Wrong positioning in file fixed.
(eudc-custom-generated-menu): New variable
(eudc-tail-menu): Use it
parent 7066c7bfbaa5
No related branches found
No related tags found
No related merge requests found
......@@ -76,6 +76,10 @@
(defvar eudc-hotlist-mode-map nil)
(defvar eudc-hotlist-list-beginning nil)
;; Known protocols (used in completion)
;; Not to be mistaken with eudc-supported-protocols
(defconst eudc-known-protocols '(bbdb ph ldap))
;; Used by the selection insertion mechanism
(defvar eudc-pre-select-window-configuration nil)
(defvar eudc-insertion-marker nil)
......@@ -84,7 +88,9 @@
;; Alist of (SERVER . PROTOCOL)
(defvar eudc-server-hotlist nil)
;; Query function
;; Protocol dependent, should be defined in eudc-protocol-locals
;; List of variables that have server- or protocol-local bindings
(defvar eudc-local-vars nil)
;; Protocol local. Query function
(defvar eudc-query-function nil)
......@@ -89,5 +95,5 @@
(defvar eudc-query-function nil)
;; A function that retrieves a list of valid attribute names
;; Protocol local. A function that retrieves a list of valid attribute names
(defvar eudc-list-attributes-function nil)
......@@ -92,8 +98,7 @@
(defvar eudc-list-attributes-function nil)
;; A mapping between EUDC attribute names and corresponding
;; protocol specific names
;; The following names are defined by EUDC and may be included
;; in that list: `name' , `firstname', `email', `phone'
;; Protocol local. A mapping between EUDC attribute names and corresponding
;; protocol specific names. The following names are defined by EUDC and may be
;; included in that list: `name' , `firstname', `email', `phone'
(defvar eudc-protocol-attributes-translation-alist nil)
......@@ -98,5 +103,6 @@
(defvar eudc-protocol-attributes-translation-alist nil)
;; A function called each time EUDC switches to a protocol
(defvar eudc-protocol-switch-init-function nil)
;; Protocol local. Mapping between protocol attribute names and BBDB field
;; names
(defvar eudc-bbdb-conversion-alist nil)
......@@ -102,5 +108,4 @@
;; A function called each time EUDC switches from a protocol to
;; another one
(defvar eudc-protocol-switch-exit-function nil)
;; Protocol/Server local. Hook called upon switching to that server
(defvar eudc-switch-to-server-hook nil)
......@@ -106,4 +111,8 @@
;; Whether the protocol supports queries with no specified attribute name
;; Protocol/Server local. Hook called upon switching from that server
(defvar eudc-switch-from-server-hook nil)
;; Protocol local. Whether the protocol supports queries with no specified
;; attribute name
(defvar eudc-protocol-has-default-query-attributes nil)
......@@ -108,13 +117,3 @@
(defvar eudc-protocol-has-default-query-attributes nil)
;; Protocol locals
;; List of (PROTOCOL (EUDC-VAR . VALUE) (EUDC-VAR .VALUE) ...)
(defvar eudc-protocol-locals '((default
(eudc-query-function . nil)
(eudc-list-attributes-function . nil)
(eudc-protocol-attributes-translation-alist . nil)
(eudc-bbdb-conversion-alist . nil)
(eudc-protocol-switch-init-function . nil)
(eudc-protocol-switch-exit-function . nil)
(eudc-protocol-has-default-query-attributes . nil))))
......@@ -120,6 +119,5 @@
;;; Emacs does not provide that one
;;; FSF Gnu Emacs does not provide that one
(if (not (fboundp 'split-string))
(defun split-string (string pattern)
"Return a list of substrings of STRING which are separated by PATTERN."
......@@ -144,5 +142,136 @@
;;}}}
;;{{{ Server and Protocol Variable Routines
(defun eudc-server-local-variable-p (var)
"Return non-nil if variable has server local bindings"
(plist-member (get var 'eudc-locals) 'server))
(defun eudc-protocol-local-variable-p (var)
"Return non-nil if variable has protocol local bindings"
(plist-member (get var 'eudc-locals) 'protocol))
(defun eudc-default-set (var val)
"Set the EUDC default value of VAR to VAL.
The current binding of VAR is not changed."
(put var 'eudc-locals
(plist-put (get var 'eudc-locals) 'default val))
(add-to-list 'eudc-local-vars var))
(defun eudc-protocol-set (var val &optional protocol)
"Set the PROTOCOL-local binding of VAR to VAL.
If omitted PROTOCOL defaults to the current value of `eudc-protocol'.
The current binding of VAR is changed only if PROTOCOL is omitted."
(if (eq 'unbound (eudc-variable-default-value var))
(eudc-default-set var (symbol-value var)))
(let* ((eudc-locals (get var 'eudc-locals))
(protocol-locals (plist-get eudc-locals 'protocol)))
(setq protocol-locals (plist-put protocol-locals (or protocol
eudc-protocol) val))
(setq eudc-locals
(plist-put eudc-locals 'protocol protocol-locals))
(put var 'eudc-locals eudc-locals)
(add-to-list 'eudc-local-vars var)
(unless protocol
(eudc-update-variable var))))
(defun eudc-server-set (var val &optional server)
"Set the SERVER-local binding of VAR to VAL.
If omitted SERVER defaults to the current value of `eudc-server'.
The current binding of VAR is changed only if SERVER is omitted.."
(if (eq 'unbound (eudc-variable-default-value var))
(eudc-default-set var (symbol-value var)))
(let* ((eudc-locals (get var 'eudc-locals))
(server-locals (plist-get eudc-locals 'server)))
(setq server-locals (plist-put server-locals (or server
eudc-server) val))
(setq eudc-locals
(plist-put eudc-locals 'server server-locals))
(put var 'eudc-locals eudc-locals)
(add-to-list 'eudc-local-vars var)
(unless server
(eudc-update-variable var))))
(defun eudc-set (var val)
"Set the most local (server, protocol or default) binding of VAR to VAL.
The current binding of VAR is also set to VAL"
(cond
((not (eq 'unbound (eudc-variable-server-value var)))
(eudc-server-set var val))
((not (eq 'unbound (eudc-variable-protocol-value var)))
(eudc-protocol-set var val))
(t
(eudc-default-set var val)))
(set var val))
(defun eudc-variable-default-value (var)
"Return the default binding of VAR.
Return `unbound' if VAR has no EUDC default value."
(let ((eudc-locals (get var 'eudc-locals)))
(if (and (boundp var)
eudc-locals)
(plist-get eudc-locals 'default 'unbound)
'unbound)))
(defun eudc-variable-protocol-value (var &optional protocol)
"Return the value of VAR local to PROTOCOL.
Return `unbound' if VAR has no value local to PROTOCOL.
PROTOCOL defaults to `eudc-protocol'"
(let* ((eudc-locals (get var 'eudc-locals))
protocol-locals)
(if (not (and (boundp var)
eudc-locals
(plist-member eudc-locals 'protocol)))
'unbound
(setq protocol-locals (plist-get eudc-locals 'protocol))
(lax-plist-get protocol-locals
(or protocol
eudc-protocol) 'unbound))))
(defun eudc-variable-server-value (var &optional server)
"Return the value of VAR local to SERVER.
Return `unbound' if VAR has no value local to SERVER.
SERVER defaults to `eudc-server'"
(let* ((eudc-locals (get var 'eudc-locals))
server-locals)
(if (not (and (boundp var)
eudc-locals
(plist-member eudc-locals 'server)))
'unbound
(setq server-locals (plist-get eudc-locals 'server))
(lax-plist-get server-locals
(or server
eudc-server) 'unbound))))
(defun eudc-update-variable (var)
"Set the value of VAR according to its locals.
If the VAR has a server- or protocol-local value corresponding
to the current `eudc-server' and `eudc-protocol' then it is set
accordingly. Otherwise it is set to its EUDC default binding"
(let (val)
(cond
((not (eq 'unbound (setq val (eudc-variable-server-value var))))
(set var val))
((not (eq 'unbound (setq val (eudc-variable-protocol-value var))))
(set var val))
((not (eq 'unbound (setq val (eudc-variable-default-value var))))
(set var val)))))
(defun eudc-update-local-variables ()
"Update all declared local EUDC variables according to theire local settings."
(mapcar 'eudc-update-variable eudc-local-vars))
(eudc-default-set 'eudc-query-function nil)
(eudc-default-set 'eudc-list-attributes-function nil)
(eudc-default-set 'eudc-protocol-attributes-translation-alist nil)
(eudc-default-set 'eudc-bbdb-conversion-alist nil)
(eudc-default-set 'eudc-switch-to-server-hook nil)
(eudc-default-set 'eudc-switch-from-server-hook nil)
(eudc-default-set 'eudc-protocol-has-default-query-attributes nil)
;;}}}
;; Add PROTOCOL to the list of supported protocols
......@@ -147,6 +276,5 @@
;; Add PROTOCOL to the list of supported protocols
;; and LOCALS to the protocol locals list
(defun eudc-register-protocol (protocol locals)
(defun eudc-register-protocol (protocol)
(unless (memq protocol eudc-supported-protocols)
(setq eudc-supported-protocols
......@@ -151,39 +279,6 @@
(unless (memq protocol eudc-supported-protocols)
(setq eudc-supported-protocols
(cons protocol eudc-supported-protocols))
(setq eudc-protocol-locals
(cons (cons protocol locals)
eudc-protocol-locals))))
(defun eudc-switch-to-protocol (protocol)
"Use PROTOCOL for directory queries from now on."
(unless (or (member protocol
eudc-supported-protocols)
(load (concat "eudc-" (symbol-name protocol)) t))
(error "Unsupported protocol: %s" protocol))
(condition-case nil
(let ((locals (assq 'default eudc-protocol-locals)))
(if eudc-protocol-switch-exit-function
(funcall eudc-protocol-switch-exit-function))
;; Reset protocol locals to their default values
(setq locals (cdr locals))
(while locals
(set (car (car locals)) (cdr (car locals)))
(setq locals (cdr locals)))
(setq locals (assq protocol eudc-protocol-locals))
(if (null locals)
(error "No protocol specific settings found"))
(setq locals (cdr locals))
(while locals
(set (car (car locals)) (cdr (car locals)))
(setq locals (cdr locals)))
(setq eudc-protocol protocol)
(if eudc-protocol-switch-init-function
(funcall eudc-protocol-switch-init-function)))
;; If something bad happens return to the previous protocol
(t
(if eudc-protocol
(eudc-switch-to-protocol eudc-protocol)))))
(cons protocol eudc-supported-protocols))))
(defun eudc-translate-query (query)
"Translate attribute names of QUERY according to `eudc-protocol-attributes-translation-alist'."
......@@ -630,6 +725,10 @@
(setq mode-name "EUDC-Servers")
(use-local-map eudc-hotlist-mode-map)
(setq mode-popup-menu eudc-hotlist-menu)
(when (and eudc-xemacs-p
(featurep 'menubar))
(set-buffer-menubar current-menubar)
(add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))
(setq buffer-read-only t))
;;}}}
......@@ -646,7 +745,16 @@
"Set the directory server to SERVER using PROTOCOL.
If NO-SAVE is nil, the server is saved as the default server
for future sessions."
(interactive "sDirectory Server: \nSProtocol: ")
(unless (eq protocol eudc-protocol)
(eudc-switch-to-protocol protocol))
(interactive (list
(read-from-minibuffer "Directory Server: ")
(intern (completing-read "Protocol: "
(mapcar '(lambda (elt)
(cons (symbol-name elt)
elt))
eudc-known-protocols)))))
(unless (or (member protocol
eudc-supported-protocols)
(load (concat "eudc-" (symbol-name protocol)) t))
(error "Unsupported protocol: %s" protocol))
(setq eudc-protocol protocol)
(setq eudc-server server)
......@@ -652,4 +760,5 @@
(setq eudc-server server)
(eudc-update-local-variables)
(if (interactive-p)
(message "Current directory server is now %s (%s)" eudc-server eudc-protocol))
(if (null no-save)
......@@ -759,6 +868,9 @@
(t
(error "Wrong value for `eudc-inline-expansion-servers': %S"
eudc-inline-expansion-servers))))
(if eudc-max-servers-to-query
(setq servers (subseq servers 0 (min eudc-max-servers-to-query
(length servers)))))
;; Prepare the query
(setq words (split-string words "[ \t]+"))
......@@ -762,10 +874,7 @@
;; Prepare the query
(setq words (split-string words "[ \t]+"))
(if (= (length words) 1)
(if eudc-protocol-has-default-query-attributes
(setq query (car words))
(setq query (list (cons 'name (car words)))))
(if (cdr words)
(while (and words query-format)
(setq query-alist (cons (cons (car query-format) (car words)) query-alist))
(setq words (cdr words)
......@@ -783,7 +892,7 @@
(setq query (cons (car query-alist) query)))
(setq query-alist (cdr query-alist))))
(condition-case nil
(condition-case signal
(progn
(eudc-set-server (caar servers) (cdar servers) t)
(setq servers (cdr servers))
......@@ -787,6 +896,10 @@
(progn
(eudc-set-server (caar servers) (cdar servers) t)
(setq servers (cdr servers))
(if (and (null (cdr words))
eudc-protocol-has-default-query-attributes)
(setq query (car words))
(setq query (list (cons 'name (car words)))))
(setq response (eudc-query query (eudc-translate-attribute-list
(cdr eudc-inline-expansion-format))))
(while (and (null response)
......@@ -797,7 +910,7 @@
(cdr eudc-inline-expansion-format)))))
(if (null response)
(error "No match found")
(error "No match")
;; Process response through eudc-inline-expansion-format
(while response
......@@ -829,7 +942,10 @@
(insert (mapconcat 'identity response-strings ", ")))
((eq eudc-multiple-match-handling-method 'abort)
(error "There is more than one match for the query"))
)))
))
(or (and (equal eudc-server eudc-former-server)
(equal eudc-protocol eudc-former-protocol))
(eudc-set-server eudc-former-server eudc-former-protocol t)))
(t
(or (and (equal eudc-server eudc-former-server)
(equal eudc-protocol eudc-former-protocol))
......@@ -833,7 +949,8 @@
(t
(or (and (equal eudc-server eudc-former-server)
(equal eudc-protocol eudc-former-protocol))
(eudc-set-server eudc-former-server eudc-former-protocol t))))))
(eudc-set-server eudc-former-server eudc-former-protocol t))
(signal (car signal) (cdr signal))))))
;;;###autoload
(defun eudc-query-form (&optional get-fields-from-server)
......@@ -946,7 +1063,7 @@
(mapcar '(lambda (elt)
(cons (symbol-name elt)
elt))
eudc-supported-protocols)))
eudc-known-protocols)))
(buffer-read-only nil))
(if (not (eobp))
(forward-line 1))
......@@ -981,6 +1098,7 @@
(forward-line 1))
(setq eudc-server-hotlist (nreverse hotlist))
(eudc-install-menu)
(eudc-save-options)
(kill-this-buffer)))
(defun eudc-hotlist-select-server ()
......@@ -1069,11 +1187,7 @@
(if (eq (point-min) (point-max))
(princ ";; This file was automatically generated by eudc.el.\n\n"))
(or provide-p
(save-excursion
(goto-char (point-min))
(forward-sexp)
(backward-sexp)
(princ "(provide 'eudc-options-file)\n")))
(princ "(provide 'eudc-options-file)\n"))
(or (bolp)
(princ "\n"))
(delete-blank-lines)
......@@ -1155,6 +1269,8 @@
(define-key map "x" 'kill-this-buffer)
map))
(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
(defconst eudc-tail-menu
`(["---" nil nil]
["Query with Form" eudc-query-form t]
......@@ -1168,8 +1284,9 @@
["Get Email" eudc-get-email t]
["Get Phone" eudc-get-phone t]
["List Valid Attribute Names" eudc-get-attribute-list t]
["---" nil nil]
,(cons "Customize" (cdr (custom-menu-create 'eudc)))))
["---" nil nil]
,(cons "Customize" eudc-custom-generated-menu)))
(defconst eudc-server-menu
'(["---" nil nil]
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment