procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/mh-e: Use cl-lib

Browse source 
Also, use underscore prefixes and defvar in preparation for lexical binding

* lisp/mh-e/mh-acros.el: Require cl-lib instead of cl.
Rename all cl.el uses by adding `cl-` prefix.
(mh-require-cl): Remove.  Not needed any more.  Remove all calls.
(mh-defstruct): Remove.  Replace all uses with cl-defstruct.
(mh-dlet*): New macro.

* lisp/mh-e/mh-comp.el (mh-user-agent-compose): Fold all ignored
optional args into the &rest arg.

* lisp/mh-e/mh-e.el: Require cl-lib instead of using mh-require-cl.
(mh-variants): Don't add-to-list on a local var.

* lisp/mh-e/mh-folder.el (mh-restore-desktop-buffer): Use shorter arg
names that don't collide with global vars.

* lisp/mh-e/mh-mime.el (mh-insert-mime-button):
(mh-insert-mime-security-button): Use mh-dlet*.

* lisp/mh-e/mh-search.el (mh-swish-next-result, mh-grep-next-result)
(mh-namazu-next-result): Use `or`.

* lisp/mh-e/mh-thread.el (mh-thread-generate)
(mh-thread-prune-containers): Use underscore rather than declare+ignore.

* lisp/mh-e/mh-tool-bar.el (mh-tool-bar-define): Use mh-dlet*.
(mh-tool-bar-define): Prefer the more precise \`...\' regexp ops.
Prefer Elisp's `eval-and-compile` over `cl-eval-when`.

* lisp/mh-e/mh-xface.el (mh-picon-get-image): Don't use
mh-funcall-if-exists for ietf-drums-parse-address.
Avoid the use of `cl-return` and hence use plain `defun`.
Replace some `cl-loop` with `dolist`.
This commit is contained in:
Stefan Monnier 2019-08-06 03:56:51 -04:00
parent b06917a491
commit 74b097b61c
21 changed files with 549 additions and 602 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

80
lisp/mh-e/mh-acros.el
View file

@ -40,30 +40,12 @@
;;; Code:
(require 'cl)
(require 'cl-lib)
;;; Compatibility
;; TODO: Replace `cl' with `cl-lib'.
;; `cl' is deprecated in Emacs 24.3. Use `cl-lib' instead. However,
;; we'll likely have to insert `cl-' before each use of a Common Lisp
;; function.
;;;###mh-autoload
(defmacro mh-require-cl ()
"Macro to load \"cl\" if needed.
Emacs coding conventions require that the \"cl\" package not be
required at runtime. However, the \"cl\" package in Emacs 21.4
and earlier left \"cl\" routines in their macro expansions. In
particular, the expansion of (setf (gethash ...) ...) used
functions in \"cl\" at run time. This macro recognizes that and
loads \"cl\" appropriately."
(if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
'(require 'cl)
'(eval-when-compile (require 'cl))))
;;;###mh-autoload
(defmacro mh-do-in-gnu-emacs (&rest body)
"Execute BODY if in GNU Emacs."
@ -81,6 +63,9 @@ loads \"cl\" appropriately."
;;;###mh-autoload
(defmacro mh-funcall-if-exists (function &rest args)
"Call FUNCTION with ARGS as parameters if it exists."
;; FIXME: Not clear when this should be used. If the function happens
;; not to exist at compile-time (e.g. because the corresponding package
;; wasn't loaded), then it won't ever be used :-(
(when (fboundp function)
`(when (fboundp ',function)
(funcall ',function ,@args))))
@ -135,53 +120,6 @@ check if variable `transient-mark-mode' is active."
'(and (boundp 'transient-mark-mode) transient-mark-mode
(boundp 'mark-active) mark-active))))
;; Shush compiler.
(mh-do-in-xemacs
(defvar struct)
(defvar x)
(defvar y))
;;;###mh-autoload
(defmacro mh-defstruct (name-spec &rest fields)
;; FIXME: Use `cl-defstruct' instead: shouldn't emit warnings any
;; more nor depend on run-time CL functions.
"Replacement for `defstruct' from the \"cl\" package.
The `defstruct' in the \"cl\" library produces compiler warnings,
and generates code that uses functions present in \"cl\" at
run-time. This is a partial replacement, that avoids these
issues.
NAME-SPEC declares the name of the structure, while FIELDS
describes the various structure fields. Lookup `defstruct' for
more details."
(let* ((struct-name (if (atom name-spec) name-spec (car name-spec)))
(conc-name (or (and (consp name-spec)
(cadr (assoc :conc-name (cdr name-spec))))
(format "%s-" struct-name)))
(predicate (intern (format "%s-p" struct-name)))
(constructor (or (and (consp name-spec)
(cadr (assoc :constructor (cdr name-spec))))
(intern (format "make-%s" struct-name))))
(fields (mapcar (lambda (x)
(if (atom x)
(list x nil)
(list (car x) (cadr x))))
fields))
(field-names (mapcar #'car fields))
(struct (gensym "S"))
(x (gensym "X"))
(y (gensym "Y")))
`(progn
(defun* ,constructor (&key ,@fields)
(list (quote ,struct-name) ,@field-names))
(defun ,predicate (arg)
(and (consp arg) (eq (car arg) (quote ,struct-name))))
,@(loop for x from 1
for y in field-names
collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z)
(list 'nth ,x z)))
(quote ,struct-name))))
;;;###mh-autoload
(defmacro with-mh-folder-updating (save-modification-flag &rest body)
"Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY).
@ -327,6 +265,16 @@ MH-E functions."
,@body))))))))
(put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
(defmacro mh-dlet* (binders &rest body)
"Like `let*' but always dynamically scoped."
(declare (debug let) (indent 1))
;; Works in both lexical and non-lexical mode.
`(progn
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders)
(let* ,binders ,@body)))
(provide 'mh-acros)
;; Local Variables:

4
lisp/mh-e/mh-alias.el
View file

@ -30,8 +30,6 @@
(require 'mh-e)
(mh-require-cl)
(require 'goto-addr)
(defvar mh-alias-alist 'not-read
@ -308,7 +306,7 @@ Blind aliases or users from /etc/passwd are not expanded."
(if (not mh-alias-expand-aliases-flag)
mh-alias-alist
(lambda (string pred action)
(case action
(cl-case action
((nil)
(let ((res (try-completion string mh-alias-alist pred)))
(if (or (eq res t)

22
lisp/mh-e/mh-comp.el
View file

@ -217,7 +217,7 @@ TO, CC, and SUBJECT arguments are used."
(defvar mh-error-if-no-draft nil) ;raise error over using old draft
;;;###autoload
(defun mh-smail-batch (&optional to subject other-headers &rest ignored)
(defun mh-smail-batch (&optional to subject _other-headers &rest _ignored)
"Compose a message with the MH mail system.
This function does not prompt the user for any header fields, and
@ -239,10 +239,7 @@ applications should use `mh-user-agent-compose'."
'mh-before-send-letter-hook)
;;;###autoload
(defun mh-user-agent-compose (&optional to subject other-headers continue
switch-function yank-action
send-actions return-action
&rest ignored)
(defun mh-user-agent-compose (&optional to subject other-headers &rest _ignored)
"Set up mail composition draft with the MH mail system.
This is the `mail-user-agent' entry point to MH-E. This function
conforms to the contract specified by `define-mail-user-agent'
@ -256,8 +253,7 @@ OTHER-HEADERS is an alist specifying additional header fields.
Elements look like (HEADER . VALUE) where both HEADER and VALUE
are strings.
CONTINUE, SWITCH-FUNCTION, YANK-ACTION, SEND-ACTIONS, and
RETURN-ACTION and any additional arguments are IGNORED."
Any additional arguments are IGNORED."
(mh-find-path)
(let ((mh-error-if-no-draft t))
(mh-send to "" subject)
@ -266,9 +262,7 @@ RETURN-ACTION and any additional arguments are IGNORED."
(cdr (car other-headers)))
(setq other-headers (cdr other-headers)))))
;; Shush compiler.
(mh-do-in-xemacs
(defvar sendmail-coding-system))
(defvar sendmail-coding-system)
;;;###autoload
(defun mh-send-letter (&optional arg)
@ -1297,10 +1291,10 @@ discarded."
"Check if current buffer is entirely composed of ASCII.
The function doesn't work for XEmacs since `find-charset-region'
doesn't exist there."
(loop for charset in (mh-funcall-if-exists
find-charset-region (point-min) (point-max))
unless (eq charset 'ascii) return nil
finally return t))
(cl-loop for charset in (mh-funcall-if-exists
find-charset-region (point-min) (point-max))
unless (eq charset 'ascii) return nil
finally return t))
(provide 'mh-comp)

12
lisp/mh-e/mh-compat.el
View file

@ -143,7 +143,7 @@ introduced in Emacs 22."
`(face-background ,face ,frame ,inherit)))
(defun-mh mh-font-lock-add-keywords font-lock-add-keywords
(mode keywords &optional how)
(_mode _keywords &optional _how)
"XEmacs does not have `font-lock-add-keywords'.
This function returns nil on that system.")
@ -243,7 +243,7 @@ compatibility with versions of Emacs that lack the variable
(delete image-directory (copy-sequence (or path load-path))))))
(defun-mh mh-image-search-load-path
image-search-load-path (file &optional path)
image-search-load-path (_file &optional _path)
"Emacs 21 and XEmacs don't have `image-search-load-path'.
This function returns nil on those systems."
nil)
@ -292,7 +292,7 @@ introduced in Emacs 24."
`(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type))))
(defun-mh mh-match-string-no-properties
match-string-no-properties (num &optional string)
match-string-no-properties (num &optional _string)
"Return string of text matched by last search, without text properties.
This function is used by XEmacs that lacks `match-string-no-properties'.
The function `buffer-substring-no-properties' is used instead.
@ -301,7 +301,7 @@ The argument STRING is ignored."
(match-beginning num) (match-end num)))
(defun-mh mh-replace-regexp-in-string replace-regexp-in-string
(regexp rep string &optional fixedcase literal subexp start)
(regexp rep string &optional _fixedcase literal _subexp _start)
"Replace REGEXP with REP everywhere in STRING and return result.
This function is used by XEmacs that lacks `replace-regexp-in-string'.
The function `replace-in-string' is used instead.
@ -311,7 +311,7 @@ The arguments FIXEDCASE, SUBEXP, and START, used by
(replace-in-string string regexp rep literal)))
(defun-mh mh-test-completion
test-completion (string collection &optional predicate)
test-completion (_string _collection &optional _predicate)
"Return non-nil if STRING is a valid completion.
XEmacs does not have `test-completion'. This function returns nil
on that system." nil)
@ -352,7 +352,7 @@ The arguments RETURN-TO and EXIT-ACTION are ignored."
(view-mode 1))
(defun-mh mh-window-full-height-p
window-full-height-p (&optional WINDOW)
window-full-height-p (&optional _window)
"Return non-nil if WINDOW is not the result of a vertical split.
This function is defined in XEmacs as it lacks
`window-full-height-p'. The values of the functions

103
lisp/mh-e/mh-e.el
View file

@ -91,7 +91,7 @@
;; for if it does it will introduce a require loop.
(require 'mh-loaddefs)
(mh-require-cl)
(require 'cl-lib)
(require 'mh-buffers)
(require 'mh-compat)
@ -496,7 +496,7 @@ all the strings have been used."
(push (buffer-substring-no-properties (point)
(mh-line-end-position))
arg-list)
(incf count)
(cl-incf count)
(forward-line))
(apply #'call-process cmd nil (list out nil) nil
(nreverse arg-list))))
@ -509,8 +509,8 @@ all the strings have been used."
Adds double-quotes around entire string and quotes the characters
\\, `, and $ with a backslash."
(concat "\""
(loop for x across string
concat (format (if (memq x '(?\\ ?` ?$)) "\\%c" "%c") x))
(cl-loop for x across string
concat (format (if (memq x '(?\\ ?` ?$)) "\\%c" "%c") x))
"\""))
(defun mh-exec-cmd (command &rest args)
@ -527,7 +527,7 @@ parsed by MH-E."
(save-excursion
(goto-char start)
(insert "Errors when executing: " command)
(loop for arg in args do (insert " " arg))
(cl-loop for arg in args do (insert " " arg))
(insert "\n"))
(save-window-excursion
(switch-to-buffer-other-window mh-log-buffer)
@ -583,7 +583,7 @@ ARGS are passed to COMMAND as command line arguments."
(push elem process-environment))
(apply #'mh-exec-cmd-daemon command filter args)))
(defun mh-process-daemon (process output)
(defun mh-process-daemon (_process output)
"PROCESS daemon that puts OUTPUT into a temporary buffer.
Any output from the process is displayed in an asynchronous
pop-up window."
@ -683,11 +683,11 @@ ARGS is returned unchanged."
`(if (boundp 'customize-package-emacs-version-alist)
,args
(let (seen)
(loop for keyword in ,args
if (cond ((eq keyword ':package-version) (setq seen t) nil)
(seen (setq seen nil) nil)
(t t))
collect keyword))))
(cl-loop for keyword in ,args
if (cond ((eq keyword ':package-version) (setq seen t) nil)
(seen (setq seen nil) nil)
(t t))
collect keyword))))
(defmacro defgroup-mh (symbol members doc &rest args)
"Declare SYMBOL as a customization group containing MEMBERS.
@ -740,14 +740,14 @@ is described by the variable `mh-variants'."
(let ((list-unique))
;; Make a unique list of directories, keeping the given order.
;; We don't want the same MH variant to be listed multiple times.
(loop for dir in (append mh-path mh-sys-path exec-path) do
(setq dir (file-chase-links (directory-file-name dir)))
(add-to-list 'list-unique dir))
(loop for dir in (nreverse list-unique) do
(when (and dir (file-accessible-directory-p dir))
(let ((variant (mh-variant-info dir)))
(if variant
(add-to-list 'mh-variants variant)))))
(cl-loop for dir in (append mh-path mh-sys-path exec-path) do
(setq dir (file-chase-links (directory-file-name dir)))
(cl-pushnew dir list-unique :test #'equal))
(cl-loop for dir in (nreverse list-unique) do
(when (and dir (file-accessible-directory-p dir))
(let ((variant (mh-variant-info dir)))
(if variant
(add-to-list 'mh-variants variant)))))
mh-variants)))
(defun mh-variant-info (dir)
@ -858,22 +858,22 @@ variant."
mh-progs progs
mh-variant-in-use variant))))
((symbolp variant) ;e.g. 'nmh (pick the first match)
(loop for variant-list in (mh-variants)
when (eq variant (cadr (assoc 'variant (cdr variant-list))))
return (let* ((version (car variant-list))
(alist (cdr variant-list))
(lib-progs (cadr (assoc 'mh-lib-progs alist)))
(lib (cadr (assoc 'mh-lib alist)))
(progs (cadr (assoc 'mh-progs alist)))
(flists (cadr (assoc 'flists alist))))
;;(set-default mh-variant flavor)
(setq mh-x-mailer-string nil
mh-flists-present-flag flists
mh-lib-progs lib-progs
mh-lib lib
mh-progs progs
mh-variant-in-use version)
t)))))
(cl-loop for variant-list in (mh-variants)
when (eq variant (cadr (assoc 'variant (cdr variant-list))))
return (let* ((version (car variant-list))
(alist (cdr variant-list))
(lib-progs (cadr (assoc 'mh-lib-progs alist)))
(lib (cadr (assoc 'mh-lib alist)))
(progs (cadr (assoc 'mh-progs alist)))
(flists (cadr (assoc 'flists alist))))
;;(set-default mh-variant flavor)
(setq mh-x-mailer-string nil
mh-flists-present-flag flists
mh-lib-progs lib-progs
mh-lib lib
mh-progs progs
mh-variant-in-use version)
t)))))
(defun mh-variant-p (&rest variants)
"Return t if variant is any of VARIANTS.
@ -1706,9 +1706,9 @@ The function is always called with SYMBOL bound to
(set symbol value) ;XXX shouldn't this be set-default?
(setq mh-junk-choice
(or value
(loop for element in mh-junk-function-alist
until (executable-find (symbol-name (car element)))
finally return (car element)))))
(cl-loop for element in mh-junk-function-alist
until (executable-find (symbol-name (car element)))
finally return (car element)))))
(defcustom-mh mh-junk-background nil
"If on, spam programs are run in background.
@ -2885,9 +2885,9 @@ removed and entries from `mh-invisible-header-fields' are added."
(when mh-invisible-header-fields-default
;; Remove entries from `mh-invisible-header-fields-default'
(setq fields
(loop for x in fields
unless (member x mh-invisible-header-fields-default)
collect x)))
(cl-loop for x in fields
unless (member x mh-invisible-header-fields-default)
collect x)))
(when (and (boundp 'mh-invisible-header-fields)
mh-invisible-header-fields)
(dolist (x mh-invisible-header-fields)
@ -3605,16 +3605,17 @@ specified colors."
new-spec)
;; Remove entries with min-colors, or delete them if we have
;; fewer colors than they specify.
(loop for entry in (reverse spec) do
(let ((requirement (if (eq (car entry) t)
nil
(assq 'min-colors (car entry)))))
(if requirement
(when (>= cells (nth 1 requirement))
(setq new-spec (cons (cons (delq requirement (car entry))
(cdr entry))
new-spec)))
(setq new-spec (cons entry new-spec)))))
(cl-loop
for entry in (reverse spec) do
(let ((requirement (if (eq (car entry) t)
nil
(assq 'min-colors (car entry)))))
(if requirement
(when (>= cells (nth 1 requirement))
(setq new-spec (cons (cons (delq requirement (car entry))
(cdr entry))
new-spec)))
(setq new-spec (cons entry new-spec)))))
new-spec))))
(defface-mh mh-folder-address

57
lisp/mh-e/mh-folder.el
View file

@ -31,7 +31,6 @@
(require 'mh-e)
(require 'mh-scan)
(mh-require-cl)
;; Dynamically-created functions not found in mh-loaddefs.el.
(autoload 'mh-tool-bar-folder-buttons-init "mh-tool-bar")
@ -80,16 +79,14 @@ the MH mail system."
(add-to-list 'desktop-buffer-mode-handlers
'(mh-folder-mode . mh-restore-desktop-buffer)))
(defun mh-restore-desktop-buffer (desktop-buffer-file-name
desktop-buffer-name
desktop-buffer-misc)
(defun mh-restore-desktop-buffer (_file-name name _misc)
"Restore an MH folder buffer specified in a desktop file.
When desktop creates a buffer, DESKTOP-BUFFER-FILE-NAME holds the
file name to visit, DESKTOP-BUFFER-NAME holds the desired buffer
name, and DESKTOP-BUFFER-MISC holds a list of miscellaneous info
When desktop creates a buffer, FILE-NAME holds the
file name to visit, NAME holds the desired buffer
name, and MISC holds a list of miscellaneous info
used by the `desktop-buffer-mode-handlers' functions."
(mh-find-path)
(mh-visit-folder desktop-buffer-name)
(mh-visit-folder name)
(current-buffer))
@ -932,9 +929,9 @@ many unread messages to skip."
(setq count (1- count)))
(not (car unread-sequence)))
(message "No more unread messages"))
(t (loop for msg in unread-sequence
when (mh-goto-msg msg t) return nil
finally (message "No more unread messages"))))))
(t (cl-loop for msg in unread-sequence
when (mh-goto-msg msg t) return nil
finally (message "No more unread messages"))))))
;;;###mh-autoload
(defun mh-page-msg (&optional lines)
@ -1030,9 +1027,9 @@ many unread messages to skip."
(setq count (1- count)))
(not (car unread-sequence)))
(message "No more unread messages"))
(t (loop for msg in unread-sequence
when (mh-goto-msg msg t) return nil
finally (message "No more unread messages"))))))
(t (cl-loop for msg in unread-sequence
when (mh-goto-msg msg t) return nil
finally (message "No more unread messages"))))))
;;;###mh-autoload
(defun mh-quit ()
@ -1503,7 +1500,7 @@ function doesn't recenter the folder buffer."
(let ((lines-from-end 2))
(save-excursion
(while (> (point-max) (progn (forward-line) (point)))
(incf lines-from-end)))
(cl-incf lines-from-end)))
(recenter (- lines-from-end))))
;; '(4) is the same as C-u prefix argument.
(t (recenter (or arg '(4))))))
@ -1587,10 +1584,11 @@ after the commands are processed."
;; Preserve sequences in destination folder...
(when mh-refile-preserves-sequences-flag
(clrhash dest-map)
(loop for i from (1+ (or last 0))
for msg in (sort (copy-sequence msgs) #'<)
do (loop for seq-name in (gethash msg seq-map)
do (push i (gethash seq-name dest-map))))
(cl-loop
for i from (1+ (or last 0))
for msg in (sort (copy-sequence msgs) #'<)
do (cl-loop for seq-name in (gethash msg seq-map)
do (push i (gethash seq-name dest-map))))
(maphash
#'(lambda (seq msgs)
;; Can't be run in the background, since the
@ -1639,10 +1637,10 @@ after the commands are processed."
(mh-delete-scan-msgs mh-whitelist)
(when mh-whitelist-preserves-sequences-flag
(clrhash white-map)
(loop for i from (1+ (or last 0))
for msg in (sort (copy-sequence mh-whitelist) #'<)
do (loop for seq-name in (gethash msg seq-map)
do (push i (gethash seq-name white-map))))
(cl-loop for i from (1+ (or last 0))
for msg in (sort (copy-sequence mh-whitelist) #'<)
do (cl-loop for seq-name in (gethash msg seq-map)
do (push i (gethash seq-name white-map))))
(maphash
#'(lambda (seq msgs)
;; Can't be run in background, since the current
@ -1922,10 +1920,11 @@ exist."
(from (or (message-fetch-field "from") ""))
folder-name)
(setq folder-name
(loop for list in mh-default-folder-list
when (string-match (nth 0 list) (if (nth 2 list) to/cc from))
return (nth 1 list)
finally return nil))
(cl-loop for list in mh-default-folder-list
when (string-match (nth 0 list)
(if (nth 2 list) to/cc from))
return (nth 1 list)
finally return nil))
;; Make sure a result from `mh-default-folder-list' begins with "+"
;; since 'mh-expand-file-name below depends on it
@ -2026,8 +2025,8 @@ If MSG is nil then act on the message at point"
(t
(dolist (folder-msg-list mh-refile-list)
(setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list))))
(setq mh-refile-list (loop for x in mh-refile-list
unless (null (cdr x)) collect x))))
(setq mh-refile-list (cl-loop for x in mh-refile-list
unless (null (cdr x)) collect x))))
(mh-notate nil ? mh-cmd-note)))
;;;###mh-autoload

2
lisp/mh-e/mh-funcs.el
View file

@ -123,7 +123,7 @@ folder. This is useful for folders that are easily regenerated."
(message "Folder %s removed" folder))
(message "Folder not removed")))
(defun mh-rmf-daemon (process output)
(defun mh-rmf-daemon (_process output)
"The rmf PROCESS puts OUTPUT in temporary buffer.
Display the results only if something went wrong."
(set-buffer (get-buffer-create mh-temp-buffer))

8
lisp/mh-e/mh-gnus.el
View file

@ -79,7 +79,7 @@
;; Function from mm-decode.el used in PGP messages. Just define it with older
;; Gnus to avoid compiler warning.
(defun-mh mh-mm-possibly-verify-or-decrypt
mm-possibly-verify-or-decrypt (parts ctl)
mm-possibly-verify-or-decrypt (_parts _ctl)
nil)
;; Copy of macro in mm-decode.el.
@ -110,16 +110,16 @@
(and (> (current-column) length)
(current-column))))
(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (handle)
(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (_handle)
;; Released Gnus doesn't keep handles associated with externally displayed
;; MIME parts. So this will always return nil.
nil)
(defun-mh mh-mm-destroy-parts mm-destroy-parts (list)
(defun-mh mh-mm-destroy-parts mm-destroy-parts (_list)
"Older versions of Emacs don't have this function."
nil)
(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (handles)
(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (_handles)
"Emacs 21 and XEmacs don't have this function."
nil)

6
lisp/mh-e/mh-identity.el
View file

@ -205,7 +205,7 @@ See `mh-identity-list'."
(setq mh-identity-local identity))))
;;;###mh-autoload
(defun mh-identity-handler-gpg-identity (field action &optional value)
(defun mh-identity-handler-gpg-identity (_field action &optional value)
"Process header FIELD \":pgg-default-user-id\".
The ACTION is one of `remove' or `add'. If `add', the VALUE is added.
The buffer-local variable `mh-identity-pgg-default-user-id' is set to
@ -219,7 +219,7 @@ VALUE when action `add' is selected."
(setq mh-identity-pgg-default-user-id value))))
;;;###mh-autoload
(defun mh-identity-handler-signature (field action &optional value)
(defun mh-identity-handler-signature (_field action &optional value)
"Process header FIELD \":signature\".
The ACTION is one of `remove' or `add'. If `add', the VALUE is
added."
@ -250,7 +250,7 @@ added."
"Marker for the end of the attribution verb.")
;;;###mh-autoload
(defun mh-identity-handler-attribution-verb (field action &optional value)
(defun mh-identity-handler-attribution-verb (_field action &optional value)
"Process header FIELD \":attribution-verb\".
The ACTION is one of `remove' or `add'. If `add', the VALUE is
added."

15
lisp/mh-e/mh-inc.el
View file

@ -33,7 +33,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(defvar mh-inc-spool-map-help nil
"Help text for `mh-inc-spool-map'.")
@ -51,13 +50,13 @@
"Make all commands and defines keys for contents of `mh-inc-spool-list'."
(setq mh-inc-spool-map-help nil)
(when mh-inc-spool-list
(loop for elem in mh-inc-spool-list
do (let ((spool (nth 0 elem))
(folder (nth 1 elem))
(key (nth 2 elem)))
(progn
(mh-inc-spool-generator folder spool)
(mh-inc-spool-def-key key folder))))))
(cl-loop for elem in mh-inc-spool-list
do (let ((spool (nth 0 elem))
(folder (nth 1 elem))
(key (nth 2 elem)))
(progn
(mh-inc-spool-generator folder spool)
(mh-inc-spool-def-key key folder))))))
(defalias 'mh-inc-spool-make-no-autoload 'mh-inc-spool-make)

1
lisp/mh-e/mh-junk.el
View file

@ -32,7 +32,6 @@
(require 'mh-e)
(require 'mh-scan)
(mh-require-cl)
;;;###mh-autoload
(defun mh-junk-blacklist (range)

27
lisp/mh-e/mh-limit.el
View file

@ -30,7 +30,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(require 'mh-scan)
(autoload 'message-fetch-field "message")
@ -126,8 +125,8 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
(mh-quote-pick-expr (mh-current-message-header-field 'subject)))))
(setq pick-expr
(let ((case-fold-search t))
(loop for s in pick-expr
collect (mh-replace-regexp-in-string "re: *" "" s))))
(cl-loop for s in pick-expr
collect (mh-replace-regexp-in-string "re: *" "" s))))
(mh-narrow-to-header-field 'subject pick-expr))
;;;###mh-autoload
@ -249,7 +248,7 @@ Return number of messages put in the sequence:
(defun mh-edit-pick-expr (default)
"With prefix arg edit a pick expression.
If no prefix arg is given, then return DEFAULT."
(let ((default-string (loop for x in default concat (format " %s" x))))
(let ((default-string (cl-loop for x in default concat (format " %s" x))))
(if (or current-prefix-arg (equal default-string ""))
(mh-pick-args-list (read-string "Pick expression: "
default-string))
@ -291,18 +290,18 @@ For example, the string \"-subject a b c -from Joe User
(let* ((field (or (message-fetch-field (format "%s" header-field))
""))
(field-option (format "-%s" header-field))
(patterns (loop for x in (split-string field "[ ]*,[ ]*")
unless (equal x "")
collect (if (string-match "<\\(.*@.*\\)>" x)
(match-string 1 x)
x))))
(patterns (cl-loop for x in (split-string field "[ ]*,[ ]*")
unless (equal x "")
collect (if (string-match "<\\(.*@.*\\)>" x)
(match-string 1 x)
x))))
(when patterns
(loop with accum = `(,field-option ,(car patterns))
for e in (cdr patterns)
do (setq accum `(,field-option ,e "-or" ,@accum))
finally return accum))))))))
(cl-loop with accum = `(,field-option ,(car patterns))
for e in (cdr patterns)
do (setq accum `(,field-option ,e "-or" ,@accum))
finally return accum))))))))
(defun mh-narrow-to-header-field (header-field pick-expr)
(defun mh-narrow-to-header-field (_header-field pick-expr)
"Limit to messages whose HEADER-FIELD match PICK-EXPR.
The MH command pick is used to do the match."
(let ((folder mh-current-folder)

129
lisp/mh-e/mh-mime.el
View file

@ -77,7 +77,7 @@
'(gethash (current-buffer) mh-globals-hash))
;; Structure to keep track of MIME handles on a per buffer basis.
(mh-defstruct (mh-buffer-data (:conc-name mh-mime-)
(cl-defstruct (mh-buffer-data (:conc-name mh-mime-)
(:constructor mh-make-buffer-data))
(handles ()) ; List of MIME handles
(handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of
@ -611,7 +611,7 @@ If message has been encoded for transfer take that into account."
"Choose among the alternatives, HANDLES the part that will be displayed.
If no part is preferred then all the parts are displayed."
(let* ((preferred (mm-preferred-alternative handles))
(others (loop for x in handles unless (eq x preferred) collect x)))
(others (cl-loop for x in handles unless (eq x preferred) collect x)))
(cond ((and preferred
(stringp (car preferred)))
(mh-mime-display-part preferred)
@ -770,7 +770,7 @@ buttons need to be displayed multiple times (for instance when
nested messages are opened)."
(or (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
(setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
(incf (mh-mime-parts-count (mh-buffer-data))))))
(cl-incf (mh-mime-parts-count (mh-buffer-data))))))
(defun mh-small-image-p (handle)
"Decide whether HANDLE is a \"small\" image that can be displayed inline.
@ -839,9 +839,7 @@ being used to highlight the signature in a MIME part."
;; Shush compiler.
(mh-do-in-xemacs
(defvar dots)
(defvar type)
(defvar ov))
(defvar ov))
(defun mh-insert-mime-button (handle index displayed)
"Insert MIME button for HANDLE.
@ -857,23 +855,27 @@ by commands like \"K v\" which operate on individual MIME parts."
(mail-content-type-get (mm-handle-type handle) 'url)
""))
(type (mm-handle-media-type handle))
(description (mail-decode-encoded-word-string
(or (mm-handle-description handle) "")))
(dots (if (or displayed (mm-handle-displayed-p handle)) " " "..."))
long-type begin end)
begin end)
(if (string-match ".*/" name) (setq name (substring name (match-end 0))))
(setq long-type (concat type (and (not (equal name ""))
(concat "; " name))))
(unless (equal description "")
(setq long-type (concat " --- " long-type)))
(unless (bolp) (insert "\n"))
(setq begin (point))
(gnus-eval-format
mh-mime-button-line-format mh-mime-button-line-format-alist
`(,@(mh-gnus-local-map-property mh-mime-button-map)
;; These vars are passed by dynamic-scoping to
;; mh-mime-button-line-format-alist via gnus-eval-format.
(mh-dlet* ((index index)
(description (mail-decode-encoded-word-string
(or (mm-handle-description handle) "")))
(dots (if (or displayed (mm-handle-displayed-p handle))
" " "..."))
(long-type (concat type (and (not (equal name ""))
(concat "; " name)))))
(unless (equal description "")
(setq long-type (concat " --- " long-type)))
(unless (bolp) (insert "\n"))
(setq begin (point))
(gnus-eval-format
mh-mime-button-line-format mh-mime-button-line-format-alist
`(,@(mh-gnus-local-map-property mh-mime-button-map)
mh-callback mh-mm-display-part
mh-part ,index
mh-data ,handle))
mh-data ,handle)))
(setq end (point))
(widget-convert-button
'link begin end
@ -888,8 +890,6 @@ by commands like \"K v\" which operate on individual MIME parts."
;; Shush compiler.
(defvar mm-verify-function-alist) ; < Emacs 22
(defvar mm-decrypt-function-alist) ; < Emacs 22
(mh-do-in-xemacs
(defvar pressed-details))
(defun mh-insert-mime-security-button (handle)
"Display buttons for PGP message, HANDLE."
@ -897,42 +897,47 @@ by commands like \"K v\" which operate on individual MIME parts."
(crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist))
(nth 2 (assoc protocol mm-decrypt-function-alist))
"Unknown"))
(type (concat crypto-type
(if (equal (car handle) "multipart/signed")
" Signed" " Encrypted")
" Part"))
(info (or (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
"Undecided"))
(details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details))
pressed-details begin end face)
(setq details (if details (concat "\n" details) ""))
(setq pressed-details (if mh-mime-security-button-pressed details ""))
(setq face (mh-mime-security-button-face info))
(unless (bolp) (insert "\n"))
(setq begin (point))
(gnus-eval-format
mh-mime-security-button-line-format
mh-mime-security-button-line-format-alist
`(,@(mh-gnus-local-map-property mh-mime-security-button-map)
begin end face)
;; These vars are passed by dynamic-scoping to
;; mh-mime-security-button-line-format-alist via gnus-eval-format.
(mh-dlet* ((type (concat crypto-type
(if (equal (car handle) "multipart/signed")
" Signed" " Encrypted")
" Part"))
(info (or (mh-mm-handle-multipart-ctl-parameter
handle 'gnus-info)
"Undecided"))
(details (mh-mm-handle-multipart-ctl-parameter
handle 'gnus-details))
pressed-details)
(setq details (if details (concat "\n" details) ""))
(setq pressed-details (if mh-mime-security-button-pressed details ""))
(setq face (mh-mime-security-button-face info))
(unless (bolp) (insert "\n"))
(setq begin (point))
(gnus-eval-format
mh-mime-security-button-line-format
mh-mime-security-button-line-format-alist
`(,@(mh-gnus-local-map-property mh-mime-security-button-map)
mh-button-pressed ,mh-mime-security-button-pressed
mh-callback mh-mime-security-press-button
mh-line-format ,mh-mime-security-button-line-format
mh-data ,handle))
(setq end (point))
(widget-convert-button 'link begin end
:mime-handle handle
:action 'mh-widget-press-button
:button-keymap mh-mime-security-button-map
:button-face face
:help-echo "Mouse-2 click or press RET (in show buffer) to see security details.")
(dolist (ov (mh-funcall-if-exists overlays-in begin end))
(mh-funcall-if-exists overlay-put ov 'evaporate t))
(when (equal info "Failed")
(let* ((type (if (equal (car handle) "multipart/signed")
"verification" "decryption"))
(warning (if (equal type "decryption")
"(passphrase may be incorrect)" "")))
(message "%s %s failed %s" crypto-type type warning)))))
(setq end (point))
(widget-convert-button 'link begin end
:mime-handle handle
:action 'mh-widget-press-button
:button-keymap mh-mime-security-button-map
:button-face face
:help-echo "Mouse-2 click or press RET (in show buffer) to see security details.")
(dolist (ov (mh-funcall-if-exists overlays-in begin end))
(mh-funcall-if-exists overlay-put ov 'evaporate t))
(when (equal info "Failed")
(let* ((type (if (equal (car handle) "multipart/signed")
"verification" "decryption"))
(warning (if (equal type "decryption")
"(passphrase may be incorrect)" "")))
(message "%s %s failed %s" crypto-type type warning))))))
(defun mh-mime-security-button-face (info)
"Return the button face to use for encrypted/signed mail based on INFO."
@ -995,7 +1000,7 @@ If CRITERION is a function or a symbol which has a function binding
then that function must return non-nil at the button we stop."
(unless (or (and (symbolp criterion) (fboundp criterion))
(functionp criterion))
(setq criterion (lambda (x) t)))
(setq criterion (lambda (_) t)))
;; Move to the next button in the buffer satisfying criterion
(goto-char (or (save-excursion
(beginning-of-line)
@ -1015,7 +1020,7 @@ then that function must return non-nil at the button we stop."
(not (if backward-flag (bobp) (eobp))))
(forward-line (if backward-flag -1 1)))
;; Stop at next MIME button if any exists.
(block loop
(cl-block loop
(while (/= (progn
(unless (= (forward-line
(if backward-flag -1 1))
@ -1028,11 +1033,11 @@ then that function must return non-nil at the button we stop."
point-before-current-button)
(when (and (get-text-property (point) 'mh-data)
(funcall criterion (point)))
(return-from loop (point))))
(cl-return-from loop (point))))
nil)))
(point))))
(defun mh-widget-press-button (widget el)
(defun mh-widget-press-button (widget _el)
"Callback for widget, WIDGET.
Parameter EL is unused."
(goto-char (widget-get widget :from))
@ -1596,7 +1601,7 @@ the possible security methods (see `mh-mml-method-default')."
nil t nil 'mh-mml-cryptographic-method-history def))
mh-mml-method-default))
(defun mh-secure-message (method mode &optional identity)
(defun mh-secure-message (method mode &optional _identity)
"Add tag to encrypt or sign message.
METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\".
@ -1697,19 +1702,19 @@ buffer, while END defaults to the end of the buffer."
(unless begin (setq begin (point-min)))
(unless end (setq end (point-max)))
(save-excursion
(block search-for-mh-directive
(cl-block search-for-mh-directive
(goto-char begin)
(while (re-search-forward "^#" end t)
(let ((s (buffer-substring-no-properties
(point) (mh-line-end-position))))
(cond ((equal s ""))
((string-match "^forw[ \t\n]+" s)
(return-from search-for-mh-directive t))
(cl-return-from search-for-mh-directive t))
(t (let ((first-token (car (split-string s "[ \t;@]"))))
(when (and first-token
(string-match mh-media-type-regexp
first-token))
(return-from search-for-mh-directive t)))))))
(cl-return-from search-for-mh-directive t)))))))
nil)))
(defun mh-minibuffer-read-type (filename &optional default)

266
lisp/mh-e/mh-search.el
View file

@ -44,7 +44,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(require 'gnus-util)
(require 'imenu)
@ -227,17 +226,17 @@ folder containing the index search results."
mh-search-regexp-builder)
(current-window-configuration)
nil)))
(block mh-search
(cl-block mh-search
;; Redoing a sequence search?
(when (and redo-search-flag mh-index-data mh-index-sequence-search-flag
(not mh-flists-called-flag))
(let ((mh-flists-called-flag t))
(apply #'mh-index-sequenced-messages mh-index-previous-search))
(return-from mh-search))
(cl-return-from mh-search))
;; We have fancy query parsing.
(when (symbolp search-regexp)
(mh-search-folder folder window-config)
(return-from mh-search))
(cl-return-from mh-search))
;; Begin search proper.
(mh-checksum-choose)
(let ((result-count 0)
@ -264,21 +263,22 @@ folder containing the index search results."
;; Parse searcher output.
(message "Processing %s output... " mh-searcher)
(goto-char (point-min))
(loop for next-result = (funcall mh-search-next-result-function)
while next-result
do (unless (eq next-result 'error)
(unless (gethash (car next-result) folder-results-map)
(setf (gethash (car next-result) folder-results-map)
(make-hash-table :test #'equal)))
(setf (gethash (cadr next-result)
(gethash (car next-result) folder-results-map))
t)))
(cl-loop for next-result = (funcall mh-search-next-result-function)
while next-result
do (unless (eq next-result 'error)
(unless (gethash (car next-result) folder-results-map)
(setf (gethash (car next-result) folder-results-map)
(make-hash-table :test #'equal)))
(setf (gethash (cadr next-result)
(gethash (car next-result) folder-results-map))
t)))
;; Copy the search results over.
(maphash #'(lambda (folder msgs)
(let ((cur (car (mh-translate-range folder "cur")))
(msgs (sort (loop for msg being the hash-keys of msgs
collect msg)
(msgs (sort (cl-loop
for msg being the hash-keys of msgs
collect msg)
#'<)))
(mh-exec-cmd "refile" msgs "-src" folder
"-link" index-folder)
@ -287,10 +287,10 @@ folder containing the index search results."
(mh-exec-cmd-quiet nil "mark" folder "-add" "-zero"
"-sequence"
"cur" (format "%s" cur)))
(loop for msg in msgs
do (incf result-count)
(setf (gethash result-count origin-map)
(cons folder msg)))))
(cl-loop for msg in msgs
do (cl-incf result-count)
(setf (gethash result-count origin-map)
(cons folder msg)))))
folder-results-map)
;; Vist the results folder.
@ -315,14 +315,14 @@ folder containing the index search results."
(message "%s found %s matches in %s folders"
(upcase-initials (symbol-name mh-searcher))
(loop for msg-hash being the hash-values of mh-index-data
sum (hash-table-count msg-hash))
(loop for msg-hash being the hash-values of mh-index-data
count (> (hash-table-count msg-hash) 0)))))))
(cl-loop for msg-hash being the hash-values of mh-index-data
sum (hash-table-count msg-hash))
(cl-loop for msg-hash being the hash-values of mh-index-data
count (> (hash-table-count msg-hash) 0)))))))
;; Shush compiler.
(mh-do-in-xemacs
(defvar pick-folder))
(defvar pick-folder)) ;FIXME: Why?
(defun mh-search-folder (folder window-config)
"Search FOLDER for messages matching a pattern.
@ -331,6 +331,7 @@ In a program, argument WINDOW-CONFIG is the current window
configuration and is used when the search folder is dismissed."
(interactive (list (mh-prompt-for-folder "Search" mh-current-folder nil nil t)
(current-window-configuration)))
;; FIXME: `pick-folder' is unused!
(let ((pick-folder (if (equal folder "+") mh-current-folder folder)))
(switch-to-buffer-other-window "search-pattern")
(if (or (zerop (buffer-size))
@ -401,10 +402,8 @@ or nothing to search all folders."
mh-ticked-messages-folders)))
(mh-index-sequenced-messages folders mh-tick-seq))
;; Shush compiler.
(mh-do-in-xemacs
(defvar mh-mairix-folder)
(defvar mh-flists-search-folders))
(defvar mh-mairix-folder)
(defvar mh-flists-search-folders)
;;;###mh-autoload
(defun mh-index-sequenced-messages (folders sequence)
@ -471,9 +470,9 @@ recursively. All arguments are IGNORED."
(mh-quote-for-shell mh-inbox))
((eq mh-flists-search-folders nil) "")
((listp mh-flists-search-folders)
(loop for folder in mh-flists-search-folders
concat
(concat " " (mh-quote-for-shell folder)))))
(cl-loop for folder in mh-flists-search-folders
concat
(concat " " (mh-quote-for-shell folder)))))
(if mh-recursive-folders-flag " -recurse" "")
" -sequence " seq " -noshowzero -fast` ; do\n"
(expand-file-name "mhpath" mh-progs) " \"+$folder\" " seq "\n"
@ -536,8 +535,9 @@ group of results."
(when (or (not (get-buffer folder))
(y-or-n-p (format "Reuse buffer displaying %s? " folder)))
(mh-visit-folder
folder (loop for x being the hash-keys of (gethash folder mh-index-data)
when (mh-msg-exists-p x folder) collect x)))))
folder (cl-loop
for x being the hash-keys of (gethash folder mh-index-data)
when (mh-msg-exists-p x folder) collect x)))))
@ -716,7 +716,7 @@ parsed."
((equal token "or") (push 'or op-stack))
((equal token "and") (push 'and op-stack))
((equal token ")")
(multiple-value-setq (op-stack operand-stack)
(cl-multiple-value-setq (op-stack operand-stack)
(cl-values-list (mh-index-evaluate op-stack operand-stack)))
(when (eq (car op-stack) 'not)
(setq op-stack (cdr op-stack))
@ -762,12 +762,12 @@ parsed."
(defun mh-index-evaluate (op-stack operand-stack)
"Read expression till starting paren based on OP-STACK and OPERAND-STACK."
(block mh-index-evaluate
(cl-block mh-index-evaluate
(let (op oper1)
(while op-stack
(setq op (pop op-stack))
(cond ((eq op 'paren)
(return-from mh-index-evaluate (list op-stack operand-stack)))
(cl-return-from mh-index-evaluate (list op-stack operand-stack)))
((eq op 'not)
(push `(not ,(pop operand-stack)) operand-stack))
((or (eq op 'and) (eq op 'or))
@ -806,7 +806,7 @@ The side-effects of this function are that the variables
searcher in `mh-search-choices' present on the system. If
optional argument SEARCHER is present, use it instead of
`mh-search-program'."
(block nil
(cl-block nil
(let ((program-alist (cond (searcher
(list (assoc searcher mh-search-choices)))
(mh-search-program
@ -821,7 +821,7 @@ optional argument SEARCHER is present, use it instead of
(setq mh-search-function (nth 2 current))
(setq mh-search-next-result-function (nth 3 current))
(setq mh-search-regexp-builder (nth 4 current))
(return mh-searcher))))
(cl-return mh-searcher))))
nil)))
;;; Swish++
@ -974,31 +974,31 @@ is used to search."
(defun mh-swish-next-result ()
"Get the next result from swish output."
(prog1
(block nil
(cl-block nil
(when (or (eobp) (equal (char-after (point)) ?.))
(return nil))
(cl-return nil))
(when (equal (char-after (point)) ?#)
(return 'error))
(cl-return 'error))
(let* ((start (search-forward " " (mh-line-end-position) t))
(end (search-forward " " (mh-line-end-position) t)))
(unless (and start end)
(return 'error))
(cl-return 'error))
(setq end (1- end))
(unless (file-exists-p (buffer-substring-no-properties start end))
(return 'error))
(cl-return 'error))
(unless (search-backward "/" start t)
(return 'error))
(cl-return 'error))
(list (let* ((s (buffer-substring-no-properties start (1+ (point)))))
(unless (string-match mh-swish-folder s)
(return 'error))
(cl-return 'error))
(if (and (string-match mh-user-path s)
(< (match-end 0) (1- (length s))))
(format "+%s"
(substring s (match-end 0) (1- (length s))))
(return 'error)))
(cl-return 'error)))
(let* ((s (buffer-substring-no-properties (1+ (point)) end))
(n (ignore-errors (string-to-number s))))
(if n n (return 'error)))
(or n (cl-return 'error)))
nil)))
(forward-line)))
@ -1051,26 +1051,26 @@ SEARCH-REGEXP-LIST is used to search."
(defun mh-mairix-next-result ()
"Return next result from mairix output."
(prog1
(block nil
(cl-block nil
(when (or (eobp) (and (bolp) (eolp)))
(return nil))
(cl-return nil))
(unless (eq (char-after) ?/)
(return 'error))
(cl-return 'error))
(let ((start (point))
end msg-start)
(setq end (mh-line-end-position))
(unless (search-forward mh-mairix-folder end t)
(return 'error))
(cl-return 'error))
(goto-char (match-beginning 0))
(unless (equal (point) start)
(return 'error))
(cl-return 'error))
(goto-char end)
(unless (search-backward "/" start t)
(return 'error))
(cl-return 'error))
(setq msg-start (1+ (point)))
(goto-char start)
(unless (search-forward mh-user-path end t)
(return 'error))
(cl-return 'error))
(list (format "+%s" (buffer-substring-no-properties
(point) (1- msg-start)))
(string-to-number
@ -1119,8 +1119,8 @@ REGEXP-LIST is an alist of fields and values."
(cond ((atom expr) `(or (and ,expr)))
((eq (car expr) 'or)
(cons 'or
(loop for e in (mapcar #'mh-mairix-convert-to-sop* (cdr expr))
append (cdr e))))
(cl-loop for e in (mapcar #'mh-mairix-convert-to-sop* (cdr expr))
append (cdr e))))
((eq (car expr) 'and)
(let ((conjuncts (mapcar #'mh-mairix-convert-to-sop* (cdr expr)))
result next-factor)
@ -1196,22 +1196,22 @@ is used to search."
(defun mh-namazu-next-result ()
"Get the next result from namazu output."
(prog1
(block nil
(when (eobp) (return nil))
(cl-block nil
(when (eobp) (cl-return nil))
(let ((file-name (buffer-substring-no-properties
(point) (mh-line-end-position))))
(unless (equal (string-match mh-namazu-folder file-name) 0)
(return 'error))
(cl-return 'error))
(unless (file-exists-p file-name)
(return 'error))
(cl-return 'error))
(string-match mh-user-path file-name)
(let* ((folder/msg (substring file-name (match-end 0)))
(mark (mh-search-from-end ?/ folder/msg)))
(unless mark (return 'error))
(unless mark (cl-return 'error))
(list (format "+%s" (substring folder/msg 0 mark))
(let ((n (ignore-errors (string-to-number
(substring folder/msg (1+ mark))))))
(if n n (return 'error)))
(or n (cl-return 'error)))
nil))))
(forward-line)))
@ -1235,25 +1235,25 @@ is used to search."
(erase-buffer)
(let ((folders
(mh-folder-list (substring folder-path (length mh-user-path)))))
(loop for folder in folders do
(setq folder (concat "+" folder))
(insert folder "\n")
(apply #'call-process (expand-file-name "pick" mh-progs)
nil '(t nil) nil folder "-list" search-regexp)))
(cl-loop for folder in folders do
(setq folder (concat "+" folder))
(insert folder "\n")
(apply #'call-process (expand-file-name "pick" mh-progs)
nil '(t nil) nil folder "-list" search-regexp)))
(goto-char (point-min)))
(defun mh-pick-next-result ()
"Return the next pick search result."
(prog1
(block nil
(when (eobp) (return nil))
(cl-block nil
(when (eobp) (cl-return nil))
(when (search-forward-regexp "^\\+" (mh-line-end-position) t)
(setq mh-index-pick-folder
(buffer-substring-no-properties (mh-line-beginning-position)
(mh-line-end-position)))
(return 'error))
(cl-return 'error))
(unless (search-forward-regexp "^[1-9][0-9]*$" (mh-line-end-position) t)
(return 'error))
(cl-return 'error))
(list mh-index-pick-folder
(string-to-number
(buffer-substring-no-properties (mh-line-beginning-position)
@ -1331,29 +1331,29 @@ Parse it and return the message folder, message index and the
match. If no other matches left then return nil. If the current
record is invalid return 'error."
(prog1
(block nil
(cl-block nil
(when (eobp)
(return nil))
(cl-return nil))
(let ((eol-pos (mh-line-end-position))
(bol-pos (mh-line-beginning-position))
folder-start msg-end)
(goto-char bol-pos)
(unless (search-forward mh-user-path eol-pos t)
(return 'error))
(cl-return 'error))
(setq folder-start (point))
(unless (search-forward ":" eol-pos t)
(return 'error))
(cl-return 'error))
(let ((match (buffer-substring-no-properties (point) eol-pos)))
(forward-char -1)
(setq msg-end (point))
(unless (search-backward "/" folder-start t)
(return 'error))
(cl-return 'error))
(list (format "+%s" (buffer-substring-no-properties
folder-start (point)))
(let ((n (ignore-errors (string-to-number
(buffer-substring-no-properties
(1+ (point)) msg-end)))))
(if n n (return 'error)))
(or n (cl-return 'error)))
match))))
(forward-line)))
@ -1369,13 +1369,14 @@ being the list of messages originally from that folder."
(save-excursion
(goto-char (point-min))
(let ((result-table (make-hash-table :test #'equal)))
(loop for msg being the hash-keys of mh-index-msg-checksum-map
do (push msg (gethash (car (gethash
(gethash msg mh-index-msg-checksum-map)
mh-index-checksum-origin-map))
result-table)))
(loop for x being the hash-keys of result-table
collect (cons x (nreverse (gethash x result-table)))))))
(cl-loop for msg being the hash-keys of mh-index-msg-checksum-map
do (push msg (gethash (car (gethash
(gethash msg
mh-index-msg-checksum-map)
mh-index-checksum-origin-map))
result-table)))
(cl-loop for x being the hash-keys of result-table
collect (cons x (nreverse (gethash x result-table)))))))
;;;###mh-autoload
(defun mh-index-insert-folder-headers ()
@ -1443,9 +1444,7 @@ being the list of messages originally from that folder."
"Non-nil means that this folder was generated by searching."
mh-index-data)
;; Shush compiler
(mh-do-in-xemacs
(defvar mh-speed-flists-inhibit-flag))
(defvar mh-speed-flists-inhibit-flag)
;;;###mh-autoload
(defun mh-index-execute-commands ()
@ -1478,23 +1477,24 @@ buffer."
(setq mh-refile-list
(mapcar (lambda (x)
(cons (car x)
(loop for y in (cdr x)
unless (memq y msgs) collect y)))
(cl-loop for y in (cdr x)
unless (memq y msgs)
collect y)))
old-refile-list)
mh-delete-list
(loop for x in old-delete-list
unless (memq x msgs) collect x)
(cl-loop for x in old-delete-list
unless (memq x msgs) collect x)
mh-blacklist
(loop for x in old-blacklist
unless (memq x msgs) collect x)
(cl-loop for x in old-blacklist
unless (memq x msgs) collect x)
mh-whitelist
(loop for x in old-whitelist
unless (memq x msgs) collect x))
(cl-loop for x in old-whitelist
unless (memq x msgs) collect x))
(mh-set-folder-modified-p (mh-outstanding-commands-p))
(when (mh-outstanding-commands-p)
(mh-notate-deleted-and-refiled)))))))
(mh-index-matching-source-msgs (append (loop for x in mh-refile-list
append (cdr x))
(mh-index-matching-source-msgs (append (cl-loop for x in mh-refile-list
append (cdr x))
mh-delete-list
mh-blacklist
mh-whitelist)
@ -1565,12 +1565,12 @@ If the folder returned doesn't exist then it is created."
(unless (mh-folder-name-p name)
(error "The argument should be a valid MH folder name"))
(let ((chosen-name
(loop for i from 1
for candidate = (if (equal i 1) name (format "%s-%s" name i))
when (or (not (mh-folder-exists-p candidate))
(equal (mh-index-folder-search-regexp candidate)
search-regexp))
return candidate)))
(cl-loop for i from 1
for candidate = (if (equal i 1) name (format "%s-%s" name i))
when (or (not (mh-folder-exists-p candidate))
(equal (mh-index-folder-search-regexp candidate)
search-regexp))
return candidate)))
;; Do pending refiles/deletes...
(when (get-buffer chosen-name)
(mh-process-or-undo-commands chosen-name))
@ -1603,37 +1603,37 @@ garbled."
"Mirror sequences present in source folders in index folder."
(let ((seq-hash (make-hash-table :test #'equal))
(seq-list ()))
(loop for folder being the hash-keys of mh-index-data
do (setf (gethash folder seq-hash)
(mh-create-sequence-map
(mh-read-folder-sequences folder nil))))
(cl-loop for folder being the hash-keys of mh-index-data
do (setf (gethash folder seq-hash)
(mh-create-sequence-map
(mh-read-folder-sequences folder nil))))
(dolist (msg (mh-translate-range mh-current-folder "all"))
(let* ((checksum (gethash msg mh-index-msg-checksum-map))
(pair (gethash checksum mh-index-checksum-origin-map))
(ofolder (car pair))
(omsg (cdr pair)))
(loop for seq in (ignore-errors
(gethash omsg (gethash ofolder seq-hash)))
do (if (assoc seq seq-list)
(push msg (cdr (assoc seq seq-list)))
(push (list seq msg) seq-list)))))
(loop for seq in seq-list
do (apply #'mh-exec-cmd "mark" mh-current-folder
"-sequence" (symbol-name (car seq)) "-add"
(mapcar #'(lambda (x) (format "%s" x)) (cdr seq))))))
(cl-loop for seq in (ignore-errors
(gethash omsg (gethash ofolder seq-hash)))
do (if (assoc seq seq-list)
(push msg (cdr (assoc seq seq-list)))
(push (list seq msg) seq-list)))))
(cl-loop for seq in seq-list
do (apply #'mh-exec-cmd "mark" mh-current-folder
"-sequence" (symbol-name (car seq)) "-add"
(mapcar #'(lambda (x) (format "%s" x)) (cdr seq))))))
;;;###mh-autoload
(defun mh-create-sequence-map (seq-list)
"Return a map from msg number to list of sequences in which it is present.
SEQ-LIST is an assoc list whose keys are sequence names and whose
cdr is the list of messages in that sequence."
(loop with map = (make-hash-table)
for seq in seq-list
when (and (not (memq (car seq) (mh-unpropagated-sequences)))
(mh-valid-seq-p (car seq)))
do (loop for msg in (cdr seq)
do (push (car seq) (gethash msg map)))
finally return map))
(cl-loop with map = (make-hash-table)
for seq in seq-list
when (and (not (memq (car seq) (mh-unpropagated-sequences)))
(mh-valid-seq-p (car seq)))
do (cl-loop for msg in (cdr seq)
do (push (car seq) (gethash msg map)))
finally return map))
;;;###mh-autoload
(defun mh-index-add-to-sequence (seq msgs)
@ -1741,7 +1741,7 @@ folder, is removed from `mh-index-data'."
(print-level nil))
(with-temp-file outfile
(mh-index-write-hashtable
data (lambda (x) (loop for y being the hash-keys of x collect y)))
data (lambda (x) (cl-loop for y being the hash-keys of x collect y)))
(mh-index-write-hashtable msg-checksum-map #'identity)
(mh-index-write-hashtable checksum-origin-map #'identity)
(pp previous-search (current-buffer)) (insert "\n")
@ -1751,8 +1751,8 @@ folder, is removed from `mh-index-data'."
"Write TABLE to `current-buffer'.
PROC is used to serialize the values corresponding to the hash
table keys."
(pp (loop for x being the hash-keys of table
collect (cons x (funcall proc (gethash x table))))
(pp (cl-loop for x being the hash-keys of table
collect (cons x (funcall proc (gethash x table))))
(current-buffer))
(insert "\n"))
@ -1769,9 +1769,9 @@ table keys."
(goto-char (point-min))
(setq t1 (mh-index-read-hashtable
(lambda (data)
(loop with table = (make-hash-table :test #'equal)
for x in data do (setf (gethash x table) t)
finally return table)))
(cl-loop with table = (make-hash-table :test #'equal)
for x in data do (setf (gethash x table) t)
finally return table)))
t2 (mh-index-read-hashtable #'identity)
t3 (mh-index-read-hashtable #'identity)
t4 (read (current-buffer))
@ -1785,10 +1785,10 @@ table keys."
(defun mh-index-read-hashtable (proc)
"From BUFFER read a hash table serialized as a list.
PROC is used to convert the value to actual data."
(loop with table = (make-hash-table :test #'equal)
for pair in (read (current-buffer))
do (setf (gethash (car pair) table) (funcall proc (cdr pair)))
finally return table))
(cl-loop with table = (make-hash-table :test #'equal)
for pair in (read (current-buffer))
do (setf (gethash (car pair) table) (funcall proc (cdr pair)))
finally return table))

21
lisp/mh-e/mh-seq.el
View file

@ -31,7 +31,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(require 'mh-scan)
(require 'font-lock)
@ -183,9 +182,9 @@ MESSAGE appears."
(interactive "P")
(if (not message)
(setq message (mh-get-msg-num t)))
(let* ((dest-folder (loop for seq in mh-refile-list
when (member message (cdr seq)) return (car seq)
finally return nil))
(let* ((dest-folder (cl-loop for seq in mh-refile-list
when (member message (cdr seq)) return (car seq)
finally return nil))
(deleted-flag (unless dest-folder (member message mh-delete-list))))
(message "Message %d%s is in sequences: %s"
message
@ -721,9 +720,9 @@ completion is over."
((eq flag t)
(all-completions last-word candidates predicate))
((eq flag 'lambda)
(loop for x in candidates
when (equal x last-word) return t
finally return nil)))))
(cl-loop for x in candidates
when (equal x last-word) return t
finally return nil)))))
(defun mh-seq-names (seq-list)
"Return an alist containing the names of the SEQ-LIST."
@ -742,8 +741,8 @@ completion is over."
(call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero"
"-norecurse" folder "-sequence" (symbol-name mh-unseen-seq))
(goto-char (point-min))
(multiple-value-bind (folder unseen total)
(values-list
(cl-multiple-value-bind (folder unseen total)
(cl-values-list
(mh-parse-flist-output-line
(buffer-substring (point) (mh-line-end-position))))
(list total unseen folder))))
@ -934,8 +933,8 @@ notated."
(dolist (msg (mh-seq-msgs seq))
(push (car seq) (gethash msg msg-hash))))
(mh-iterate-on-range msg range
(loop for seq in (gethash msg msg-hash)
do (mh-add-sequence-notation msg (mh-internal-seq seq))))))
(cl-loop for seq in (gethash msg msg-hash)
do (mh-add-sequence-notation msg (mh-internal-seq seq))))))
(defun mh-add-sequence-notation (msg internal-seq-flag)
"Add sequence notation to the MSG on the current line.

2
lisp/mh-e/mh-show.el
View file

@ -900,7 +900,7 @@ See also `mh-folder-mode'.
;; Don't allow Gnus to create buttons while highlighting, maybe this is bad
;; style?
(mh-flet
((gnus-article-add-button (&rest args) nil))
((gnus-article-add-button (&rest _args) nil))
(let* ((modified (buffer-modified-p))
(gnus-article-buffer (buffer-name))
(gnus-cite-face-list `(,@(cdr gnus-cite-face-list)

11
lisp/mh-e/mh-speed.el
View file

@ -31,7 +31,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(require 'gnus-util)
(require 'speedbar)
@ -184,7 +183,7 @@ The optional arguments from speedbar are IGNORED."
;;; Support Routines
;;;###mh-autoload
(defun mh-folder-speedbar-buttons (buffer)
(defun mh-folder-speedbar-buttons (_buffer)
"Interface function to create MH-E speedbar buffer.
BUFFER is the MH-E buffer for which the speedbar buffer is to be
created."
@ -438,7 +437,7 @@ flists is run only for that one folder."
;; Copied from mh-make-folder-list-filter...
;; XXX Refactor to use mh-make-folder-list-filer?
(defun mh-speed-parse-flists-output (process output)
(defun mh-speed-parse-flists-output (_process output)
"Parse the incremental results from flists.
PROCESS is the flists process and OUTPUT is the results that must
be handled next."
@ -451,7 +450,7 @@ be handled next."
mh-speed-partial-line
(substring output position line-end))
mh-speed-partial-line "")
(multiple-value-setq (folder unseen total)
(cl-multiple-value-setq (folder unseen total)
(cl-values-list
(mh-parse-flist-output-line line mh-speed-current-folder)))
(when (and folder unseen total
@ -555,12 +554,12 @@ The function invalidates the latest ancestor that is present."
(last-slash (mh-search-from-end ?/ folder))
(ancestor folder)
(ancestor-pos nil))
(block while-loop
(cl-block while-loop
(while last-slash
(setq ancestor (substring ancestor 0 last-slash))
(setq ancestor-pos (gethash ancestor mh-speed-folder-map))
(when ancestor-pos
(return-from while-loop))
(cl-return-from while-loop))
(setq last-slash (mh-search-from-end ?/ ancestor))))
(unless ancestor-pos (setq ancestor nil))
(goto-char (or ancestor-pos (gethash nil mh-speed-folder-map)))

76
lisp/mh-e/mh-thread.el
View file

@ -76,14 +76,14 @@
(require 'mh-e)
(require 'mh-scan)
(mh-defstruct (mh-thread-message (:conc-name mh-message-)
(cl-defstruct (mh-thread-message (:conc-name mh-message-)
(:constructor mh-thread-make-message))
(id nil)
(references ())
(subject "")
(subject-re-p nil))
(mh-defstruct (mh-thread-container (:conc-name mh-container-)
(cl-defstruct (mh-thread-container (:conc-name mh-container-)
(:constructor mh-thread-make-container))
message parent children
(real-child-p t))
@ -258,7 +258,7 @@ sibling."
(beginning-of-line)
(forward-char address-start-offset)
(while (char-equal (char-after) ? )
(incf level)
(cl-incf level)
(forward-char))
level)))
@ -292,7 +292,7 @@ at the end."
(setq begin (point))
(setq spaces (format (format "%%%ss" (1+ level)) ""))
(forward-line)
(block nil
(cl-block nil
(while (not (eobp))
(forward-char address-start-offset)
(unless (equal (string-match spaces (buffer-substring-no-properties
@ -300,7 +300,7 @@ at the end."
0)
(beginning-of-line)
(backward-char)
(return))
(cl-return))
(forward-line)))
(list begin (point)))))
@ -388,8 +388,8 @@ the id-table is updated."
(parent-container (mh-container-parent child-container)))
(when parent-container
(setf (mh-container-children parent-container)
(loop for elem in (mh-container-children parent-container)
unless (eq child-container elem) collect elem))
(cl-loop for elem in (mh-container-children parent-container)
unless (eq child-container elem) collect elem))
(setf (mh-container-parent child-container) nil))))
(defsubst mh-thread-add-link (parent child &optional at-end-p)
@ -442,9 +442,9 @@ added to the end of the children list of PARENT."
"Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise.
In the limit, the function returns t if ANCESTOR and SUCCESSOR
are the same containers."
(block nil
(cl-block nil
(while successor
(when (eq ancestor successor) (return t))
(when (eq ancestor successor) (cl-return t))
(setq successor (mh-container-parent successor)))
nil))
@ -525,12 +525,12 @@ children."
(cond ((and (mh-container-message container)
(mh-message-id (mh-container-message container)))
(mh-message-subject (mh-container-message container)))
(t (block nil
(t (cl-block nil
(dolist (kid (mh-container-children container))
(when (and (mh-container-message kid)
(mh-message-id (mh-container-message kid)))
(let ((kid-message (mh-container-message kid)))
(return (mh-message-subject kid-message)))))
(cl-return (mh-message-subject kid-message)))))
(error "This can't happen")))))
(defsubst mh-thread-update-id-index-maps (id index)
@ -595,9 +595,9 @@ Only information about messages in MSG-LIST are added to the tree."
(goto-char (point-min))
(let ((roots ())
(case-fold-search t))
(block nil
(cl-block nil
(while (not (eobp))
(block process-message
(cl-block process-message
(let* ((index-line
(prog1 (buffer-substring (point) (mh-line-end-position))
(forward-line)))
@ -616,26 +616,26 @@ Only information about messages in MSG-LIST are added to the tree."
(forward-line)))
(subject-re-p nil))
(unless (gethash index mh-thread-scan-line-map)
(return-from process-message))
(unless (integerp index) (return)) ;Error message here
(multiple-value-setq (subject subject-re-p)
(values-list (mh-thread-prune-subject subject)))
(cl-return-from process-message))
(unless (integerp index) (cl-return)) ;Error message here
(cl-multiple-value-setq (subject subject-re-p)
(cl-values-list (mh-thread-prune-subject subject)))
(setq in-reply-to (mh-thread-process-in-reply-to in-reply-to))
(setq refs (loop for x in (append (split-string refs) in-reply-to)
when (string-match mh-message-id-regexp x)
collect x))
(setq refs
(cl-loop for x in (append (split-string refs) in-reply-to)
when (string-match mh-message-id-regexp x)
collect x))
(setq id (mh-thread-canonicalize-id id))
(mh-thread-update-id-index-maps id index)
(setq refs (mapcar #'mh-thread-canonicalize-id refs))
(mh-thread-get-message id subject-re-p subject refs)
(do ((ancestors refs (cdr ancestors)))
(cl-do ((ancestors refs (cdr ancestors)))
((null (cdr ancestors))
(when (car ancestors)
(mh-thread-remove-parent-link id)
(mh-thread-add-link (car ancestors) id)))
(mh-thread-add-link (car ancestors) (cadr ancestors)))))))
(maphash #'(lambda (k v)
(declare (ignore k))
(maphash #'(lambda (_k v)
(when (null (mh-container-parent v))
(push v roots)))
mh-thread-id-table)
@ -720,8 +720,7 @@ For now it will take the last string inside angles."
mh-thread-history)
(mh-thread-remove-parent-link node)))))
(let ((results ()))
(maphash #'(lambda (k v)
(declare (ignore k))
(maphash #'(lambda (_k v)
(when (and (null (mh-container-parent v))
(gethash (mh-message-id (mh-container-message v))
mh-thread-id-index-map))
@ -751,17 +750,18 @@ For now it will take the last string inside angles."
(mh-thread-last-ancestor nil))
(if (null mh-index-data)
(mh-thread-generate-scan-lines thread-tree -2)
(loop for x in (mh-index-group-by-folder)
do (let* ((old-map mh-thread-scan-line-map)
(mh-thread-scan-line-map (make-hash-table)))
(setq mh-thread-last-ancestor nil)
(loop for msg in (cdr x)
do (let ((v (gethash msg old-map)))
(when v
(setf (gethash msg mh-thread-scan-line-map) v))))
(when (> (hash-table-count mh-thread-scan-line-map) 0)
(insert (if (bobp) "" "\n") (car x) "\n")
(mh-thread-generate-scan-lines thread-tree -2))))
(cl-loop for x in (mh-index-group-by-folder)
do (let* ((old-map mh-thread-scan-line-map)
(mh-thread-scan-line-map (make-hash-table)))
(setq mh-thread-last-ancestor nil)
(cl-loop for msg in (cdr x)
do (let ((v (gethash msg old-map)))
(when v
(setf (gethash msg mh-thread-scan-line-map)
v))))
(when (> (hash-table-count mh-thread-scan-line-map) 0)
(insert (if (bobp) "" "\n") (car x) "\n")
(mh-thread-generate-scan-lines thread-tree -2))))
(mh-index-create-imenu-index))))
(defun mh-thread-generate-scan-lines (tree level)
@ -826,8 +826,8 @@ MSG is the message being notated with NOTATION at OFFSET."
(let* ((msg (or msg (mh-get-msg-num nil)))
(cur-scan-line (and mh-thread-scan-line-map
(gethash msg mh-thread-scan-line-map)))
(old-scan-lines (loop for map in mh-thread-scan-line-map-stack
collect (and map (gethash msg map)))))
(old-scan-lines (cl-loop for map in mh-thread-scan-line-map-stack
collect (and map (gethash msg map)))))
(when cur-scan-line
(setf (aref (car cur-scan-line) offset) notation))
(dolist (line old-scan-lines)

97
lisp/mh-e/mh-tool-bar.el
View file

@ -36,7 +36,7 @@
;;; Tool Bar Commands
(defun mh-tool-bar-search (&optional arg)
(defun mh-tool-bar-search (&optional _arg)
"Interactively call `mh-tool-bar-search-function'.
Optional argument ARG is not used."
(interactive "P")
@ -131,11 +131,12 @@ where,
active. If it isn't present then the button is always active."
;; The following variable names have been carefully chosen to make code
;; generation easier. Modifying the names should be done carefully.
(let (folder-buttons folder-docs folder-button-setter sequence-button-setter
show-buttons show-button-setter show-seq-button-setter
letter-buttons letter-docs letter-button-setter
folder-defaults letter-defaults
folder-vectors show-vectors letter-vectors)
(mh-dlet* (folder-buttons
folder-docs folder-button-setter sequence-button-setter
show-buttons show-button-setter show-seq-button-setter
letter-buttons letter-docs letter-button-setter
folder-defaults letter-defaults
folder-vectors show-vectors letter-vectors)
(dolist (x defaults)
(cond ((eq (car x) :folder) (setq folder-defaults (cdr x)))
((eq (car x) :letter) (setq letter-defaults (cdr x)))))
@ -161,14 +162,14 @@ where,
(append `(,(if (memq 'folder modes) :folder :sequence) ,name)
functions))
(setq show-sym
(if (string-match "^mh-\\(.*\\)$" name-str)
(if (string-match "\\`mh-\\(.*\\)\\'" name-str)
(intern (concat "mh-show-" (match-string 1 name-str)))
name))
(setq functions
(append `(,(if (memq 'folder modes) :show :show-seq)
,(if (fboundp show-sym) show-sym name))
functions)))
(do ((functions functions (cddr functions)))
(cl-do ((functions functions (cddr functions)))
((null functions))
(let* ((type (car functions))
(function (cadr functions))
@ -209,15 +210,15 @@ where,
(dolist (x letter-defaults)
(unless (memq x letter-buttons)
(error "Letter defaults contains unknown button %s" x)))
`(eval-when (compile load eval)
`(eval-and-compile
;; GNU Emacs tool bar specific code
(mh-do-in-gnu-emacs
(defun mh-buffer-exists-p (mode)
"Test whether a buffer with major mode MODE is present."
(loop for buf in (buffer-list)
when (with-current-buffer buf
(eq major-mode mode))
return t))
(cl-loop for buf in (buffer-list)
when (with-current-buffer buf
(eq major-mode mode))
return t))
;; Tool bar initialization functions
(defun mh-tool-bar-folder-buttons-init ()
(when (mh-buffer-exists-p 'mh-folder-mode)
@ -257,18 +258,18 @@ where,
(defun mh-tool-bar-update (mode default-map sequence-map)
"Update `tool-bar-map' in all buffers of MODE.
Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
(loop for buf in (buffer-list)
do (with-current-buffer buf
(if (eq mode major-mode)
(let ((map (if mh-folder-view-stack
sequence-map
default-map)))
;; Yes, make-local-variable is necessary since we
;; get here during initialization when loading
;; mh-e.el, after the +inbox buffer has been
;; created, but before mh-folder-mode has run and
;; created the local map.
(set (make-local-variable 'tool-bar-map) map))))))
(cl-loop for buf in (buffer-list)
do (with-current-buffer buf
(when (eq mode major-mode) ;FIXME: derived-mode-p?
(let ((map (if mh-folder-view-stack
sequence-map
default-map)))
;; Yes, make-local-variable is necessary since we
;; get here during initialization when loading
;; mh-e.el, after the +inbox buffer has been
;; created, but before mh-folder-mode has run and
;; created the local map.
(set (make-local-variable 'tool-bar-map) map))))))
(defun mh-tool-bar-folder-buttons-set (symbol value)
"Construct tool bar for `mh-folder-mode' and `mh-show-mode'."
(set-default symbol value)
@ -286,17 +287,17 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
;; XEmacs specific code
(mh-do-in-xemacs
(defvar mh-tool-bar-folder-vector-map
(list ,@(loop for button in folder-buttons
for vector in folder-vectors
collect `(cons ',button ,vector))))
(list ,@(cl-loop for button in folder-buttons
for vector in folder-vectors
collect `(cons ',button ,vector))))
(defvar mh-tool-bar-show-vector-map
(list ,@(loop for button in show-buttons
for vector in show-vectors
collect `(cons ',button ,vector))))
(list ,@(cl-loop for button in show-buttons
for vector in show-vectors
collect `(cons ',button ,vector))))
(defvar mh-tool-bar-letter-vector-map
(list ,@(loop for button in letter-buttons
for vector in letter-vectors
collect `(cons ',button ,vector))))
(list ,@(cl-loop for button in letter-buttons
for vector in letter-vectors
collect `(cons ',button ,vector))))
(defvar mh-tool-bar-folder-buttons)
(defvar mh-tool-bar-show-buttons)
(defvar mh-tool-bar-letter-buttons)
@ -305,18 +306,20 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
(set-default symbol value)
(when mh-xemacs-has-tool-bar-flag
(setq mh-tool-bar-letter-buttons
(loop for b in value
collect (cdr
(assoc b mh-tool-bar-letter-vector-map))))))
(cl-loop
for b in value
collect (cdr (assoc b mh-tool-bar-letter-vector-map))))))
(defun mh-tool-bar-folder-buttons-set (symbol value)
(set-default symbol value)
(when mh-xemacs-has-tool-bar-flag
(setq mh-tool-bar-folder-buttons
(loop for b in value
collect (cdr (assoc b mh-tool-bar-folder-vector-map))))
(cl-loop
for b in value
collect (cdr (assoc b mh-tool-bar-folder-vector-map))))
(setq mh-tool-bar-show-buttons
(loop for b in value
collect (cdr (assoc b mh-tool-bar-show-vector-map))))))
(cl-loop
for b in value
collect (cdr (assoc b mh-tool-bar-show-vector-map))))))
(defun mh-tool-bar-init (mode)
"Install tool bar in MODE."
(when mh-xemacs-use-tool-bar-flag
@ -354,9 +357,9 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
"List of buttons to include in MH-Folder tool bar."
:group 'mh-tool-bar
:set 'mh-tool-bar-folder-buttons-set
:type '(set ,@(loop for x in folder-buttons
for y in folder-docs
collect `(const :tag ,y ,x)))
:type '(set ,@(cl-loop for x in folder-buttons
for y in folder-docs
collect `(const :tag ,y ,x)))
;;:package-version '(MH-E "7.1")
)
(custom-declare-variable
@ -365,9 +368,9 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
"List of buttons to include in MH-Letter tool bar."
:group 'mh-tool-bar
:set 'mh-tool-bar-letter-buttons-set
:type '(set ,@(loop for x in letter-buttons
for y in letter-docs
collect `(const :tag ,y ,x)))
:type '(set ,@(cl-loop for x in letter-buttons
for y in letter-docs
collect `(const :tag ,y ,x)))
;;:package-version '(MH-E "7.1")
))))

79
lisp/mh-e/mh-utils.el
View file

@ -29,7 +29,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(require 'font-lock)
@ -40,9 +39,9 @@
"Return the position of last occurrence of CHAR in STRING.
If CHAR is not present in STRING then return nil. The function is
used in lieu of `search' in the CL package."
(loop for index from (1- (length string)) downto 0
when (equal (aref string index) char) return index
finally return nil))
(cl-loop for index from (1- (length string)) downto 0
when (equal (aref string index) char) return index
finally return nil))
@ -103,9 +102,9 @@ PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil."
(dolist (string pick-expr)
(when (and string
(not (string-equal string "")))
(loop for i from 0 to (1- (length mh-pick-regexp-chars)) do
(let ((s (string ?\\ (aref mh-pick-regexp-chars i))))
(setq string (mh-replace-regexp-in-string s s string t t))))
(cl-loop for i from 0 to (1- (length mh-pick-regexp-chars)) do
(let ((s (string ?\\ (aref mh-pick-regexp-chars i))))
(setq string (mh-replace-regexp-in-string s s string t t))))
(setq quoted-pick-expr (append quoted-pick-expr (list string)))))
quoted-pick-expr))
@ -374,7 +373,7 @@ the cursor is not pointing to a message."
(mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter
"-recurse" "-fast"))))
(defun mh-collect-folder-names-filter (process output)
(defun mh-collect-folder-names-filter (_process output)
"Read folder names.
PROCESS is the flists process that was run to collect folder
names and the function is called when OUTPUT is available."
@ -402,15 +401,15 @@ names and the function is called when OUTPUT is available."
(child2 (and parent (substring parent (1+ (or parent-slash 0)))))
(grand-parent (and parent-slash (substring parent 0 parent-slash)))
(cache-entry (gethash parent mh-sub-folders-cache)))
(unless (loop for x in cache-entry when (equal (car x) child1) return t
finally return nil)
(unless (cl-loop for x in cache-entry when (equal (car x) child1) return t
finally return nil)
(push (list child1) cache-entry)
(setf (gethash parent mh-sub-folders-cache)
(sort cache-entry (lambda (x y) (string< (car x) (car y)))))
(when parent
(loop for x in (gethash grand-parent mh-sub-folders-cache)
when (equal (car x) child2)
do (progn (setf (cdr x) t) (return)))))))
(cl-loop for x in (gethash grand-parent mh-sub-folders-cache)
when (equal (car x) child2)
do (progn (setf (cdr x) t) (cl-return)))))))
(defun mh-normalize-folder-name (folder &optional empty-string-okay
dont-remove-trailing-slash
@ -522,12 +521,12 @@ they will not be returned."
(unless (null folder)
(setq folder-list (list folder))
(setq folder (concat folder "/")))
(loop for f in (mh-sub-folders folder) do
(setq folder-list
(append folder-list
(if (mh-children-p f)
(mh-folder-list (concat folder (car f)))
(list (concat folder (car f)))))))
(cl-loop for f in (mh-sub-folders folder) do
(setq folder-list
(append folder-list
(if (mh-children-p f)
(mh-folder-list (concat folder (car f)))
(list (concat folder (car f)))))))
folder-list))
;;;###mh-autoload
@ -583,10 +582,10 @@ Expects FOLDER to have already been normalized with
(mh-line-beginning-position) t)))
(when (integerp has-pos)
(while (equal (char-after has-pos) ? )
(decf has-pos))
(incf has-pos)
(cl-decf has-pos))
(cl-incf has-pos)
(while (equal (char-after start-pos) ? )
(incf start-pos))
(cl-incf start-pos))
(let* ((name (buffer-substring start-pos has-pos))
(first-char (aref name 0))
(last-char (aref name (1- (length name)))))
@ -621,7 +620,7 @@ Here we will need to invalidate the cached sub-folders of +foo,
otherwise completion on +foo won't tell us about the option
+foo/bar!"
(remhash folder mh-sub-folders-cache)
(block ancestor-found
(cl-block ancestor-found
(let ((parent folder)
(one-ancestor-found nil)
last-slash)
@ -630,7 +629,7 @@ otherwise completion on +foo won't tell us about the option
(unless (eq (gethash parent mh-sub-folders-cache 'none) 'none)
(remhash parent mh-sub-folders-cache)
(if one-ancestor-found
(return-from ancestor-found)
(cl-return-from ancestor-found)
(setq one-ancestor-found t))))
(remhash nil mh-sub-folders-cache))))
@ -702,11 +701,11 @@ See Info node `(elisp) Programmed Completion' for details."
(name (substring name 1))
(t ""))))
(cond ((eq (car-safe flag) 'boundaries)
(list* 'boundaries
(let ((slash (mh-search-from-end ?/ orig-name)))
(if slash (1+ slash)
(if (string-match "\\`\\+" orig-name) 1 0)))
(if (cdr flag) (string-match "/" (cdr flag)))))
(cl-list* 'boundaries
(let ((slash (mh-search-from-end ?/ orig-name)))
(if slash (1+ slash)
(if (string-match "\\`\\+" orig-name) 1 0)))
(if (cdr flag) (string-match "/" (cdr flag)))))
((eq flag nil)
(let ((try-res
(try-completion
@ -721,6 +720,8 @@ See Info node `(elisp) Programmed Completion' for details."
(all-completions
remainder (mh-sub-folders last-complete t) predicate))
((eq flag 'lambda)
;; FIXME: if name starts with "/", `path' will end
;; being a relative name without a leading + nor / !? --Stef
(let ((path (concat (unless (and (> (length name) 1)
(eq (aref name 1) ?/))
mh-user-path)
@ -738,7 +739,7 @@ See Info node `(elisp) Programmed Completion' for details."
If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be
a folder name corresponding to `mh-user-path'."
(mh-normalize-folder-name
(let ((completion-root-regexp "^[+/]")
(let ((completion-root-regexp "^[+/]") ;FIXME: Who/what uses that?
(minibuffer-local-completion-map mh-folder-completion-map)
(mh-allow-root-folder-flag allow-root-folder-flag))
(completing-read prompt 'mh-folder-completion-function nil nil nil
@ -876,12 +877,12 @@ in this situation."
;; In this situation, rfc822-goto-eoh doesn't go to the end of the
;; header. The replacement allows From_ lines in the mail header.
(goto-char (point-min))
(loop for p = (re-search-forward
"^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
do (cond ((null p) (return))
(t (goto-char (match-beginning 0))
(unless (looking-at "From ") (return))
(goto-char p))))
(cl-loop for p = (re-search-forward
"^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
do (cond ((null p) (cl-return))
(t (goto-char (match-beginning 0))
(unless (looking-at "From ") (cl-return))
(goto-char p))))
(point)))
;;;###mh-autoload
@ -918,9 +919,9 @@ Handle RFC 822 (or later) continuation lines."
(defun mh-letter-skipped-header-field-p (field)
"Check if FIELD is to be skipped."
(let ((field (downcase field)))
(loop for x in mh-compose-skipped-header-fields
when (equal (downcase x) field) return t
finally return nil)))
(cl-loop for x in mh-compose-skipped-header-fields
when (equal (downcase x) field) return t
finally return nil)))
(defvar mh-hidden-header-keymap
(let ((map (make-sparse-keymap)))

133
lisp/mh-e/mh-xface.el
View file

@ -28,7 +28,6 @@
;;; Code:
(require 'mh-e)
(mh-require-cl)
(autoload 'message-fetch-field "message")
@ -74,8 +73,8 @@ in this order is used."
(x-face (setq raw (mh-uncompface x-face)
type 'pbm))
(url (setq type 'url))
(t (multiple-value-setq (type raw)
(values-list (mh-picon-get-image)))))
(t (cl-multiple-value-setq (type raw)
(cl-values-list (mh-picon-get-image)))))
(when type
(goto-char (point-min))
(when (re-search-forward "^from:" (point-max) t)
@ -177,93 +176,97 @@ The directories are searched for in the order they appear in the list.")
(defvar mh-picon-cache (make-hash-table :test #'equal))
(defvar mh-picon-image-types
(loop for type in '(xpm xbm gif)
when (or (mh-do-in-gnu-emacs
(ignore-errors
(mh-funcall-if-exists image-type-available-p type)))
(mh-do-in-xemacs (featurep type)))
collect type))
(cl-loop for type in '(xpm xbm gif)
when (or (mh-do-in-gnu-emacs
(ignore-errors
(mh-funcall-if-exists image-type-available-p type)))
(mh-do-in-xemacs (featurep type)))
collect type))
(autoload 'message-tokenize-header "sendmail")
(defun* mh-picon-get-image ()
(defun mh-picon-get-image ()
"Find the best possible match and return contents."
(mh-picon-set-directory-list)
(save-restriction
(let* ((from-field (ignore-errors (car (message-tokenize-header
(mh-get-header-field "from:")))))
(from (car (ignore-errors
(mh-funcall-if-exists ietf-drums-parse-address
from-field))))
;; Don't use mh-funcall-if-exists because
;; ietf-drums-parse-address might exist at run-time but
;; not at compile-time.
(when (fboundp 'ietf-drums-parse-address)
(ietf-drums-parse-address from-field)))))
(host (and from
(string-match "\\([^+]*\\)\\(\\+.*\\)?@\\(.*\\)" from)
(downcase (match-string 3 from))))
(user (and host (downcase (match-string 1 from))))
(canonical-address (format "%s@%s" user host))
(cached-value (gethash canonical-address mh-picon-cache))
(host-list (and host (delete "" (split-string host "\\."))))
(match nil))
(cond (cached-value (return-from mh-picon-get-image cached-value))
((not host-list) (return-from mh-picon-get-image nil)))
(setq match
(block loop
;; u@h search
(loop for dir in mh-picon-existing-directory-list
do (loop for type in mh-picon-image-types
;; [path]user@host
for file1 = (format "%s/%s.%s"
dir canonical-address type)
when (file-exists-p file1)
do (return-from loop file1)
;; [path]user
for file2 = (format "%s/%s.%s" dir user type)
when (file-exists-p file2)
do (return-from loop file2)
;; [path]host
for file3 = (format "%s/%s.%s" dir host type)
when (file-exists-p file3)
do (return-from loop file3)))
;; facedb search
;; Search order for user@foo.net:
;; [path]net/foo/user
;; [path]net/foo/user/face
;; [path]net/user
;; [path]net/user/face
;; [path]net/foo/unknown
;; [path]net/foo/unknown/face
;; [path]net/unknown
;; [path]net/unknown/face
(loop for u in (list user "unknown")
do (loop for dir in mh-picon-existing-directory-list
do (loop for x on host-list by #'cdr
for y = (mh-picon-generate-path x u dir)
do (loop for type in mh-picon-image-types
for z1 = (format "%s.%s" y type)
when (file-exists-p z1)
do (return-from loop z1)
for z2 = (format "%s/face.%s"
y type)
when (file-exists-p z2)
do (return-from loop z2)))))))
(setf (gethash canonical-address mh-picon-cache)
(mh-picon-file-contents match)))))
(host-list (and host (delete "" (split-string host "\\.")))))
(cond
(cached-value cached-value)
((not host-list) nil)
(t
(let ((match
(cl-block loop
;; u@h search
(dolist (dir mh-picon-existing-directory-list)
(cl-loop for type in mh-picon-image-types
;; [path]user@host
for file1 = (format "%s/%s.%s"
dir canonical-address type)
when (file-exists-p file1)
do (cl-return-from loop file1)
;; [path]user
for file2 = (format "%s/%s.%s" dir user type)
when (file-exists-p file2)
do (cl-return-from loop file2)
;; [path]host
for file3 = (format "%s/%s.%s" dir host type)
when (file-exists-p file3)
do (cl-return-from loop file3)))
;; facedb search
;; Search order for user@foo.net:
;; [path]net/foo/user
;; [path]net/foo/user/face
;; [path]net/user
;; [path]net/user/face
;; [path]net/foo/unknown
;; [path]net/foo/unknown/face
;; [path]net/unknown
;; [path]net/unknown/face
(dolist (u (list user "unknown"))
(dolist (dir mh-picon-existing-directory-list)
(cl-loop for x on host-list by #'cdr
for y = (mh-picon-generate-path x u dir)
do (cl-loop for type in mh-picon-image-types
for z1 = (format "%s.%s" y type)
when (file-exists-p z1)
do (cl-return-from loop z1)
for z2 = (format "%s/face.%s"
y type)
when (file-exists-p z2)
do (cl-return-from loop z2))))))))
(setf (gethash canonical-address mh-picon-cache)
(mh-picon-file-contents match))))))))
(defun mh-picon-set-directory-list ()
"Update `mh-picon-existing-directory-list' if needed."
(when (eq mh-picon-existing-directory-list 'unset)
(setq mh-picon-existing-directory-list
(loop for x in mh-picon-directory-list
when (file-directory-p x) collect x))))
(cl-loop for x in mh-picon-directory-list
when (file-directory-p x) collect x))))
(defun mh-picon-generate-path (host-list user directory)
"Generate the image file path.
HOST-LIST is the parsed host address of the email address, USER
the username and DIRECTORY is the directory relative to which the
path is generated."
(loop with acc = ""
for elem in host-list
do (setq acc (format "%s/%s" elem acc))
finally return (format "%s/%s%s" directory acc user)))
(cl-loop with acc = ""
for elem in host-list
do (setq acc (format "%s/%s" elem acc))
finally return (format "%s/%s%s" directory acc user)))
(defun mh-picon-file-contents (file)
"Return details about FILE.
@ -437,7 +440,7 @@ actual display is carried out by the SENTINEL function."
;; Temporary failure
(mh-x-image-set-download-state cache-file 'try-again)))
(defun mh-x-image-scale-and-display (process change)
(defun mh-x-image-scale-and-display (process _change)
"When the wget PROCESS terminates scale and display image.
The argument CHANGE is ignored."
(when (eq (process-status process) 'exit)