;;; 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,
;;;###mh-autoload
(defun mh-colors-available-p ()
"Check if colors are available in the Emacs being used."
- (or mh-xemacs-flag
+ (or (featurep 'xemacs)
(let ((color-cells (mh-display-color-cells)))
(and (numberp color-cells) (>= color-cells 8)))))
"Delete the next LINES lines."
(delete-region (point) (progn (forward-line lines) (point))))
-(defvar mh-image-load-path nil
- "Directory where images for MH-E are found.
-If nil, then the function `mh-image-load-path' will search for
-the images in \"../../etc/images\" relative to the files in
-\"lisp/mh-e\".")
-
-(defvar mh-image-load-path-called-flag nil
- "Non-nil means that the function `mh-image-load-path' has been called.
-This variable is used by that function to avoid doing the work repeatedly.")
-
-;;;###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\", in `image-load-path', or in `load-path'.
-This function saves the actual location found in the variable
-`mh-image-load-path'. If the images on your system are actually
-located elsewhere, then set the variable `mh-image-load-path'
-before starting MH-E.
-
-If `image-load-path' exists (since Emacs 22), then the contents
-of the variable `mh-image-load-path' is added to it if isn't
-already there. Otherwise, the contents of the variable
-`mh-image-load-path' is added to the `load-path' if it isn't
-already there.
-
-See also variable `mh-image-load-path-called-flag'."
- (unless mh-image-load-path-called-flag
- (cond
- (mh-image-load-path) ; user setting exists
- ((let (mh-library-name) ; try relative setting
- ;; 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"))
- ;; And then set mh-image-load-path relative to that.
- (setq mh-image-load-path
- (expand-file-name (concat
- (file-name-directory mh-library-name)
- "../../etc/images")))
- (file-exists-p (expand-file-name "mh-logo.xpm" mh-image-load-path))))
- ((mh-image-search-load-path "mh-logo.xpm")
- ;; Images in image-load-path.
- (setq mh-image-load-path
- (file-name-directory (mh-image-search-load-path "mh-logo.xpm"))))
- ((locate-library "mh-logo.xpm")
- ;; Images in load-path.
- (setq mh-image-load-path
- (file-name-directory (locate-library "mh-logo.xpm")))))
-
- (if (not (file-exists-p mh-image-load-path))
- (error "Directory %s in mh-image-load-path does not exist"
- mh-image-load-path))
- (if (not (file-exists-p
- (expand-file-name "mh-logo.xpm" mh-image-load-path)))
- (error "Directory %s in mh-image-load-path does not contain MH-E images"
- 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 (done in
- ;; two steps to avoid infinite loops when replacing "/*$" with "/"
- ;; in XEmacs). 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 (mh-replace-regexp-in-string "^\+" "" folder))
(setq folder (mh-replace-regexp-in-string "/+$" "" folder))
- (setq folder (concat 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) ())))
(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