diff options
Diffstat (limited to 'lisp/net/eudc.el')
| -rw-r--r-- | lisp/net/eudc.el | 190 |
1 files changed, 52 insertions, 138 deletions
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index bc550fbc113..3c9c01d0f96 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1,4 +1,4 @@ -;;; eudc.el --- Emacs Unified Directory Client +;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ (require 'wid-edit) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-and-compile (if (not (fboundp 'make-overlay)) @@ -68,6 +68,7 @@ (defvar eudc-mode-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) (define-key map "q" 'kill-current-buffer) (define-key map "x" 'kill-current-buffer) (define-key map "f" 'eudc-query-form) @@ -75,7 +76,6 @@ (define-key map "n" 'eudc-move-to-next-record) (define-key map "p" 'eudc-move-to-previous-record) map)) -(set-keymap-parent eudc-mode-map widget-keymap) (defvar mode-popup-menu) @@ -158,25 +158,6 @@ properties on the list." (setq plist (cdr (cdr plist)))) default)) -(if (not (fboundp 'split-string)) - (defun split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (when (string-match pattern string 0) - (if (> (match-beginning 0) 0) - (setq parts (cons (substring string 0 (match-beginning 0)) nil))) - (setq start (match-end 0)) - (while (and (string-match pattern string start) - (> (match-end 0) start)) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0)))) - (nreverse (if (< start (length string)) - (cons (substring string start) parts) - parts))))) - (defun eudc-replace-in-string (str regexp newtext) "Replace all matches in STR for REGEXP with NEWTEXT. Value is the new string." @@ -314,7 +295,7 @@ accordingly. Otherwise it is set to its EUDC default binding" (defun eudc-update-local-variables () "Update all EUDC variables according to their local settings." (interactive) - (mapcar 'eudc-update-variable eudc-local-vars)) + (mapcar #'eudc-update-variable eudc-local-vars)) (eudc-default-set 'eudc-query-function nil) (eudc-default-set 'eudc-list-attributes-function nil) @@ -378,7 +359,7 @@ BEG and END delimit the text which is to be replaced." (let ((replacement)) (setq replacement (completing-read "Multiple matches found; choose one: " - (mapcar 'list choices))) + (mapcar #'list choices))) (delete-region beg end) (insert replacement))) @@ -415,7 +396,7 @@ underscore characters are replaced by spaces." (if match (cdr match) (capitalize - (mapconcat 'identity + (mapconcat #'identity (split-string (symbol-name attribute) "_") " "))))) @@ -432,7 +413,7 @@ if any, is called to print the value in cdr of FIELD." (progn (eval (list (cdr match) val)) (insert "\n")) - (mapcar + (mapc (function (lambda (val-elem) (indent-to col) @@ -598,9 +579,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (setq result (eudc-add-field-to-records (cons (car field) (mapconcat - 'identity + #'identity (cdr field) - "\n")) result))) + "\n")) + result))) ((eq 'duplicate method) (setq result (eudc-distribute-field-on-records field result))))))) @@ -613,12 +595,9 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (mapcar (function (lambda (rec) - (if (eval (cons 'and - (mapcar - (function - (lambda (attr) - (consp (assq attr rec)))) - attrs))) + (if (cl-every (lambda (attr) + (consp (assq attr rec))) + attrs) rec))) records))) @@ -632,25 +611,14 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (defun eudc-distribute-field-on-records (field records) "Duplicate each individual record in RECORDS according to value of FIELD. Each copy is added a new field containing one of the values of FIELD." - (let (result - (values (cdr field))) - ;; Uniquify values first - (while values - (setcdr values (delete (car values) (cdr values))) - (setq values (cdr values))) - (mapc - (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)) - ))) - (cdr field)) + (let (result) + (dolist (value (delete-dups (cdr field))) ;; Uniquify values first. + (setq result (nconc (eudc-add-field-to-records + (cons (car field) value) + records) + result))) result)) - (define-derived-mode eudc-mode special-mode "EUDC" "Major mode used in buffers displaying the results of directory queries. There is no sense in calling this command from a buffer other than @@ -662,9 +630,7 @@ These are the special commands of EUDC mode: n -- Move to next record. p -- Move to previous record. b -- Insert record at point into the BBDB database." - (if (not (featurep 'xemacs)) - (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) - (setq mode-popup-menu (eudc-menu)))) + (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))) ;;}}} @@ -776,8 +742,8 @@ otherwise a list of symbols is returned." (setq query-alist (cdr query-alist))) query) (if eudc-protocol-has-default-query-attributes - (mapconcat 'identity words " ") - (list (cons 'name (mapconcat 'identity words " "))))))) + (mapconcat #'identity words " ") + (list (cons 'name (mapconcat #'identity words " "))))))) (defun eudc-extract-n-word-formats (format-list n) "Extract a list of N-long formats from FORMAT-LIST. @@ -836,7 +802,6 @@ see `eudc-inline-expansion-servers'" "[ \t]+")) query-formats response - response-string response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) @@ -894,20 +859,18 @@ see `eudc-inline-expansion-servers'" (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))))) - (if (> (length response-string) 0) - (setq response-strings - (cons response-string response-strings))) - (setq response (cdr response))) + (dolist (r response) + (let ((response-string + (apply #'format + (car eudc-inline-expansion-format) + (mapcar (function + (lambda (field) + (or (cdr (assq field r)) + ""))) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + (if (> (length response-string) 0) + (push response-string response-strings)))) (if (or (and replace (not eudc-expansion-overwrites-query)) @@ -923,7 +886,7 @@ see `eudc-inline-expansion-servers'" (eudc-select response-strings beg end)) ((eq eudc-multiple-match-handling-method 'all) (delete-region beg end) - (insert (mapconcat 'identity response-strings ", "))) + (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) @@ -943,10 +906,9 @@ queries the server for the existing fields and displays a corresponding form." prompts widget (width 0) - inhibit-read-only pt) (switch-to-buffer buffer) - (setq inhibit-read-only t) + (let ((inhibit-read-only t)) (erase-buffer) (kill-all-local-variables) (make-local-variable 'eudc-form-widget-list) @@ -960,11 +922,10 @@ queries the server for the existing fields and displays a corresponding form." (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") ;; Build the list of prompts (setq prompts (if eudc-use-raw-directory-names - (mapcar 'symbol-name (eudc-translate-attribute-list fields)) + (mapcar #'symbol-name (eudc-translate-attribute-list fields)) (mapcar (function (lambda (field) - (or (and (assq field eudc-user-attribute-names-alist) - (cdr (assq field eudc-user-attribute-names-alist))) + (or (cdr (assq field eudc-user-attribute-names-alist)) (capitalize (symbol-name field))))) fields))) ;; Loop over prompt strings to find the longest one @@ -1008,7 +969,7 @@ queries the server for the existing fields and displays a corresponding form." "Quit") (goto-char pt) (use-local-map widget-keymap) - (widget-setup)) + (widget-setup))) ) (defun eudc-bookmark-server (server protocol) @@ -1177,60 +1138,41 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () - (cond - ((and (featurep 'xemacs) (featurep 'menubar)) - (add-submenu '("Tools") (eudc-menu))) - ((not (featurep 'xemacs)) - (cond - ((fboundp 'easy-menu-create-menu) - (define-key - global-map - [menu-bar tools directory-search] - (cons "Directory Servers" - (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) - ((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 Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr (eudc-menu)))))) - (t - (error "Unknown version of easymenu")))) - )) - + (define-key + global-map + [menu-bar tools directory-search] + (cons "Directory Servers" + (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) ;;; Load time initializations : -;;; Load the options file +;; Load the options file (if (and (not noninteractive) (and (locate-library eudc-options-file) (progn (message "") t)) ; Remove mode line message (not (featurep 'eudc-options-file))) (load eudc-options-file)) -;;; Install the full menu +;; Install the full menu (unless (featurep 'infodock) (eudc-install-menu)) -;;; The following installs a short menu for EUDC at XEmacs startup. +;; The following installs a short menu for EUDC at Emacs startup. ;;;###autoload (defun eudc-load-eudc () "Load the Emacs Unified Directory Client. This does nothing except loading eudc by autoload side-effect." (interactive) + ;; FIXME: By convention, loading a file should "do nothing significant" + ;; since Emacs may occasionally load a file for "frivolous" reasons + ;; (e.g. to find a docstring), so having a function which just loads + ;; the file doesn't seem very useful. nil) ;;;###autoload -(cond - ((not (featurep 'xemacs)) +(progn (defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] @@ -1255,34 +1197,6 @@ This does nothing except loading eudc by autoload side-effect." :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) - (t - (let ((menu '("Directory Servers" - ["Load Hotlist of Servers" eudc-load-eudc t] - ["New Server" eudc-set-server t] - ["---" nil nil] - ["Query with Form" eudc-query-form t] - ["Expand Inline Query" eudc-expand-inline t] - ["---" nil nil] - ["Get Email" eudc-get-email t] - ["Get Phone" eudc-get-phone t]))) - (if (not (featurep 'eudc-autoloads)) - (if (featurep 'xemacs) - (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 Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr menu))))))))))) ;;}}} |