;;; 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))))
-;;;###mh-autoload
-(defun mh-image-load-path-for-library (library image &optional path)
- "Return a suitable search path for images of LIBRARY.
-
-Images for LIBRARY are searched for in \"../../etc/images\" and
-\"../etc/images\" relative to the files in \"lisp/LIBRARY\", in
-`image-load-path', or in `load-path'.
-
-This function returns value of `load-path' augmented with the
-path to IMAGE. If PATH is given, it is used instead of
-`load-path'.
-
-Here is an example that uses a common idiom to provide
-compatibility with versions of Emacs that lack the variable
-`image-load-path':
-
- (let ((load-path
- (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\" 'load-path))
- (image-load-path
- (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\" 'image-load-path)))
- (mh-tool-bar-folder-buttons-init))"
- (unless library (error "No library specified"))
- (unless image (error "No image specified"))
- (let ((image-directory))
- (cond
- ;; Try relative setting.
- ((let (library-name d1ei d2ei)
- ;; First, find library in the load-path.
- (setq library-name (locate-library library))
- (if (not library-name)
- (error "Cannot find library %s in load-path" library))
- ;; And then set image-directory relative to that.
- (setq
- ;; Go down 2 levels.
- d2ei (expand-file-name
- (concat (file-name-directory library-name) "../../etc/images"))
- ;; Go down 1 level.
- d1ei (expand-file-name
- (concat (file-name-directory library-name) "../etc/images")))
- (setq image-directory
- ;; Set it to nil if image is not found.
- (cond ((file-exists-p (expand-file-name image d2ei)) d2ei)
- ((file-exists-p (expand-file-name image d1ei)) d1ei)))))
- ;; Check for images in image-load-path or load-path.
- ((let ((img image)
- (dir (or
- ;; Images in image-load-path.
- (mh-image-search-load-path image)
- ;; Images in load-path.
- (locate-library image)))
- parent)
- ;; Since the image might be in a nested directory (for
- ;; example, mail/attach.pbm), adjust `image-directory'
- ;; accordingly.
- (and dir
- (setq dir (file-name-directory dir))
- (progn
- (while (setq parent (file-name-directory img))
- (setq img (directory-file-name parent)
- dir (expand-file-name "../" dir)))
- (setq image-directory dir)))))
- (t
- (error "Could not find image %s for library %s" image library)))
-
- ;; Return augmented `image-load-path' or `load-path'.
- (cond ((and path (symbolp path))
- (nconc (list image-directory)
- (delete image-directory
- (if (boundp path)
- (copy-sequence (symbol-value path))
- nil))))
- (t
- (nconc (list image-directory)
- (delete image-directory (copy-sequence load-path)))))))
-
;;;###mh-autoload
(defun mh-make-local-vars (&rest pairs)
"Initialize local variables according to the variable-value PAIRS."
(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-do-in-gnu-emacs
- (let ((load-path (mh-image-load-path-for-library
- "mh-e" "mh-logo.xpm" 'load-path))
- (image-load-path (mh-image-load-path-for-library
- "mh-e" "mh-logo.xpm" 'image-load-path)))
+ (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
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-folder-list nil)
=> (\"inbox\" \"lists\" \"lists/mh-e\" \"outbox\")
(mh-folder-list \"+lists\")
- => (\"lists/mh-e\")
+ => (\"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 (mh-replace-regexp-in-string "/+$" "" folder))
+ (if (equal folder "")
+ (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-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)))))))
+ (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