Mercurial > emacs
diff lisp/mh-e/mh-speed.el @ 49459:06b77df47802
* mh-e: Created directory. ChangeLog will appear in a week when we
release version 7.2.
* lisp/mail/mh-alias.el, lisp/mail/mh-comp.el,
lisp/mail/mh-customize.el, lisp/mail/mh-e.el, lisp/mail/mh-funcs.el,
lisp/mail/mh-identity.el, lisp/mail/mh-index.el,
lisp/mail/mh-loaddefs.el, lisp/mail/mh-mime.el, lisp/mail/mh-pick.el,
lisp/mail/mh-seq.el, lisp/mail/mh-speed.el, lisp/mail/mh-utils.el,
lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm and
reply2.xpm, which were created by the MH-E package, were left in mail
since they can probably be used by other mail packages.
* makefile.w32-in (WINS): Added mh-e.
* makefile.nt (WINS): Added mh-e.
author | Bill Wohler <wohler@newt.com> |
---|---|
date | Sun, 26 Jan 2003 02:38:37 +0000 |
parents | |
children | b35587af8747 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-speed.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,573 @@ +;;; mh-speed.el --- Speedbar interface for MH-E. + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Satyaki Das <satyaki@theforce.stanford.edu> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; 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) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; Future versions should only use flists. + +;; Speedbar support for MH-E package. + +;;; Change Log: + +;; $Id: mh-speed.el,v 1.2 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +;; Requires +(require 'cl) +(require 'mh-e) +(require 'speedbar) + +;; Global variables +(defvar mh-speed-refresh-flag nil) +(defvar mh-speed-last-selected-folder nil) +(defvar mh-speed-folder-map (make-hash-table :test #'equal)) +(defvar mh-speed-folders-cache (make-hash-table :test #'equal)) +(defvar mh-speed-flists-cache (make-hash-table :test #'equal)) +(defvar mh-speed-flists-process nil) +(defvar mh-speed-flists-timer nil) +(defvar mh-speed-partial-line "") + +;; Add our stealth update function +(unless (member 'mh-speed-stealth-update + (cdr (assoc "files" speedbar-stealthy-function-list))) + ;; Is changing constant lists in elisp safe? + (setq speedbar-stealthy-function-list + (copy-tree speedbar-stealthy-function-list)) + (push 'mh-speed-stealth-update + (cdr (assoc "files" speedbar-stealthy-function-list)))) + +;; Functions called by speedbar to initialize display... +;;;###mh-autoload +(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." + (unless (get-text-property (point-min) 'mh-level) + (erase-buffer) + (clrhash mh-speed-folder-map) + (speedbar-make-tag-line 'bracket ?+ 'mh-speed-toggle nil " " 'ignore nil + 'mh-speedbar-folder-face 0) + (forward-line -1) + (setf (gethash nil mh-speed-folder-map) + (set-marker (make-marker) (1+ (line-beginning-position)))) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) + (mh-speed-stealth-update t) + (when mh-speed-run-flists-flag + (mh-speed-flists nil)))) + +;;;###mh-autoload +(defalias 'mh-show-speedbar-buttons 'mh-folder-speedbar-buttons) +;;;###mh-autoload +(defalias 'mh-letter-speedbar-buttons 'mh-folder-speedbar-buttons) + +;; Keymaps for speedbar... +(defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) + "Specialized speedbar keymap for MH-E buffers.") +(gnus-define-keys mh-folder-speedbar-key-map + "+" mh-speed-expand-folder + "-" mh-speed-contract-folder + "\r" mh-speed-view + "f" mh-speed-flists + "i" mh-speed-invalidate-map) + +(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) + +;; Menus for speedbar... +(defvar mh-folder-speedbar-menu-items + '(["Visit Folder" mh-speed-view + (save-excursion + (set-buffer speedbar-buffer) + (get-text-property (line-beginning-position) 'mh-folder))] + ["Expand nested folders" mh-speed-expand-folder + (and (get-text-property (line-beginning-position) 'mh-children-p) + (not (get-text-property (line-beginning-position) 'mh-expanded)))] + ["Contract nested folders" mh-speed-contract-folder + (and (get-text-property (line-beginning-position) 'mh-children-p) + (get-text-property (line-beginning-position) 'mh-expanded))] + ["Run Flists" mh-speed-flists t] + ["Invalidate cached folders" mh-speed-invalidate-map t]) + "Extra menu items for speedbar.") + +(defvar mh-show-speedbar-menu-items mh-folder-speedbar-menu-items) +(defvar mh-letter-speedbar-menu-items mh-folder-speedbar-menu-items) + +(defmacro mh-speed-select-attached-frame () + "Compatibility macro to handle speedbar versions 0.11a and 0.14beta4." + (cond ((fboundp 'dframe-select-attached-frame) + '(dframe-select-attached-frame speedbar-frame)) + ((boundp 'speedbar-attached-frame) + '(select-frame speedbar-attached-frame)) + (t (error "Installed speedbar version not supported by MH-E")))) + +(defun mh-speed-update-current-folder (force) + "Update speedbar highlighting of the current folder. +The function tries to be smart so that work done is minimized. The currently +highlighted folder is cached and no highlighting happens unless it changes. +Also highlighting is suspended while the speedbar frame is selected. +Otherwise you get the disconcerting behavior of folders popping open on their +own when you are trying to navigate around in the speedbar buffer. + +The update is always carried out if FORCE is non-nil." + (let* ((lastf (selected-frame)) + (newcf (save-excursion + (mh-speed-select-attached-frame) + (prog1 (mh-speed-extract-folder-name (buffer-name)) + (select-frame lastf)))) + (lastb (current-buffer)) + (case-fold-search t)) + (when (or force + (and mh-speed-refresh-flag (not (eq lastf speedbar-frame))) + (and (stringp newcf) + (equal (substring newcf 0 1) "+") + (not (equal newcf mh-speed-last-selected-folder)))) + (setq mh-speed-refresh-flag nil) + (select-frame speedbar-frame) + (set-buffer speedbar-buffer) + + ;; Remove highlight from previous match... + (mh-speed-highlight mh-speed-last-selected-folder + 'mh-speedbar-folder-face) + + ;; If we found a match highlight it... + (when (mh-speed-goto-folder newcf) + (mh-speed-highlight newcf 'mh-speedbar-selected-folder-face)) + + (setq mh-speed-last-selected-folder newcf) + (speedbar-position-cursor-on-line) + (set-window-point (frame-first-window speedbar-frame) (point)) + (set-buffer lastb) + (select-frame lastf)) + (when (eq lastf speedbar-frame) + (setq mh-speed-refresh-flag t)))) + +(defun mh-speed-normal-face (face) + "Return normal face for given FACE." + (cond ((eq face 'mh-speedbar-folder-with-unseen-messages-face) + 'mh-speedbar-folder-face) + ((eq face 'mh-speedbar-selected-folder-with-unseen-messages-face) + 'mh-speedbar-selected-folder-face) + (t face))) + +(defun mh-speed-bold-face (face) + "Return bold face for given FACE." + (cond ((eq face 'mh-speedbar-folder-face) + 'mh-speedbar-folder-with-unseen-messages-face) + ((eq face 'mh-speedbar-selected-folder-face) + 'mh-speedbar-selected-folder-with-unseen-messages-face) + (t face))) + +(defun mh-speed-highlight (folder face) + "Set FOLDER to FACE." + (save-excursion + (speedbar-with-writable + (goto-char (gethash folder mh-speed-folder-map (point))) + (beginning-of-line) + (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) + (setq face (mh-speed-bold-face face)) + (setq face (mh-speed-normal-face face))) + (beginning-of-line) + (when (re-search-forward "\\[.\\] " (line-end-position) t) + (put-text-property (point) (line-end-position) 'face face))))) + +(defun mh-speed-stealth-update (&optional force) + "Do stealth update. +With non-nil FORCE, the update is always carried out." + (cond ((save-excursion (set-buffer speedbar-buffer) + (get-text-property (point-min) 'mh-level)) + ;; Execute this hook and *don't* run anything else + (mh-speed-update-current-folder force) + nil) + ;; Otherwise on to your regular programming + (t t))) + +(defun mh-speed-goto-folder (folder) + "Move point to line containing FOLDER. +The function will expand out parent folders of FOLDER if needed." + (let ((prefix folder) + (suffix-list ()) + (last-slash t)) + (while (and (not (gethash prefix mh-speed-folder-map)) last-slash) + (setq last-slash (mh-search-from-end ?/ prefix)) + (when (integerp last-slash) + (push (substring prefix (1+ last-slash)) suffix-list) + (setq prefix (substring prefix 0 last-slash)))) + (let ((prefix-position (gethash prefix mh-speed-folder-map))) + (if prefix-position + (goto-char prefix-position) + (goto-char (point-min)) + (mh-speed-toggle) + (unless (get-text-property (point) 'mh-expanded) + (mh-speed-toggle)) + (goto-char (gethash prefix mh-speed-folder-map)))) + (while suffix-list + ;; We always need atleast one toggle. We need two if the directory list + ;; is stale since a folder was added. + (when (equal prefix (get-text-property (line-beginning-position) + 'mh-folder)) + (mh-speed-toggle) + (unless (get-text-property (point) 'mh-expanded) + (mh-speed-toggle))) + (setq prefix (format "%s/%s" prefix (pop suffix-list))) + (goto-char (gethash prefix mh-speed-folder-map (point)))) + (beginning-of-line) + (equal folder (get-text-property (point) 'mh-folder)))) + +(defun mh-speed-extract-folder-name (buffer) + "Given an MH-E BUFFER find the folder that should be highlighted. +Do the right thing for the different kinds of buffers that MH-E uses." + (save-excursion + (set-buffer buffer) + (cond ((eq major-mode 'mh-folder-mode) + mh-current-folder) + ((eq major-mode 'mh-show-mode) + (set-buffer mh-show-folder-buffer) + mh-current-folder) + ((eq major-mode 'mh-letter-mode) + (when (string-match mh-user-path buffer-file-name) + (let* ((rel-path (substring buffer-file-name (match-end 0))) + (directory-end (mh-search-from-end ?/ rel-path))) + (when directory-end + (format "+%s" (substring rel-path 0 directory-end))))))))) + +(defun mh-speed-add-buttons (folder level) + "Add speedbar button for FOLDER which is at indented by LEVEL amount." + (let ((folder-list (mh-speed-folders folder))) + (mapc + (lambda (f) + (let* ((folder-name (format "%s%s%s" (or folder "+") + (if folder "/" "") (car f))) + (counts (gethash folder-name mh-speed-flists-cache))) + (speedbar-with-writable + (speedbar-make-tag-line + 'bracket (if (cdr f) ?+ ? ) + 'mh-speed-toggle nil + (format "%s%s" + (car f) + (if counts + (format " (%s/%s)" (car counts) (cdr counts)) + "")) + 'mh-speed-view nil + (if (and counts (> (car counts) 0)) + 'mh-speedbar-folder-with-unseen-messages-face + 'mh-speedbar-folder-face) + level) + (save-excursion + (forward-line -1) + (setf (gethash folder-name mh-speed-folder-map) + (set-marker (make-marker) (1+ (line-beginning-position)))) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-folder ,folder-name + mh-expanded nil + mh-children-p ,(not (not (cdr f))) + ,@(if counts `(mh-count + (,(car counts) . ,(cdr counts))) ()) + mh-level ,level)))))) + folder-list))) + +;;;###mh-autoload +(defun mh-speed-toggle (&rest args) + "Toggle the display of child folders. +The otional ARGS are ignored and there for compatibilty with speedbar." + (interactive) + (declare (ignore args)) + (beginning-of-line) + (let ((parent (get-text-property (point) 'mh-folder)) + (kids-p (get-text-property (point) 'mh-children-p)) + (expanded (get-text-property (point) 'mh-expanded)) + (level (get-text-property (point) 'mh-level)) + (point (point)) + start-region) + (speedbar-with-writable + (cond ((not kids-p) nil) + (expanded + (forward-line) + (setq start-region (point)) + (while (and (get-text-property (point) 'mh-level) + (> (get-text-property (point) 'mh-level) level)) + (remhash (get-text-property (point) 'mh-folder) + mh-speed-folder-map) + (forward-line)) + (delete-region start-region (point)) + (forward-line -1) + (speedbar-change-expand-button-char ?+) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + '(mh-expanded nil))) + (t + (forward-line) + (mh-speed-add-buttons parent (1+ level)) + (goto-char point) + (speedbar-change-expand-button-char ?-) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-expanded t))))))) + +(defalias 'mh-speed-expand-folder 'mh-speed-toggle) +(defalias 'mh-speed-contract-folder 'mh-speed-toggle) + +;;;###mh-autoload +(defun mh-speed-view (&rest args) + "View folder on current line. +Optional ARGS are ignored." + (interactive) + (declare (ignore args)) + (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) + (range (and (stringp folder) (mh-read-msg-range folder)))) + (when (stringp folder) + (speedbar-with-attached-buffer + (mh-visit-folder folder range) + (delete-other-windows))))) + +(defun mh-speed-folders (folder) + "Find the subfolders of FOLDER. +The function avoids running folders unnecessarily by caching the results of +the actual folders call." + (let ((match (gethash folder mh-speed-folders-cache 'no-result))) + (cond ((eq match 'no-result) + (setf (gethash folder mh-speed-folders-cache) + (mh-speed-folders-actual folder))) + (t match)))) + +(defun mh-speed-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." + (let* ((folder (cond ((and (stringp folder) + (equal (substring folder 0 1) "+")) + folder) + (t nil))) + (arg-list `(,(expand-file-name "folders" mh-progs) + nil (t nil) nil "-noheader" "-norecurse" + ,@(if (stringp folder) (list folder) ()))) + (results ())) + (with-temp-buffer + (apply #'call-process arg-list) + (goto-char (point-min)) + (while (not (and (eolp) (bolp))) + (goto-char (line-end-position)) + (let ((has-pos (search-backward " has " (line-beginning-position) t))) + (when (integerp has-pos) + (while (or (equal (char-after has-pos) ? ) + (equal (char-after has-pos) ?+)) + (decf has-pos)) + (incf has-pos) + (let ((name (buffer-substring (line-beginning-position) has-pos))) + (let ((first-char (substring name 0 1))) + (unless (or (string-equal first-char ".") + (string-equal first-char "#") + (string-equal first-char ",")) + (push + (cons name + (search-forward "(others)" (line-end-position) t)) + results))))) + (forward-line 1)))) + (setq results (nreverse results)) + (when (stringp folder) + (setq results (cdr results)) + (let ((folder-name-len (length (format "%s/" (substring folder 1))))) + (setq results (mapcar (lambda (f) + (cons (substring (car f) folder-name-len) + (cdr f))) + results)))) + results)) + +;;;###mh-autoload +(defun mh-speed-flists (force) + "Execute flists -recurse and update message counts. +If FORCE is non-nil the timer is reset." + (interactive (list t)) + (when force + (when (timerp mh-speed-flists-timer) + (cancel-timer mh-speed-flists-timer)) + (setq mh-speed-flists-timer nil) + (when (and (processp mh-speed-flists-process) + (not (eq (process-status mh-speed-flists-process) 'exit))) + (kill-process mh-speed-flists-process) + (setq mh-speed-flists-process nil))) + (unless mh-speed-flists-timer + (setq mh-speed-flists-timer + (run-at-time + nil mh-speed-flists-interval + (lambda () + (unless (and (processp mh-speed-flists-process) + (not (eq (process-status mh-speed-flists-process) + 'exit))) + (setq mh-speed-flists-process + (start-process (expand-file-name "flists" mh-progs) nil + "flists" "-recurse" + "-sequence" (symbol-name mh-unseen-seq))) + (set-process-filter mh-speed-flists-process + 'mh-speed-parse-flists-output))))))) + +;; Copied from mh-make-folder-list-filter... +(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." + (let ((prevailing-match-data (match-data)) + (position 0) + line-end line folder unseen total) + (unwind-protect + (while (setq line-end (string-match "\n" output position)) + (setq line (format "%s%s" + mh-speed-partial-line + (substring output position line-end)) + mh-speed-partial-line "") + (multiple-value-setq (folder unseen total) + (mh-parse-flist-output-line line)) + (when (and folder unseen total) + (setf (gethash folder mh-speed-flists-cache) (cons unseen total)) + (save-excursion + (when (buffer-live-p (get-buffer speedbar-buffer)) + (set-buffer speedbar-buffer) + (speedbar-with-writable + (when (get-text-property (point-min) 'mh-level) + (let ((pos (gethash folder mh-speed-folder-map)) + face) + (when pos + (goto-char pos) + (goto-char (line-beginning-position)) + (cond + ((null (get-text-property (point) 'mh-count)) + (goto-char (line-end-position)) + (setq face (get-text-property (1- (point)) 'face)) + (insert (format " (%s/%s)" unseen total)) + (mh-speed-highlight 'unknown face) + (goto-char (line-beginning-position)) + (add-text-properties (point) (1+ (point)) + `(mh-count (,unseen . ,total)))) + ((not (equal (get-text-property (point) 'mh-count) + (cons unseen total))) + (goto-char (line-end-position)) + (setq face (get-text-property (1- (point)) 'face)) + (re-search-backward " " (line-beginning-position) t) + (delete-region (point) (line-end-position)) + (insert (format " (%s/%s)" unseen total)) + (mh-speed-highlight 'unknown face) + (goto-char (line-beginning-position)) + (add-text-properties + (point) (1+ (point)) + `(mh-count (,unseen . ,total)))))))))))) + (setq position (1+ line-end))) + (set-match-data prevailing-match-data)) + (setq mh-speed-partial-line (substring output position)))) + +;;;###mh-autoload +(defun mh-speed-invalidate-map (folder) + "Remove FOLDER from various optimization caches." + (interactive (list "")) + (save-excursion + (set-buffer speedbar-buffer) + (let* ((speedbar-update-flag nil) + (last-slash (mh-search-from-end ?/ folder)) + (parent (if last-slash (substring folder 0 last-slash) nil)) + (parent-position (gethash parent mh-speed-folder-map)) + (parent-change nil)) + (remhash parent mh-speed-folders-cache) + (remhash folder mh-speed-folders-cache) + (when parent-position + (let ((parent-kids (mh-speed-folders parent))) + (cond ((null parent-kids) + (setq parent-change ?+)) + ((and (null (cdr parent-kids)) + (equal (if last-slash + (substring folder (1+ last-slash)) + (substring folder 1)) + (caar parent-kids))) + (setq parent-change ? )))) + (goto-char parent-position) + (when (equal (get-text-property (line-beginning-position) 'mh-folder) + parent) + (when (get-text-property (line-beginning-position) 'mh-expanded) + (mh-speed-toggle)) + (when parent-change + (speedbar-with-writable + (mh-speedbar-change-expand-button-char parent-change) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-children-p ,(equal parent-change ?+))))) + (mh-speed-highlight mh-speed-last-selected-folder + 'mh-speedbar-folder-face) + (setq mh-speed-last-selected-folder nil) + (setq mh-speed-refresh-flag t))) + (when (equal folder "") + (clrhash mh-speed-folders-cache))))) + +;;;###mh-autoload +(defun mh-speed-add-folder (folder) + "Add FOLDER since it is being created. +The function invalidates the latest ancestor that is present." + (save-excursion + (set-buffer speedbar-buffer) + (let ((speedbar-update-flag nil) + (last-slash (mh-search-from-end ?/ folder)) + (ancestor folder) + (ancestor-pos nil)) + (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)) + (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))) + (speedbar-with-writable + (mh-speedbar-change-expand-button-char ?+) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-children-p t))) + (when (get-text-property (line-beginning-position) 'mh-expanded) + (mh-speed-toggle)) + (remhash ancestor mh-speed-folders-cache) + (setq mh-speed-refresh-flag t)))) + +;; Make it slightly more general to allow for [ ] buttons to be changed to +;; [+]. +(defun mh-speedbar-change-expand-button-char (char) + "Change the expansion button character to CHAR for the current line." + (save-excursion + (beginning-of-line) + (if (re-search-forward "\\[.\\]" (line-end-position) t) + (speedbar-with-writable + (backward-char 2) + (delete-char 1) + (insert-char char 1 t) + (put-text-property (point) (1- (point)) 'invisible nil) + ;; make sure we fix the image on the text here. + (speedbar-insert-image-button-maybe (- (point) 2) 3))))) + +(provide 'mh-speed) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-speed.el ends here