X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e583523a108624f7fd0c28294010b19daae5ab97..10d1d0af5f6421603cd841e0c1c5805e2b2fb67d:/lisp/mh-e/mh-speed.el diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 5c7f5cda3b..c8ce4d837c 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -1,6 +1,6 @@ -;;; mh-speed.el --- Speedbar interface for MH-E. +;;; mh-speed.el --- MH-E speedbar support -;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Satyaki Das ;; Maintainer: Bill Wohler @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, 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 @@ -20,27 +20,24 @@ ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: -;; Future versions should only use flists. -;; Speedbar support for MH-E package. +;; Future versions should only use flists. ;;; Change Log: ;;; Code: -;; Requires -(eval-when-compile (require 'mh-acros)) -(mh-require-cl) (require 'mh-e) +(mh-require-cl) + +(require 'gnus-util) (require 'speedbar) (require 'timer) -;; Global variables +;; 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)) @@ -49,7 +46,10 @@ (defvar mh-speed-flists-timer nil) (defvar mh-speed-partial-line "") -;; Add our stealth update function + + +;;; Speedbar Hook + (unless (member 'mh-speed-stealth-update (cdr (assoc "files" speedbar-stealthy-function-list))) ;; Is changing constant lists in elisp safe? @@ -58,7 +58,132 @@ (push 'mh-speed-stealth-update (cdr (assoc "files" speedbar-stealthy-function-list)))) -;; Functions called by speedbar to initialize display... + + +;;; Speedbar Menus + +(defvar mh-folder-speedbar-menu-items + '("--" + ["Visit Folder" mh-speed-view + (save-excursion + (set-buffer speedbar-buffer) + (get-text-property (mh-line-beginning-position) 'mh-folder))] + ["Expand Nested Folders" mh-speed-expand-folder + (and (get-text-property (mh-line-beginning-position) 'mh-children-p) + (not (get-text-property (mh-line-beginning-position) 'mh-expanded)))] + ["Contract Nested Folders" mh-speed-contract-folder + (and (get-text-property (mh-line-beginning-position) 'mh-children-p) + (get-text-property (mh-line-beginning-position) 'mh-expanded))] + ["Refresh Speedbar" mh-speed-refresh 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) + + + +;;; Speedbar Keys + +(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 + "r" mh-speed-refresh) + +(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) + + + +;;; Speedbar Commands + +;; Alphabetical. + +(defalias 'mh-speed-contract-folder 'mh-speed-toggle) + +(defalias 'mh-speed-expand-folder 'mh-speed-toggle) + +(defun mh-speed-refresh () + "Regenerates the list of folders in the speedbar. + +Run this command if you've added or deleted a folder, or want to +update the unseen message count before the next automatic +update." + (interactive) + (mh-speed-flists t) + (mh-speed-invalidate-map "")) + +(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-toggle (&rest args) + "Toggle the display of child folders in the speedbar. +The optional ARGS from speedbar are ignored." + (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)) + (let ((folder (get-text-property (point) 'mh-folder))) + (when (gethash folder mh-speed-folder-map) + (set-marker (gethash folder mh-speed-folder-map) nil) + (remhash folder mh-speed-folder-map))) + (forward-line)) + (delete-region start-region (point)) + (forward-line -1) + (speedbar-change-expand-button-char ?+) + (add-text-properties + (mh-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 + (mh-line-beginning-position) (1+ (line-beginning-position)) + `(mh-expanded t))))))) + +(defun mh-speed-view (&rest args) + "Visits the selected folder just as if you had used \\\\[mh-visit-folder]. +The optional ARGS from speedbar are ignored." + (interactive) + (declare (ignore args)) + (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) + (range (and (stringp folder) + (mh-read-range "Scan" folder t nil nil + mh-interpret-number-as-range-flag)))) + (when (stringp folder) + (speedbar-with-attached-buffer + (mh-visit-folder folder range) + (delete-other-windows))))) + + + +;;; Support Routines + ;;;###mh-autoload (defun mh-folder-speedbar-buttons (buffer) "Interface function to create MH-E speedbar buffer. @@ -72,9 +197,9 @@ created." (forward-line -1) (setf (gethash nil mh-speed-folder-map) (set-marker (or (gethash nil mh-speed-folder-map) (make-marker)) - (1+ (line-beginning-position)))) + (1+ (mh-line-beginning-position)))) (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) + (mh-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-update-interval 0) @@ -85,37 +210,6 @@ created." ;;;###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 - "r" mh-speed-refresh) - -(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))] - ["Refresh Speedbar" mh-speed-refresh 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) @@ -166,6 +260,19 @@ The update is always carried out if FORCE is non-nil." (when (eq lastf speedbar-frame) (setq mh-speed-refresh-flag t)))) +(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]+)" (mh-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 "\\[.\\] " (mh-line-end-position) t) + (put-text-property (point) (mh-line-end-position) 'face face))))) + (defun mh-speed-normal-face (face) "Return normal face for given FACE." (cond ((eq face 'mh-speedbar-folder-with-unseen-messages) @@ -182,30 +289,6 @@ The update is always carried out if FORCE is non-nil." 'mh-speedbar-selected-folder-with-unseen-messages) (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." @@ -228,7 +311,7 @@ The function will expand out parent folders of FOLDER if needed." (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) + (when (equal prefix (get-text-property (mh-line-beginning-position) 'mh-folder)) (mh-speed-toggle) (unless (get-text-property (point) 'mh-expanded) @@ -283,9 +366,9 @@ uses." (setf (gethash folder-name mh-speed-folder-map) (set-marker (or (gethash folder-name mh-speed-folder-map) (make-marker)) - (1+ (line-beginning-position)))) + (1+ (mh-line-beginning-position)))) (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) + (mh-line-beginning-position) (1+ (mh-line-beginning-position)) `(mh-folder ,folder-name mh-expanded nil mh-children-p ,(not (not (cdr f))) @@ -294,64 +377,6 @@ uses." mh-level ,level)))))) folder-list))) -;;;###mh-autoload -(defun mh-speed-toggle (&rest args) - "Toggle the display of child folders in the speedbar. -The optional ARGS from speedbar are ignored." - (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)) - (let ((folder (get-text-property (point) 'mh-folder))) - (when (gethash folder mh-speed-folder-map) - (set-marker (gethash folder mh-speed-folder-map) nil) - (remhash 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) - "Visits the selected folder just as if you had used \\\\[mh-visit-folder]. -The optional ARGS from speedbar are ignored." - (interactive) - (declare (ignore args)) - (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) - (range (and (stringp folder) - (mh-read-range "Scan" folder t nil nil - mh-interpret-number-as-range-flag)))) - (when (stringp folder) - (speedbar-with-attached-buffer - (mh-visit-folder folder range) - (delete-other-windows))))) - (defvar mh-speed-current-folder nil) (defvar mh-speed-flists-folder nil) @@ -373,7 +398,7 @@ flists is run only for that one folder." (interactive (list t)) (when force (when mh-speed-flists-timer - (cancel-timer mh-speed-flists-timer) + (mh-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))) @@ -414,6 +439,7 @@ flists is run only for that one folder." 'mh-speed-parse-flists-output))))))) ;; Copied from mh-make-folder-list-filter... +;; XXX Refactor to use mh-make-folder-list-filer? (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 @@ -443,25 +469,25 @@ be handled next." face) (when pos (goto-char pos) - (goto-char (line-beginning-position)) + (goto-char (mh-line-beginning-position)) (cond ((null (get-text-property (point) 'mh-count)) - (goto-char (line-end-position)) + (goto-char (mh-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)) + (goto-char (mh-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)) + (goto-char (mh-line-end-position)) (setq face (get-text-property (1- (point)) 'face)) - (re-search-backward " " (line-beginning-position) t) - (delete-region (point) (line-end-position)) + (re-search-backward " " (mh-line-beginning-position) t) + (delete-region (point) (mh-line-end-position)) (insert (format " (%s/%s)" unseen total)) (mh-speed-highlight 'unknown face) - (goto-char (line-beginning-position)) + (goto-char (mh-line-beginning-position)) (add-text-properties (point) (1+ (point)) `(mh-count (,unseen . ,total)))))))))))) @@ -491,31 +517,37 @@ be handled next." (caar parent-kids))) (setq parent-change ? )))) (goto-char parent-position) - (when (equal (get-text-property (line-beginning-position) 'mh-folder) + (when (equal (get-text-property (mh-line-beginning-position) 'mh-folder) parent) - (when (get-text-property (line-beginning-position) 'mh-expanded) + (when (get-text-property (mh-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-line-beginning-position) (1+ (mh-line-beginning-position)) `(mh-children-p ,(equal parent-change ?+))))) (mh-speed-highlight mh-speed-last-selected-folder 'mh-speedbar-folder) (setq mh-speed-last-selected-folder nil) (setq mh-speed-refresh-flag t))) (when (equal folder "") - (clrhash mh-sub-folders-cache))))) - -(defun mh-speed-refresh () - "Regenerates the list of folders in the speedbar. + (mh-clear-sub-folders-cache))))) -Run this command if you've added or deleted a folder, or want to -update the unseen message count before the next automatic -update." - (interactive) - (mh-speed-flists t) - (mh-speed-invalidate-map "")) +;; 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 "\\[.\\]" (mh-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. + (mh-funcall-if-exists + speedbar-insert-image-button-maybe (- (point) 2) 3))))) ;;;###mh-autoload (defun mh-speed-add-folder (folder) @@ -539,28 +571,12 @@ The function invalidates the latest ancestor that is present." (speedbar-with-writable (mh-speedbar-change-expand-button-char ?+) (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) + (mh-line-beginning-position) (1+ (mh-line-beginning-position)) `(mh-children-p t))) - (when (get-text-property (line-beginning-position) 'mh-expanded) + (when (get-text-property (mh-line-beginning-position) 'mh-expanded) (mh-speed-toggle)) (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. - (mh-funcall-if-exists - speedbar-insert-image-button-maybe (- (point) 2) 3))))) - (provide 'mh-speed) ;; Local Variables: