;;; mh-utils.el --- MH-E general utilities
;; Copyright (C) 1993, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;;; General Utilities
-(require 'mailabbrev nil t)
-(mh-defun-compat mail-abbrev-make-syntax-table ()
- "Emacs 21 and XEmacs don't have this function."
- nil)
-
;;;###mh-autoload
(defun mh-beginning-of-word (&optional n)
"Return position of the N th word backwards."
(let ((syntax-table (syntax-table)))
(unwind-protect
(save-excursion
- (mail-abbrev-make-syntax-table)
+ (mh-mail-abbrev-make-syntax-table)
(set-syntax-table mail-abbrev-syntax-table)
(backward-word n)
(point))
;;;###mh-autoload
(defun mh-colors-available-p ()
"Check if colors are available in the Emacs being used."
- (or mh-xemacs-flag
- (let ((color-cells (display-color-cells)))
+ (or (featurep 'xemacs)
+ (let ((color-cells (mh-display-color-cells)))
(and (numberp color-cells) (>= color-cells 8)))))
;;;###mh-autoload
"Delete the next LINES lines."
(delete-region (point) (progn (forward-line lines) (point))))
-(defvar mh-image-load-path-called-flag nil)
-
-;;;###mh-autoload
-(defun mh-image-load-path ()
- "Ensure that the MH-E images are accessible by `find-image'.
-Images for MH-E are found in ../../etc/images relative to the
-files in \"lisp/mh-e\". If `image-load-path' exists (since Emacs
-22), then the images directory is added to it if isn't already
-there. Otherwise, the images directory is added to the
-`load-path' if it isn't already there."
- (unless mh-image-load-path-called-flag
- (let (mh-library-name mh-image-load-path)
- ;; First, find mh-e in the load-path.
- (setq mh-library-name (locate-library "mh-e"))
- (if (not mh-library-name)
- (error "Can not find MH-E in load-path"))
- (setq mh-image-load-path
- (expand-file-name (concat (file-name-directory mh-library-name)
- "../../etc/images")))
- (if (not (file-exists-p mh-image-load-path))
- (error "Can not find image directory %s" mh-image-load-path))
- (if (boundp 'image-load-path)
- (add-to-list 'image-load-path mh-image-load-path)
- (add-to-list 'load-path mh-image-load-path)))
- (setq mh-image-load-path-called-flag t)))
-
;;;###mh-autoload
(defun mh-make-local-vars (&rest pairs)
"Initialize local variables according to the variable-value PAIRS."
(funcall function (car list))
(setq list (cdr list))))
+(defvar mh-pick-regexp-chars ".*$["
+ "List of special characters in pick regular expressions.")
+
+;;;###mh-autoload
+(defun mh-quote-pick-expr (pick-expr)
+ "Quote `mh-pick-regexp-chars' in PICK-EXPR.
+PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil."
+ (let ((quoted-pick-expr))
+ (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))))
+ (setq quoted-pick-expr (append quoted-pick-expr (list string)))))
+ quoted-pick-expr))
+
;;;###mh-autoload
(defun mh-replace-string (old new)
"Replace all occurrences of OLD with NEW in the current buffer.
(defvar mh-logo-cache nil)
+;; Shush compiler.
+(defvar image-load-path)
+
;;;###mh-autoload
(defun mh-logo-display ()
"Modify mode line to display MH-E logo."
- (mh-image-load-path)
(mh-do-in-gnu-emacs
- (add-text-properties
- 0 2
- `(display ,(or mh-logo-cache
- (setq mh-logo-cache
- (mh-funcall-if-exists
- find-image '((:type xpm :ascent center
- :file "mh-logo.xpm"))))))
- (car mode-line-buffer-identification)))
+ (let* ((load-path (mh-image-load-path-for-library "mh-e" "mh-logo.xpm"))
+ (image-load-path (cons (car load-path)
+ (when (boundp 'image-load-path)
+ image-load-path))))
+ (add-text-properties
+ 0 2
+ `(display ,(or mh-logo-cache
+ (setq mh-logo-cache
+ (mh-funcall-if-exists
+ find-image '((:type xpm :ascent center
+ :file "mh-logo.xpm"))))))
+ (car mode-line-buffer-identification))))
(mh-do-in-xemacs
- (setq modeline-buffer-identification
- (list
- (if mh-modeline-glyph
- (cons modeline-buffer-id-left-extent mh-modeline-glyph)
- (cons modeline-buffer-id-left-extent "XEmacs%N:"))
- (cons modeline-buffer-id-right-extent " %17b")))))
+ (setq modeline-buffer-identification
+ (list
+ (if mh-modeline-glyph
+ (cons modeline-buffer-id-left-extent mh-modeline-glyph)
+ (cons modeline-buffer-id-left-extent "XEmacs%N:"))
+ (cons modeline-buffer-id-right-extent " %17b")))))
\f
do (progn (setf (cdr x) t) (return)))))))
(defun mh-normalize-folder-name (folder &optional empty-string-okay
- dont-remove-trailing-slash)
+ dont-remove-trailing-slash
+ return-nil-if-folder-empty)
"Normalizes FOLDER name.
Makes sure that two '/' characters never occur next to each
If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a
trailing '/' if present is retained (if present), otherwise it is
-removed."
- (when (stringp folder)
+removed.
+
+If optional argument RETURN-NIL-IF-FOLDER-EMPTY is non-nil, then
+return nil if FOLDER is \"\" or \"+\". This is useful when
+normalizing the folder for the \"folders\" command which displays
+the directories in / if passed \"+\". This is usually not
+desired. If this argument is non-nil, then EMPTY-STRING-OKAY has
+no effect."
+ (cond
+ ((if (and (or (equal folder "+") (equal folder ""))
+ return-nil-if-folder-empty)
+ (setq folder nil)))
+ ((stringp folder)
;; Replace two or more consecutive '/' characters with a single '/'
(while (string-match "//" folder)
(setq folder (replace-match "/" nil t folder)))
(stringp mh-current-folder-name))
(setq folder (format "%s/%s/" mh-current-folder-name
(substring folder 1))))
- ;; XXX: Purge empty strings from the list that split-string returns. In
- ;; XEmacs, (split-string "+foo/" "/") returns ("+foo" "") while in GNU
- ;; Emacs it returns ("+foo"). In the code it is assumed that the
- ;; components list has no empty strings.
+ ;; XXX: Purge empty strings from the list that split-string
+ ;; returns. In XEmacs, (split-string "+foo/" "/") returns
+ ;; ("+foo" "") while in GNU Emacs it returns ("+foo"). In the
+ ;; code it is assumed that the components list has no empty
+ ;; strings.
(let ((components (delete "" (split-string folder "/")))
(result ()))
;; Remove .. and . from the pathname.
(when leading-slash-present
(setq folder (concat "/" folder)))))
(cond ((and empty-string-okay (equal folder "")))
- ((equal folder "") (setq folder "+"))
- ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder)))))
+ ((equal folder "")
+ (setq folder "+"))
+ ((not (equal (aref folder 0) ?+))
+ (setq folder (concat "+" folder))))))
folder)
(defmacro mh-children-p (folder)
;;;###mh-autoload
(defun mh-folder-list (folder)
"Return FOLDER and its descendents.
-Returns a list of strings. For example,
-
- '(\"inbox\" \"lists\" \"lists/mh-e\").
-
-If folder is nil, then all folders are considered. Respects the
-value of `mh-recursive-folders-flag'. If this flag is nil, and
-the sub-folders have not been explicitly viewed, then they will
-not be returned."
+FOLDER may have a + prefix. Returns a list of strings without the
++ prefix. If FOLDER is nil, then all folders are considered. For
+example, if your Mail directory only contains the folders +inbox,
++outbox, +lists, and +lists/mh-e, then
+
+ (mh-folder-list nil)
+ => (\"inbox\" \"lists\" \"lists/mh-e\" \"outbox\")
+ (mh-folder-list \"+lists\")
+ => (\"lists\" \"lists/mh-e\")
+
+Respects the value of `mh-recursive-folders-flag'. If this flag
+is nil, and the sub-folders have not been explicitly viewed, then
+they will not be returned."
(let ((folder-list))
- ;; Normalize folder. Strip leading +. Add trailing slash. If no
- ;; folder is specified, ensure it is nil to ensure we get the
- ;; top-level folders; otherwise mh-sub-folders returns all the
- ;; files in / if given an empty string or +.
+ ;; Normalize folder. Strip leading + and trailing slash(es). If no
+ ;; folder is specified, ensure it is nil to avoid adding the
+ ;; folder to the folder-list and adding a slash to it.
(when folder
- (setq folder (replace-regexp-in-string "^\+" "" folder))
- (setq folder (replace-regexp-in-string "/*$" "/" folder))
+ (setq folder (mh-replace-regexp-in-string "^\+" "" folder))
+ (setq folder (mh-replace-regexp-in-string "/+$" "" folder))
(if (equal folder "")
- (setq folder nil)))
+ (setq folder nil)))
+ ;; Add provided folder to list, unless all folders are asked for.
+ ;; Then append slash to separate sub-folders.
+ (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 (list (concat folder (car f)))))
- (if (mh-children-p f)
- (setq folder-list
- (append folder-list
- (mh-folder-list (concat folder (car f)))))))
+ (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
If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a
slash is added to each of the sub-folder names that may have
nested folders within them."
- (let* ((folder (mh-normalize-folder-name folder))
+ (let* ((folder (mh-normalize-folder-name folder nil nil t))
(match (gethash folder mh-sub-folders-cache 'no-result))
(sub-folders (cond ((eq match 'no-result)
(setf (gethash folder mh-sub-folders-cache)
sub-folders)
sub-folders)))
+;; FIXME: This function does not do well if FOLDER does not exist. It
+;; then changes the context to that folder which causes problems down
+;; the line. Since a folder in the cache could later be deleted, it
+;; would be good for mh-sub-folders-actual to return nil in this case
+;; so that mh-sub-folders could delete it from the cache. This
+;; function could protect itself by using a temporary context.
(defun mh-sub-folders-actual (folder)
"Execute the command folders to return the sub-folders of FOLDER.
Filters out the folder names that start with \".\" so that
-directories that aren't usually mail folders are hidden."
+directories that aren't usually mail folders are hidden.
+Expects FOLDER to have already been normalized with
+ (mh-normalize-folder-name folder nil nil t)"
(let ((arg-list `(,(expand-file-name "folders" mh-progs)
nil (t nil) nil "-noheader" "-norecurse" "-nototal"
,@(if (stringp folder) (list folder) ())))
(apply #'call-process arg-list)
(goto-char (point-min))
(while (not (and (eolp) (bolp)))
- (goto-char (line-end-position))
- (let ((start-pos (line-beginning-position))
- (has-pos (search-backward " has " (line-beginning-position) t)))
+ (goto-char (mh-line-end-position))
+ (let ((start-pos (mh-line-beginning-position))
+ (has-pos (search-backward " has "
+ (mh-line-beginning-position) t)))
(when (integerp has-pos)
(while (equal (char-after has-pos) ? )
(decf has-pos))
(setq name (substring name 0 (1- (length name)))))
(push
(cons name
- (search-forward "(others)" (line-end-position) t))
+ (search-forward "(others)" (mh-line-end-position) t))
results))))
(forward-line 1))))
(setq results (nreverse results))
(defvar mh-folder-hist nil)
;; Shush compiler.
-(eval-when-compile (defvar mh-speed-flists-cache))
+(defvar mh-speed-flists-cache)
(defvar mh-allow-root-folder-flag nil
"Non-nil means \"+\" is an acceptable folder name.
(defun mh-folder-completion-function (name predicate flag)
"Programmable completion for folder names.
NAME is the partial folder name that has been input. PREDICATE if
-non-nil is a function that is used to filter the possible choices
-and FLAG determines whether the completion is over."
+non-nil is a function that is used to filter the possible
+choices. FLAG is nil to indicate `try-completion', t for
+`all-completions', or the symbol lambda for `test-completion'.
+See Info node `(elisp) Programmed Completion' for details."
(let* ((orig-name name)
+ ;; After normalization, name is nil, +, or +something. If a
+ ;; trailing slash is present, it is preserved.
(name (mh-normalize-folder-name name nil t))
(last-slash (mh-search-from-end ?/ name))
- (last-complete (if last-slash (substring name 0 last-slash) nil))
+ ;; nil if + or +folder; +folder/ if slash present.
+ (last-complete (if last-slash (substring name 0 (1+ last-slash)) nil))
+ ;; Either +folder/remainder, +remainder, or "".
(remainder (cond (last-complete (substring name (1+ last-slash)))
- ((and (> (length name) 0) (equal (aref name 0) ?+))
- (substring name 1))
+ (name (substring name 1))
(t ""))))
(cond ((eq flag nil)
- (let ((try-res (try-completion
- name
- (mapcar (lambda (x)
- (cons (if (not last-complete)
- (concat "+" (car x))
- (concat last-complete "/" (car x)))
- (cdr x)))
- (mh-sub-folders last-complete t))
- predicate)))
+ (let ((try-res
+ (try-completion
+ name
+ (mapcar (lambda (x)
+ (cons (concat (or last-complete "+") (car x))
+ (cdr x)))
+ (mh-sub-folders last-complete t))
+ predicate)))
(cond ((eq try-res nil) nil)
((and (eq try-res t) (equal name orig-name)) t)
((eq try-res t) name)
(t try-res))))
((eq flag t)
- (all-completions
- remainder (mh-sub-folders last-complete t) predicate))
+ (mapcar (lambda (x)
+ (concat (or last-complete "+") x))
+ (all-completions
+ remainder (mh-sub-folders last-complete t) predicate)))
((eq flag 'lambda)
- (let ((path (concat mh-user-path
- (substring (mh-normalize-folder-name name) 1))))
+ (let ((path (concat (unless (and (> (length name) 1)
+ (eq (aref name 1) ?/))
+ mh-user-path)
+ (substring name 1))))
(cond (mh-allow-root-folder-flag (file-exists-p path))
((equal path mh-user-path) nil)
(t (file-exists-p path))))))))
;; Shush compiler.
-(eval-when-compile
- (mh-do-in-xemacs
- (defvar completion-root-regexp)
- (defvar minibuffer-completing-file-name)))
+(defvar completion-root-regexp) ; XEmacs
+(defvar minibuffer-completing-file-name) ; XEmacs
(defun mh-folder-completing-read (prompt default allow-root-folder-flag)
"Read folder name with PROMPT and default result DEFAULT.
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 ((minibuffer-completing-file-name t)
- (completion-root-regexp "^[+/]")
+ (let ((completion-root-regexp "^[+/]")
(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
(buffer-substring-no-properties start (point))))
""))
-(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility
-
;;;###mh-autoload
(defun mh-goto-header-field (field)
"Move to FIELD in the message header.
(unwind-protect
(cond ((or (and (not arg)
(text-property-any begin end 'invisible 'vanish))
- (and (numberp arg) (>= arg 0))
- (and (eq arg 'long) (> (line-beginning-position 5) end)))
+ (and (numberp arg)
+ (>= arg 0))
+ (and (eq arg 'long)
+ (> (mh-line-beginning-position 5) end)))
(remove-text-properties begin end '(invisible nil))
- (search-forward ":" (line-end-position) t)
+ (search-forward ":" (mh-line-end-position) t)
(mh-letter-skip-leading-whitespace-in-header-field))
;; XXX Redesign to make usable by user. Perhaps use a positive
;; numeric prefix to make that many lines visible.