[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/net/eudc.el
|
From: |
Pavel Janík |
|
Subject: |
[Emacs-diffs] Changes to emacs/lisp/net/eudc.el |
|
Date: |
Sun, 06 Jan 2002 10:06:15 -0500 |
Index: emacs/lisp/net/eudc.el
diff -c emacs/lisp/net/eudc.el:1.3 emacs/lisp/net/eudc.el:1.4
*** emacs/lisp/net/eudc.el:1.3 Fri Jan 14 07:00:59 2000
--- emacs/lisp/net/eudc.el Sun Jan 6 10:06:14 2002
***************
*** 85,91 ****
;; List of variables that have server- or protocol-local bindings
(defvar eudc-local-vars nil)
! ;; Protocol local. Query function
(defvar eudc-query-function nil)
;; Protocol local. A function that retrieves a list of valid attribute names
--- 85,91 ----
;; List of variables that have server- or protocol-local bindings
(defvar eudc-local-vars nil)
! ;; Protocol local. Query function
(defvar eudc-query-function nil)
;; Protocol local. A function that retrieves a list of valid attribute names
***************
*** 195,201 ****
newtext)))
(concat rtn-str (substring str start))))
! ;;}}}
;;{{{ Server and Protocol Variable Routines
--- 195,201 ----
newtext)))
(concat rtn-str (substring str start))))
! ;;}}}
;;{{{ Server and Protocol Variable Routines
***************
*** 230,236 ****
(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'.
--- 230,236 ----
(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'.
***************
*** 241,247 ****
(server-locals (eudc-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)
--- 241,247 ----
(server-locals (eudc-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)
***************
*** 252,258 ****
(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)))
--- 252,258 ----
(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)))
***************
*** 281,287 ****
(eudc-plist-member eudc-locals 'protocol)))
'unbound
(setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
! (eudc-lax-plist-get protocol-locals
(or protocol
eudc-protocol) 'unbound))))
--- 281,287 ----
(eudc-plist-member eudc-locals 'protocol)))
'unbound
(setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
! (eudc-lax-plist-get protocol-locals
(or protocol
eudc-protocol) 'unbound))))
***************
*** 306,312 ****
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))))
--- 306,312 ----
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))))
***************
*** 334,344 ****
;; Add PROTOCOL to the list of supported protocols
(defun eudc-register-protocol (protocol)
(unless (memq protocol eudc-supported-protocols)
! (setq eudc-supported-protocols
(cons protocol eudc-supported-protocols))
! (put 'eudc-protocol 'custom-type
`(choice :menu-tag "Protocol"
! ,@(mapcar (lambda (s)
(list 'string ':tag (symbol-name s)))
eudc-supported-protocols))))
(or (memq protocol eudc-known-protocols)
--- 334,344 ----
;; Add PROTOCOL to the list of supported protocols
(defun eudc-register-protocol (protocol)
(unless (memq protocol eudc-supported-protocols)
! (setq eudc-supported-protocols
(cons protocol eudc-supported-protocols))
! (put 'eudc-protocol 'custom-type
`(choice :menu-tag "Protocol"
! ,@(mapcar (lambda (s)
(list 'string ':tag (symbol-name s)))
eudc-supported-protocols))))
(or (memq protocol eudc-known-protocols)
***************
*** 352,364 ****
`eudc-protocol-attributes-translation-alist'."
(if eudc-protocol-attributes-translation-alist
(mapcar '(lambda (attribute)
! (let ((trans (assq (car attribute)
(symbol-value
eudc-protocol-attributes-translation-alist))))
(if trans
(cons (cdr trans) (cdr attribute))
attribute)))
query)
! query))
(defun eudc-translate-attribute-list (list)
"Translate a list of attribute names LIST.
--- 352,364 ----
`eudc-protocol-attributes-translation-alist'."
(if eudc-protocol-attributes-translation-alist
(mapcar '(lambda (attribute)
! (let ((trans (assq (car attribute)
(symbol-value
eudc-protocol-attributes-translation-alist))))
(if trans
(cons (cdr trans) (cdr attribute))
attribute)))
query)
! query))
(defun eudc-translate-attribute-list (list)
"Translate a list of attribute names LIST.
***************
*** 380,387 ****
(setq eudc-pre-select-window-configuration (current-window-configuration))
(setq eudc-insertion-marker (point-marker))
(with-output-to-temp-buffer "*EUDC Completions*"
! (apply 'display-completion-list
! choices
(if eudc-xemacs-p
'(:activate-callback eudc-insert-selected)))))
--- 380,387 ----
(setq eudc-pre-select-window-configuration (current-window-configuration))
(setq eudc-insertion-marker (point-marker))
(with-output-to-temp-buffer "*EUDC Completions*"
! (apply 'display-completion-list
! choices
(if eudc-xemacs-p
'(:activate-callback eudc-insert-selected)))))
***************
*** 400,418 ****
"Query the current directory server with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
name and VALUE the corresponding value.
! If NO-TRANSLATION is non-nil, ATTR is translated according to
`eudc-protocol-attributes-translation-alist'.
! RETURN-ATTRIBUTES is a list of attributes to return defaulting to
`eudc-default-return-attributes'."
(unless eudc-query-function
(error "Don't know how to perform the query"))
(if no-translation
(funcall eudc-query-function query (or return-attributes
eudc-default-return-attributes))
!
! (funcall eudc-query-function
(eudc-translate-query query)
! (cond
(return-attributes
(eudc-translate-attribute-list return-attributes))
((listp eudc-default-return-attributes)
--- 400,418 ----
"Query the current directory server with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
name and VALUE the corresponding value.
! If NO-TRANSLATION is non-nil, ATTR is translated according to
`eudc-protocol-attributes-translation-alist'.
! RETURN-ATTRIBUTES is a list of attributes to return defaulting to
`eudc-default-return-attributes'."
(unless eudc-query-function
(error "Don't know how to perform the query"))
(if no-translation
(funcall eudc-query-function query (or return-attributes
eudc-default-return-attributes))
!
! (funcall eudc-query-function
(eudc-translate-query query)
! (cond
(return-attributes
(eudc-translate-attribute-list return-attributes))
((listp eudc-default-return-attributes)
***************
*** 422,442 ****
(defun eudc-format-attribute-name-for-display (attribute)
"Format a directory attribute name for display.
! ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
by the corresponding user name if any. Otherwise it is capitalized and
underscore characters are replaced by spaces."
(let ((match (assq attribute eudc-user-attribute-names-alist)))
(if match
(cdr match)
! (capitalize
! (mapconcat 'identity
(split-string (symbol-name attribute) "_")
" ")))))
(defun eudc-print-attribute-value (field)
"Insert the value of the directory FIELD at point.
! The directory attribute name in car of FIELD is looked up in
! `eudc-attribute-display-method-alist' and the corresponding method,
if any, is called to print the value in cdr of FIELD."
(let ((match (assoc (downcase (car field))
eudc-attribute-display-method-alist))
--- 422,442 ----
(defun eudc-format-attribute-name-for-display (attribute)
"Format a directory attribute name for display.
! ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
by the corresponding user name if any. Otherwise it is capitalized and
underscore characters are replaced by spaces."
(let ((match (assq attribute eudc-user-attribute-names-alist)))
(if match
(cdr match)
! (capitalize
! (mapconcat 'identity
(split-string (symbol-name attribute) "_")
" ")))))
(defun eudc-print-attribute-value (field)
"Insert the value of the directory FIELD at point.
! The directory attribute name in car of FIELD is looked up in
! `eudc-attribute-display-method-alist' and the corresponding method,
if any, is called to print the value in cdr of FIELD."
(let ((match (assoc (downcase (car field))
eudc-attribute-display-method-alist))
***************
*** 460,479 ****
(defun eudc-print-record-field (field column-width)
"Print the record field FIELD.
FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
! COLUMN-WIDTH is the width of the first display column containing the
attribute name ATTR."
(let ((field-beg (point)))
;; The record field that is passed to this function has already been processed
;; by `eudc-format-attribute-name-for-display' so we don't need to call it
;; again to display the attribute name
! (insert (format (concat "%" (int-to-string column-width) "s: ")
(car field)))
(put-text-property field-beg (point) 'face 'bold)
(indent-to (+ 2 column-width))
(eudc-print-attribute-value field)))
(defun eudc-display-records (records &optional raw-attr-names)
! "Display the record list RECORDS in a formatted buffer.
If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(let ((buffer (get-buffer-create "*Directory Query Results*"))
--- 460,479 ----
(defun eudc-print-record-field (field column-width)
"Print the record field FIELD.
FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
! COLUMN-WIDTH is the width of the first display column containing the
attribute name ATTR."
(let ((field-beg (point)))
;; The record field that is passed to this function has already been processed
;; by `eudc-format-attribute-name-for-display' so we don't need to call it
;; again to display the attribute name
! (insert (format (concat "%" (int-to-string column-width) "s: ")
(car field)))
(put-text-property field-beg (point) 'face 'bold)
(indent-to (+ 2 column-width))
(eudc-print-attribute-value field)))
(defun eudc-display-records (records &optional raw-attr-names)
! "Display the record list RECORDS in a formatted buffer.
If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(let ((buffer (get-buffer-create "*Directory Query Results*"))
***************
*** 483,489 ****
beg
first-record
attribute-name)
! (switch-to-buffer buffer)
(setq buffer-read-only t)
(setq inhibit-read-only t)
(erase-buffer)
--- 483,489 ----
beg
first-record
attribute-name)
! (switch-to-buffer buffer)
(setq buffer-read-only t)
(setq inhibit-read-only t)
(erase-buffer)
***************
*** 496,508 ****
""))
;; Replace field names with user names, compute max width
(setq precords
! (mapcar
(function
(lambda (record)
! (mapcar
(function
(lambda (field)
! (setq attribute-name
(if raw-attr-names
(symbol-name (car field))
(eudc-format-attribute-name-for-display (car
field))))
--- 496,508 ----
""))
;; Replace field names with user names, compute max width
(setq precords
! (mapcar
(function
(lambda (record)
! (mapcar
(function
(lambda (field)
! (setq attribute-name
(if raw-attr-names
(symbol-name (car field))
(eudc-format-attribute-name-for-display (car
field))))
***************
*** 513,526 ****
records))
;; Display the records
(setq first-record (point))
! (mapcar
(function
(lambda (record)
(setq beg (point))
;; Map over the record fields to print the attribute/value pairs
! (mapcar (function
(lambda (field)
! (eudc-print-record-field field width)))
record)
;; Store the record internal format in some convenient place
(overlay-put (make-overlay beg (point))
--- 513,526 ----
records))
;; Display the records
(setq first-record (point))
! (mapcar
(function
(lambda (record)
(setq beg (point))
;; Map over the record fields to print the attribute/value pairs
! (mapcar (function
(lambda (field)
! (eudc-print-record-field field width)))
record)
;; Store the record internal format in some convenient place
(overlay-put (make-overlay beg (point))
***************
*** 551,557 ****
(if (not (and (boundp 'eudc-form-widget-list)
eudc-form-widget-list))
(error "Not in a directory query form buffer")
! (mapcar (function
(lambda (wid-field)
(setq value (widget-value (cdr wid-field)))
(if (not (string= value ""))
--- 551,557 ----
(if (not (and (boundp 'eudc-form-widget-list)
eudc-form-widget-list))
(error "Not in a directory query form buffer")
! (mapcar (function
(lambda (wid-field)
(setq value (widget-value (cdr wid-field)))
(if (not (string= value ""))
***************
*** 560,567 ****
eudc-form-widget-list)
(kill-buffer (current-buffer))
(eudc-display-records (eudc-query query-alist)
eudc-use-raw-directory-names))))
!
!
(defun eudc-filter-duplicate-attributes (record)
"Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
--- 560,566 ----
eudc-form-widget-list)
(kill-buffer (current-buffer))
(eudc-display-records (eudc-query query-alist)
eudc-use-raw-directory-names))))
!
(defun eudc-filter-duplicate-attributes (record)
"Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
***************
*** 577,583 ****
(if (null (eudc-cdar rec))
(list record) ; No duplicate attrs in this record
! (mapcar (function
(lambda (field)
(if (listp (cdr field))
(setq duplicates (cons field duplicates))
--- 576,582 ----
(if (null (eudc-cdar rec))
(list record) ; No duplicate attrs in this record
! (mapcar (function
(lambda (field)
(if (listp (cdr field))
(setq duplicates (cons field duplicates))
***************
*** 585,618 ****
record)
(setq result (list unique))
;; Map over the record fields that have multiple values
! (mapcar
(function
(lambda (field)
(let ((method (if (consp eudc-duplicate-attribute-handling-method)
! (cdr
! (assq
! (or
! (car
! (rassq
(car field)
! (symbol-value
eudc-protocol-attributes-translation-alist)))
(car field))
eudc-duplicate-attribute-handling-method))
eudc-duplicate-attribute-handling-method)))
(cond
((or (null method) (eq 'list method))
! (setq result
(eudc-add-field-to-records field result)))
((eq 'first method)
! (setq result
! (eudc-add-field-to-records (cons (car field)
! (eudc-cadr field))
result)))
((eq 'concat method)
! (setq result
(eudc-add-field-to-records (cons (car field)
! (mapconcat
'identity
(cdr field)
"\n")) result)))
--- 584,617 ----
record)
(setq result (list unique))
;; Map over the record fields that have multiple values
! (mapcar
(function
(lambda (field)
(let ((method (if (consp eudc-duplicate-attribute-handling-method)
! (cdr
! (assq
! (or
! (car
! (rassq
(car field)
! (symbol-value
eudc-protocol-attributes-translation-alist)))
(car field))
eudc-duplicate-attribute-handling-method))
eudc-duplicate-attribute-handling-method)))
(cond
((or (null method) (eq 'list method))
! (setq result
(eudc-add-field-to-records field result)))
((eq 'first method)
! (setq result
! (eudc-add-field-to-records (cons (car field)
! (eudc-cadr field))
result)))
((eq 'concat method)
! (setq result
(eudc-add-field-to-records (cons (car field)
! (mapconcat
'identity
(cdr field)
"\n")) result)))
***************
*** 624,642 ****
(defun eudc-filter-partial-records (records attrs)
"Eliminate records that do not caontain all ATTRS from RECORDS."
! (delq nil
! (mapcar
! (function
(lambda (rec)
! (if (eval (cons 'and
! (mapcar
! (function
(lambda (attr)
(consp (assq attr rec))))
attrs)))
rec)))
records)))
!
(defun eudc-add-field-to-records (field records)
"Add FIELD to each individual record in RECORDS and return the resulting
list."
(mapcar (function
--- 623,641 ----
(defun eudc-filter-partial-records (records attrs)
"Eliminate records that do not caontain all ATTRS from RECORDS."
! (delq nil
! (mapcar
! (function
(lambda (rec)
! (if (eval (cons 'and
! (mapcar
! (function
(lambda (attr)
(consp (assq attr rec))))
attrs)))
rec)))
records)))
!
(defun eudc-add-field-to-records (field records)
"Add FIELD to each individual record in RECORDS and return the resulting
list."
(mapcar (function
***************
*** 653,663 ****
(while values
(setcdr values (delete (car values) (cdr values)))
(setq values (cdr values)))
! (mapcar
(function
(lambda (value)
(let ((result-list (copy-sequence records)))
! (setq result-list (eudc-add-field-to-records
(cons (car field) value)
result-list))
(setq result (append result-list result))
--- 652,662 ----
(while values
(setcdr values (delete (car values) (cdr values)))
(setq values (cdr values)))
! (mapcar
(function
(lambda (value)
(let ((result-list (copy-sequence records)))
! (setq result-list (eudc-add-field-to-records
(cons (car field) value)
result-list))
(setq result (append result-list result))
***************
*** 688,694 ****
(run-hooks 'eudc-mode-hook)
)
! ;;}}}
;;{{{ High-level interfaces (interactive functions)
--- 687,693 ----
(run-hooks 'eudc-mode-hook)
)
! ;;}}}
;;{{{ High-level interfaces (interactive functions)
***************
*** 700,710 ****
;;;###autoload
(defun eudc-set-server (server protocol &optional no-save)
"Set the directory server to SERVER using PROTOCOL.
! Unless NO-SAVE is non-nil, the server is saved as the default
server for future sessions."
(interactive (list
(read-from-minibuffer "Directory Server: ")
! (intern (completing-read "Protocol: "
(mapcar '(lambda (elt)
(cons (symbol-name elt)
elt))
--- 699,709 ----
;;;###autoload
(defun eudc-set-server (server protocol &optional no-save)
"Set the directory server to SERVER using PROTOCOL.
! Unless NO-SAVE is non-nil, the server is saved as the default
server for future sessions."
(interactive (list
(read-from-minibuffer "Directory Server: ")
! (intern (completing-read "Protocol: "
(mapcar '(lambda (elt)
(cons (symbol-name elt)
elt))
***************
*** 731,737 ****
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(email)))
email)
! (if (null (cdr result))
(setq email (eudc-cdaar result))
(error "Multiple match. Use the query form"))
(if (interactive-p)
--- 730,736 ----
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(email)))
email)
! (if (null (cdr result))
(setq email (eudc-cdaar result))
(error "Multiple match. Use the query form"))
(if (interactive-p)
***************
*** 748,754 ****
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(phone)))
phone)
! (if (null (cdr result))
(setq phone (eudc-cdaar result))
(error "Multiple match. Use the query form"))
(if (interactive-p)
--- 747,753 ----
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(phone)))
phone)
! (if (null (cdr result))
(setq phone (eudc-cdaar result))
(error "Multiple match. Use the query form"))
(if (interactive-p)
***************
*** 764,770 ****
(interactive)
(if eudc-list-attributes-function
(let ((entries (funcall eudc-list-attributes-function (interactive-p))))
! (if entries
(if (interactive-p)
(eudc-display-records entries t)
entries)))
--- 763,769 ----
(interactive)
(if eudc-list-attributes-function
(let ((entries (funcall eudc-list-attributes-function (interactive-p))))
! (if entries
(if (interactive-p)
(eudc-display-records entries t)
entries)))
***************
*** 778,784 ****
(if format
(progn
(while (and words format)
! (setq query-alist (cons (cons (car format) (car words))
query-alist))
(setq words (cdr words)
format (cdr format)))
--- 777,783 ----
(if format
(progn
(while (and words format)
! (setq query-alist (cons (cons (car format) (car words))
query-alist))
(setq words (cdr words)
format (cdr format)))
***************
*** 814,837 ****
format-list)))
(setq n (1- n)))
formats))
-
;;;###autoload
(defun eudc-expand-inline (&optional replace)
"Query the directory server, and expand the query string before point.
The query string consists of the buffer substring from the point back to
! the preceding comma, colon or beginning of line.
! The variable `eudc-inline-query-format' controls how to associate the
individual inline query words with directory attribute names.
! After querying the server for the given string, the expansion specified by
`eudc-inline-expansion-format' is inserted in the buffer at point.
If REPLACE is non nil, then this expansion replaces the name in the buffer.
`eudc-expansion-overwrites-query' being non nil inverts the meaning of
REPLACE.
! Multiple servers can be tried with the same query until one finds a match,
see `eudc-inline-expansion-servers'"
(interactive)
! (if (memq eudc-inline-expansion-servers
'(current-server server-then-hotlist))
(or eudc-server
(call-interactively 'eudc-set-server))
--- 813,835 ----
format-list)))
(setq n (1- n)))
formats))
;;;###autoload
(defun eudc-expand-inline (&optional replace)
"Query the directory server, and expand the query string before point.
The query string consists of the buffer substring from the point back to
! the preceding comma, colon or beginning of line.
! The variable `eudc-inline-query-format' controls how to associate the
individual inline query words with directory attribute names.
! After querying the server for the given string, the expansion specified by
`eudc-inline-expansion-format' is inserted in the buffer at point.
If REPLACE is non nil, then this expansion replaces the name in the buffer.
`eudc-expansion-overwrites-query' being non nil inverts the meaning of
REPLACE.
! Multiple servers can be tried with the same query until one finds a match,
see `eudc-inline-expansion-servers'"
(interactive)
! (if (memq eudc-inline-expansion-servers
'(current-server server-then-hotlist))
(or eudc-server
(call-interactively 'eudc-set-server))
***************
*** 839,845 ****
(error "No server in the hotlist")))
(let* ((end (point))
(beg (save-excursion
! (if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
(save-excursion
(beginning-of-line)
(point))
--- 837,843 ----
(error "No server in the hotlist")))
(let* ((end (point))
(beg (save-excursion
! (if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
(save-excursion
(beginning-of-line)
(point))
***************
*** 858,864 ****
;; Prepare the list of servers to query
(setq servers (copy-sequence eudc-server-hotlist))
(setq servers
! (cond
((eq eudc-inline-expansion-servers 'hotlist)
eudc-server-hotlist)
((eq eudc-inline-expansion-servers 'server-then-hotlist)
--- 856,862 ----
;; Prepare the list of servers to query
(setq servers (copy-sequence eudc-server-hotlist))
(setq servers
! (cond
((eq eudc-inline-expansion-servers 'hotlist)
eudc-server-hotlist)
((eq eudc-inline-expansion-servers 'server-then-hotlist)
***************
*** 875,894 ****
(condition-case signal
(progn
! (setq response
(catch 'found
;; Loop on the servers
(while servers
(eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
!
;; Determine which formats apply in the query-format list
(setq query-formats
! (or
(eudc-extract-n-word-formats eudc-inline-query-format
(length query-words))
(if (null eudc-protocol-has-default-query-attributes)
'(name))))
!
;; Loop on query-formats
(while query-formats
(setq response
--- 873,892 ----
(condition-case signal
(progn
! (setq response
(catch 'found
;; Loop on the servers
(while servers
(eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
!
;; Determine which formats apply in the query-format list
(setq query-formats
! (or
(eudc-extract-n-word-formats eudc-inline-query-format
(length query-words))
(if (null eudc-protocol-has-default-query-attributes)
'(name))))
!
;; Loop on query-formats
(while query-formats
(setq response
***************
*** 906,919 ****
(if (null response)
(error "No match")
!
;; Process response through eudc-inline-expansion-format
(while response
! (setq response-string (apply 'format
(car eudc-inline-expansion-format)
! (mapcar (function
(lambda (field)
! (or (cdr (assq field (car
response)))
"")))
(eudc-translate-attribute-list
(cdr
eudc-inline-expansion-format)))))
--- 904,917 ----
(if (null response)
(error "No match")
!
;; Process response through eudc-inline-expansion-format
(while response
! (setq response-string (apply 'format
(car eudc-inline-expansion-format)
! (mapcar (function
(lambda (field)
! (or (cdr (assq field (car
response)))
"")))
(eudc-translate-attribute-list
(cdr
eudc-inline-expansion-format)))))
***************
*** 921,932 ****
(setq response-strings
(cons response-string response-strings)))
(setq response (cdr response)))
!
(if (or
(and replace (not eudc-expansion-overwrites-query))
(and (not replace) eudc-expansion-overwrites-query))
(delete-region beg end))
! (cond
((or (= (length response-strings) 1)
(null eudc-multiple-match-handling-method)
(eq eudc-multiple-match-handling-method 'first))
--- 919,930 ----
(setq response-strings
(cons response-string response-strings)))
(setq response (cdr response)))
!
(if (or
(and replace (not eudc-expansion-overwrites-query))
(and (not replace) eudc-expansion-overwrites-query))
(delete-region beg end))
! (cond
((or (= (length response-strings) 1)
(null eudc-multiple-match-handling-method)
(eq eudc-multiple-match-handling-method 'first))
***************
*** 946,952 ****
(equal eudc-protocol eudc-former-protocol))
(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)
"Display a form to query the directory server.
--- 944,950 ----
(equal eudc-protocol eudc-former-protocol))
(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)
"Display a form to query the directory server.
***************
*** 970,976 ****
(widget-insert "Directory Query Form\n")
(widget-insert "====================\n\n")
(widget-insert "Current server is: " (or eudc-server
! (progn
(call-interactively
'eudc-set-server)
eudc-server))
"\n")
--- 968,974 ----
(widget-insert "Directory Query Form\n")
(widget-insert "====================\n\n")
(widget-insert "Current server is: " (or eudc-server
! (progn
(call-interactively
'eudc-set-server)
eudc-server))
"\n")
***************
*** 990,997 ****
(if (> (length prompt) width)
(setq width (length prompt)))))
prompts)
! ;; Insert the first widget out of the mapcar to leave the cursor
! ;; in the first field
(widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ")
(car prompts)))
(setq pt (point))
(setq widget (widget-create 'editable-field :size 15))
--- 988,995 ----
(if (> (length prompt) width)
(setq width (length prompt)))))
prompts)
! ;; Insert the first widget out of the mapcar to leave the cursor
! ;; in the first field
(widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ")
(car prompts)))
(setq pt (point))
(setq widget (widget-create 'editable-field :size 15))
***************
*** 1118,1131 ****
(error "No more records before point")))))
-
;;}}}
;;{{{ Menus an keymaps
(require 'easymenu)
! (setq eudc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "q" 'kill-this-buffer)
(define-key map "x" 'kill-this-buffer)
--- 1116,1128 ----
(error "No more records before point")))))
;;}}}
;;{{{ Menus an keymaps
(require 'easymenu)
! (setq eudc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "q" 'kill-this-buffer)
(define-key map "x" 'kill-this-buffer)
***************
*** 1138,1153 ****
(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
! (defconst eudc-tail-menu
`(["---" nil nil]
["Query with Form" eudc-query-form t]
["Expand Inline Query" eudc-expand-inline t]
! ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
(and (or (featurep 'bbdb)
(prog1 (locate-library "bbdb") (message "")))
(overlays-at (point))
(overlay-get (car (overlays-at (point))) 'eudc-record))]
! ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
(and (eq major-mode 'eudc-mode)
(or (featurep 'bbdb)
(prog1 (locate-library "bbdb") (message ""))))]
--- 1135,1150 ----
(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
! (defconst eudc-tail-menu
`(["---" nil nil]
["Query with Form" eudc-query-form t]
["Expand Inline Query" eudc-expand-inline t]
! ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
(and (or (featurep 'bbdb)
(prog1 (locate-library "bbdb") (message "")))
(overlays-at (point))
(overlay-get (car (overlays-at (point))) 'eudc-record))]
! ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
(and (eq major-mode 'eudc-mode)
(or (featurep 'bbdb)
(prog1 (locate-library "bbdb") (message ""))))]
***************
*** 1157,1165 ****
["List Valid Attribute Names" eudc-get-attribute-list t]
["---" nil nil]
,(cons "Customize" eudc-custom-generated-menu)))
-
! (defconst eudc-server-menu
'(["---" nil nil]
["Bookmark Current Server" eudc-bookmark-current-server t]
["Edit Server List" eudc-edit-hotlist t]
--- 1154,1162 ----
["List Valid Attribute Names" eudc-get-attribute-list t]
["---" nil nil]
,(cons "Customize" eudc-custom-generated-menu)))
!
! (defconst eudc-server-menu
'(["---" nil nil]
["Bookmark Current Server" eudc-bookmark-current-server t]
["Edit Server List" eudc-edit-hotlist t]
***************
*** 1169,1193 ****
(let (command)
(append '("Directory Search")
(list
! (append
'("Server")
! (mapcar
! (function
(lambda (servspec)
(let* ((server (car servspec))
(protocol (cdr servspec))
(proto-name (symbol-name protocol)))
! (setq command (intern (concat "eudc-set-server-"
! server
! "-"
proto-name)))
(if (not (fboundp command))
! (fset command
`(lambda ()
(interactive)
(eudc-set-server ,server (quote ,protocol))
! (message "Selected directory server is now %s
(%s)"
! ,server
,proto-name))))
(vector (format "%s (%s)" server proto-name)
command
--- 1166,1190 ----
(let (command)
(append '("Directory Search")
(list
! (append
'("Server")
! (mapcar
! (function
(lambda (servspec)
(let* ((server (car servspec))
(protocol (cdr servspec))
(proto-name (symbol-name protocol)))
! (setq command (intern (concat "eudc-set-server-"
! server
! "-"
proto-name)))
(if (not (fboundp command))
! (fset command
`(lambda ()
(interactive)
(eudc-set-server ,server (quote ,protocol))
! (message "Selected directory server is now %s
(%s)"
! ,server
,proto-name))))
(vector (format "%s (%s)" server proto-name)
command
***************
*** 1198,1217 ****
eudc-tail-menu)))
(defun eudc-install-menu ()
! (cond
((and eudc-xemacs-p (featurep 'menubar))
(add-submenu '("Tools") (eudc-menu)))
(eudc-emacs-p
! (cond
((fboundp 'easy-menu-add-item)
(let ((menu (eudc-menu)))
(easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
(cdr menu)))))
((fboundp 'easy-menu-create-keymaps)
(easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu"
(eudc-menu))
! (define-key
global-map
! [menu-bar tools eudc]
(cons "Directory Search"
(easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
(t
--- 1195,1214 ----
eudc-tail-menu)))
(defun eudc-install-menu ()
! (cond
((and eudc-xemacs-p (featurep 'menubar))
(add-submenu '("Tools") (eudc-menu)))
(eudc-emacs-p
! (cond
((fboundp 'easy-menu-add-item)
(let ((menu (eudc-menu)))
(easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
(cdr menu)))))
((fboundp 'easy-menu-create-keymaps)
(easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu"
(eudc-menu))
! (define-key
global-map
! [menu-bar tools eudc]
(cons "Directory Search"
(easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
(t
***************
*** 1227,1234 ****
(message "")) ; Remove modeline message
(not (featurep 'eudc-options-file)))
(load eudc-options-file))
!
!
;;; Install the full menu
(unless (featurep 'infodock)
(eudc-install-menu))
--- 1224,1230 ----
(message "")) ; Remove modeline message
(not (featurep 'eudc-options-file)))
(load eudc-options-file))
!
;;; Install the full menu
(unless (featurep 'infodock)
(eudc-install-menu))
***************
*** 1243,1255 ****
(interactive)
nil)
- ;;}}}
-
;;;###autoload
! (cond ((not (string-match "XEmacs" emacs-version))
(defvar eudc-tools-menu (make-sparse-keymap "Directory Search"))
(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
-
(define-key eudc-tools-menu [phone]
'("Get Phone" . eudc-get-phone))
(define-key eudc-tools-menu [email]
--- 1239,1248 ----
(interactive)
nil)
;;;###autoload
! (cond ((not eudc-xemacs-p)
(defvar eudc-tools-menu (make-sparse-keymap "Directory Search"))
(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
(define-key eudc-tools-menu [phone]
'("Get Phone" . eudc-get-phone))
(define-key eudc-tools-menu [email]
***************
*** 1266,1272 ****
'("New Server" . eudc-set-server))
(define-key eudc-tools-menu [load]
'("Load Hotlist of Servers" . eudc-load-eudc)))
!
(t
(let ((menu '("Directory Search"
["Load Hotlist of Servers" eudc-load-eudc t]
--- 1259,1265 ----
'("New Server" . eudc-set-server))
(define-key eudc-tools-menu [load]
'("Load Hotlist of Servers" . eudc-load-eudc)))
!
(t
(let ((menu '("Directory Search"
["Load Hotlist of Servers" eudc-load-eudc t]
***************
*** 1278,1303 ****
["Get Email" eudc-get-email t]
["Get Phone" eudc-get-phone t])))
(if (not (featurep 'eudc-autoloads))
! (if (string-match "XEmacs" emacs-version)
(if (and (featurep 'menubar)
(not (featurep 'infodock)))
(add-submenu '("Tools") menu))
(require 'easymenu)
! (cond
((fboundp 'easy-menu-add-item)
(easy-menu-add-item nil '("tools")
(easy-menu-create-menu (car menu)
(cdr menu))))
((fboundp 'easy-menu-create-keymaps)
! (define-key
global-map
! [menu-bar tools eudc]
(cons "Directory Search"
(easy-menu-create-keymaps "Directory Search"
(cdr menu)))))))))))
!
;;}}}
!
(provide 'eudc)
;;; eudc.el ends here
--- 1271,1296 ----
["Get Email" eudc-get-email t]
["Get Phone" eudc-get-phone t])))
(if (not (featurep 'eudc-autoloads))
! (if eudc-xemacs-p
(if (and (featurep 'menubar)
(not (featurep 'infodock)))
(add-submenu '("Tools") menu))
(require 'easymenu)
! (cond
((fboundp 'easy-menu-add-item)
(easy-menu-add-item nil '("tools")
(easy-menu-create-menu (car menu)
(cdr menu))))
((fboundp 'easy-menu-create-keymaps)
! (define-key
global-map
! [menu-bar tools eudc]
(cons "Directory Search"
(easy-menu-create-keymaps "Directory Search"
(cdr menu)))))))))))
!
;;}}}
!
(provide 'eudc)
;;; eudc.el ends here
- [Emacs-diffs] Changes to emacs/lisp/net/eudc.el,
Pavel Janík <=