mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

EUDC: Enable lexical binding and do some cleanups

Browse source 
* lisp/net/eudc.el: Enable lexical binding.
(cl-lib): Always require cl-lib, not only when byte compiling.
(eudc-mode-map): Set parent keymap within let form.
(eudc-update-local-variables): Use #' read syntax for function
argument to map function.
(eudc-select): Likewise.
(eudc-format-attribute-name-for-display): Likewise
(eudc-filter-duplicate-attributes): Likewise.
(eudc-format-query): Likewise.
(eudc-expand-inline): Likewise.
(eudc-query-form): Likewise.
(eudc-print-attribute-value): Use mapc instead of mapcar.
(eudc-filter-partial-records): Use cl-every.
(eudc-distribute-field-on-records): Use delete-dups to
simplify function.
(eudc-expand-inline): Replace while with dolist and let form.
(eudc-query-form): Set inhibit-read-only after switching
buffers.  Remove useless and call.
(eudc-load-eudc): Add a FIXME comment.
This commit is contained in:
Stefan Monnier 2018-03-14 20:06:47 -04:00 • committed by Thomas Fitzsimmons
parent 7d0fa6081e
commit 836dce63c3
1 changed files with 45 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

104
lisp/net/eudc.el
View file

@ -1,4 +1,4 @@
;;; eudc.el --- Emacs Unified Directory Client
;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*-
;; Copyright (C) 1998-2018 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)
@ -314,7 +314,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 +378,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 +415,7 @@ underscore characters are replaced by spaces."
(if match
(cdr match)
(capitalize
(mapconcat 'identity
(mapconcat #'identity
(split-string (symbol-name attribute) "_")
" ")))))
@ -432,7 +432,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 +598,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 +614,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 +630,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
@ -776,8 +763,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 +823,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 +880,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 +907,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 +927,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 +943,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 +990,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)
@ -1207,25 +1189,29 @@ queries the server for the existing fields and displays a corresponding form."
;;; 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 XEmacs 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