HCoop / bpt / emacs.git / blame
| Commit | Line | Data |
|---|---|---|
| bdcfe844 BW |
1 | ;;; mh-speed.el --- Speedbar interface for MH-E. |
| 2 | ||
| 3 | ;; Copyright (C) 2002 Free Software Foundation, Inc. | |
| 4 | ||
| c3d9274a | 5 | ;; Author: Satyaki Das <satyaki@theforce.stanford.edu> |
| bdcfe844 BW |
6 | ;; Maintainer: Bill Wohler <wohler@newt.com> |
| 7 | ;; Keywords: mail | |
| 8 | ;; See: mh-e.el | |
| 9 | ||
| 10 | ;; This file is part of GNU Emacs. | |
| 11 | ||
| 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 13 | ;; it under the terms of the GNU General Public License as published by | |
| 14 | ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 | ;; any later version. | |
| 16 | ||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 20 | ;; GNU General Public License for more details. | |
| 21 | ||
| 22 | ;; You should have received a copy of the GNU General Public License | |
| 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 24 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 25 | ;; Boston, MA 02111-1307, USA. | |
| 26 | ||
| 27 | ;;; Commentary: | |
| 28 | ;; Future versions should only use flists. | |
| 29 | ||
| 30 | ;; Speedbar support for MH-E package. | |
| 31 | ||
| 32 | ;;; Change Log: | |
| 33 | ||
| 942da20c | 34 | ;; $Id: mh-speed.el,v 1.2 2003/01/08 23:21:16 wohler Exp $ |
| bdcfe844 BW |
35 | |
| 36 | ;;; Code: | |
| 37 | ||
| 38 | ;; Requires | |
| 39 | (require 'cl) | |
| bdcfe844 BW |
40 | (require 'mh-e) |
| 41 | (require 'speedbar) | |
| 42 | ||
| bdcfe844 BW |
43 | ;; Global variables |
| 44 | (defvar mh-speed-refresh-flag nil) | |
| 45 | (defvar mh-speed-last-selected-folder nil) | |
| 46 | (defvar mh-speed-folder-map (make-hash-table :test #'equal)) | |
| 47 | (defvar mh-speed-folders-cache (make-hash-table :test #'equal)) | |
| 48 | (defvar mh-speed-flists-cache (make-hash-table :test #'equal)) | |
| 49 | (defvar mh-speed-flists-process nil) | |
| 50 | (defvar mh-speed-flists-timer nil) | |
| 51 | (defvar mh-speed-partial-line "") | |
| 52 | ||
| 53 | ;; Add our stealth update function | |
| 54 | (unless (member 'mh-speed-stealth-update | |
| 55 | (cdr (assoc "files" speedbar-stealthy-function-list))) | |
| 56 | ;; Is changing constant lists in elisp safe? | |
| 57 | (setq speedbar-stealthy-function-list | |
| 58 | (copy-tree speedbar-stealthy-function-list)) | |
| 59 | (push 'mh-speed-stealth-update | |
| 60 | (cdr (assoc "files" speedbar-stealthy-function-list)))) | |
| 61 | ||
| 62 | ;; Functions called by speedbar to initialize display... | |
| c3d9274a | 63 | ;;;###mh-autoload |
| bdcfe844 BW |
64 | (defun mh-folder-speedbar-buttons (buffer) |
| 65 | "Interface function to create MH-E speedbar buffer. | |
| 66 | BUFFER is the MH-E buffer for which the speedbar buffer is to be created." | |
| 67 | (unless (get-text-property (point-min) 'mh-level) | |
| 68 | (erase-buffer) | |
| 69 | (clrhash mh-speed-folder-map) | |
| 70 | (speedbar-make-tag-line 'bracket ?+ 'mh-speed-toggle nil " " 'ignore nil | |
| 71 | 'mh-speedbar-folder-face 0) | |
| 72 | (forward-line -1) | |
| 73 | (setf (gethash nil mh-speed-folder-map) | |
| 74 | (set-marker (make-marker) (1+ (line-beginning-position)))) | |
| 75 | (add-text-properties | |
| 76 | (line-beginning-position) (1+ (line-beginning-position)) | |
| 77 | `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) | |
| 78 | (mh-speed-stealth-update t) | |
| 79 | (when mh-speed-run-flists-flag | |
| 80 | (mh-speed-flists nil)))) | |
| 81 | ||
| c3d9274a | 82 | ;;;###mh-autoload |
| bdcfe844 | 83 | (defalias 'mh-show-speedbar-buttons 'mh-folder-speedbar-buttons) |
| c3d9274a | 84 | ;;;###mh-autoload |
| bdcfe844 BW |
85 | (defalias 'mh-letter-speedbar-buttons 'mh-folder-speedbar-buttons) |
| 86 | ||
| 87 | ;; Keymaps for speedbar... | |
| 88 | (defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) | |
| 89 | "Specialized speedbar keymap for MH-E buffers.") | |
| 90 | (gnus-define-keys mh-folder-speedbar-key-map | |
| c3d9274a BW |
91 | "+" mh-speed-expand-folder |
| 92 | "-" mh-speed-contract-folder | |
| 93 | "\r" mh-speed-view | |
| 94 | "f" mh-speed-flists | |
| 95 | "i" mh-speed-invalidate-map) | |
| bdcfe844 BW |
96 | |
| 97 | (defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) | |
| bdcfe844 BW |
98 | (defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) |
| 99 | ||
| 100 | ;; Menus for speedbar... | |
| 101 | (defvar mh-folder-speedbar-menu-items | |
| 102 | '(["Visit Folder" mh-speed-view | |
| 103 | (save-excursion | |
| 104 | (set-buffer speedbar-buffer) | |
| 105 | (get-text-property (line-beginning-position) 'mh-folder))] | |
| 106 | ["Expand nested folders" mh-speed-expand-folder | |
| 107 | (and (get-text-property (line-beginning-position) 'mh-children-p) | |
| 108 | (not (get-text-property (line-beginning-position) 'mh-expanded)))] | |
| 109 | ["Contract nested folders" mh-speed-contract-folder | |
| 110 | (and (get-text-property (line-beginning-position) 'mh-children-p) | |
| 111 | (get-text-property (line-beginning-position) 'mh-expanded))] | |
| 112 | ["Run Flists" mh-speed-flists t] | |
| 113 | ["Invalidate cached folders" mh-speed-invalidate-map t]) | |
| 114 | "Extra menu items for speedbar.") | |
| 115 | ||
| 116 | (defvar mh-show-speedbar-menu-items mh-folder-speedbar-menu-items) | |
| bdcfe844 BW |
117 | (defvar mh-letter-speedbar-menu-items mh-folder-speedbar-menu-items) |
| 118 | ||
| 119 | (defmacro mh-speed-select-attached-frame () | |
| 120 | "Compatibility macro to handle speedbar versions 0.11a and 0.14beta4." | |
| 121 | (cond ((fboundp 'dframe-select-attached-frame) | |
| 122 | '(dframe-select-attached-frame speedbar-frame)) | |
| 123 | ((boundp 'speedbar-attached-frame) | |
| 124 | '(select-frame speedbar-attached-frame)) | |
| 125 | (t (error "Installed speedbar version not supported by MH-E")))) | |
| 126 | ||
| 127 | (defun mh-speed-update-current-folder (force) | |
| 128 | "Update speedbar highlighting of the current folder. | |
| 129 | The function tries to be smart so that work done is minimized. The currently | |
| 130 | highlighted folder is cached and no highlighting happens unless it changes. | |
| 131 | Also highlighting is suspended while the speedbar frame is selected. | |
| 132 | Otherwise you get the disconcerting behavior of folders popping open on their | |
| 133 | own when you are trying to navigate around in the speedbar buffer. | |
| 134 | ||
| 135 | The update is always carried out if FORCE is non-nil." | |
| 136 | (let* ((lastf (selected-frame)) | |
| c3d9274a | 137 | (newcf (save-excursion |
| bdcfe844 BW |
138 | (mh-speed-select-attached-frame) |
| 139 | (prog1 (mh-speed-extract-folder-name (buffer-name)) | |
| 140 | (select-frame lastf)))) | |
| c3d9274a BW |
141 | (lastb (current-buffer)) |
| 142 | (case-fold-search t)) | |
| bdcfe844 BW |
143 | (when (or force |
| 144 | (and mh-speed-refresh-flag (not (eq lastf speedbar-frame))) | |
| 145 | (and (stringp newcf) | |
| 146 | (equal (substring newcf 0 1) "+") | |
| 147 | (not (equal newcf mh-speed-last-selected-folder)))) | |
| 148 | (setq mh-speed-refresh-flag nil) | |
| 149 | (select-frame speedbar-frame) | |
| 150 | (set-buffer speedbar-buffer) | |
| 151 | ||
| 152 | ;; Remove highlight from previous match... | |
| 153 | (mh-speed-highlight mh-speed-last-selected-folder | |
| 154 | 'mh-speedbar-folder-face) | |
| 155 | ||
| 156 | ;; If we found a match highlight it... | |
| 157 | (when (mh-speed-goto-folder newcf) | |
| 158 | (mh-speed-highlight newcf 'mh-speedbar-selected-folder-face)) | |
| 159 | ||
| 160 | (setq mh-speed-last-selected-folder newcf) | |
| 161 | (speedbar-position-cursor-on-line) | |
| 162 | (set-window-point (frame-first-window speedbar-frame) (point)) | |
| 163 | (set-buffer lastb) | |
| 164 | (select-frame lastf)) | |
| 165 | (when (eq lastf speedbar-frame) | |
| 166 | (setq mh-speed-refresh-flag t)))) | |
| 167 | ||
| 168 | (defun mh-speed-normal-face (face) | |
| 169 | "Return normal face for given FACE." | |
| 170 | (cond ((eq face 'mh-speedbar-folder-with-unseen-messages-face) | |
| 171 | 'mh-speedbar-folder-face) | |
| 172 | ((eq face 'mh-speedbar-selected-folder-with-unseen-messages-face) | |
| 173 | 'mh-speedbar-selected-folder-face) | |
| 174 | (t face))) | |
| 175 | ||
| 176 | (defun mh-speed-bold-face (face) | |
| 177 | "Return bold face for given FACE." | |
| 178 | (cond ((eq face 'mh-speedbar-folder-face) | |
| 179 | 'mh-speedbar-folder-with-unseen-messages-face) | |
| 180 | ((eq face 'mh-speedbar-selected-folder-face) | |
| 181 | 'mh-speedbar-selected-folder-with-unseen-messages-face) | |
| 182 | (t face))) | |
| 183 | ||
| 184 | (defun mh-speed-highlight (folder face) | |
| 185 | "Set FOLDER to FACE." | |
| 186 | (save-excursion | |
| 187 | (speedbar-with-writable | |
| 188 | (goto-char (gethash folder mh-speed-folder-map (point))) | |
| 189 | (beginning-of-line) | |
| 190 | (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) | |
| 191 | (setq face (mh-speed-bold-face face)) | |
| 192 | (setq face (mh-speed-normal-face face))) | |
| 193 | (beginning-of-line) | |
| 194 | (when (re-search-forward "\\[.\\] " (line-end-position) t) | |
| 195 | (put-text-property (point) (line-end-position) 'face face))))) | |
| 196 | ||
| 197 | (defun mh-speed-stealth-update (&optional force) | |
| 198 | "Do stealth update. | |
| 199 | With non-nil FORCE, the update is always carried out." | |
| 200 | (cond ((save-excursion (set-buffer speedbar-buffer) | |
| 201 | (get-text-property (point-min) 'mh-level)) | |
| 202 | ;; Execute this hook and *don't* run anything else | |
| 203 | (mh-speed-update-current-folder force) | |
| 204 | nil) | |
| 205 | ;; Otherwise on to your regular programming | |
| 206 | (t t))) | |
| 207 | ||
| 208 | (defun mh-speed-goto-folder (folder) | |
| 209 | "Move point to line containing FOLDER. | |
| 210 | The function will expand out parent folders of FOLDER if needed." | |
| 211 | (let ((prefix folder) | |
| 212 | (suffix-list ()) | |
| 213 | (last-slash t)) | |
| 214 | (while (and (not (gethash prefix mh-speed-folder-map)) last-slash) | |
| c3d9274a | 215 | (setq last-slash (mh-search-from-end ?/ prefix)) |
| bdcfe844 BW |
216 | (when (integerp last-slash) |
| 217 | (push (substring prefix (1+ last-slash)) suffix-list) | |
| 218 | (setq prefix (substring prefix 0 last-slash)))) | |
| 219 | (let ((prefix-position (gethash prefix mh-speed-folder-map))) | |
| 220 | (if prefix-position | |
| 221 | (goto-char prefix-position) | |
| 222 | (goto-char (point-min)) | |
| 223 | (mh-speed-toggle) | |
| 224 | (unless (get-text-property (point) 'mh-expanded) | |
| 225 | (mh-speed-toggle)) | |
| 226 | (goto-char (gethash prefix mh-speed-folder-map)))) | |
| 227 | (while suffix-list | |
| 228 | ;; We always need atleast one toggle. We need two if the directory list | |
| 229 | ;; is stale since a folder was added. | |
| 230 | (when (equal prefix (get-text-property (line-beginning-position) | |
| 231 | 'mh-folder)) | |
| 232 | (mh-speed-toggle) | |
| 233 | (unless (get-text-property (point) 'mh-expanded) | |
| 234 | (mh-speed-toggle))) | |
| 235 | (setq prefix (format "%s/%s" prefix (pop suffix-list))) | |
| 236 | (goto-char (gethash prefix mh-speed-folder-map (point)))) | |
| 237 | (beginning-of-line) | |
| 238 | (equal folder (get-text-property (point) 'mh-folder)))) | |
| 239 | ||
| 240 | (defun mh-speed-extract-folder-name (buffer) | |
| 241 | "Given an MH-E BUFFER find the folder that should be highlighted. | |
| 242 | Do the right thing for the different kinds of buffers that MH-E uses." | |
| 243 | (save-excursion | |
| 244 | (set-buffer buffer) | |
| 245 | (cond ((eq major-mode 'mh-folder-mode) | |
| 246 | mh-current-folder) | |
| 247 | ((eq major-mode 'mh-show-mode) | |
| 248 | (set-buffer mh-show-folder-buffer) | |
| 249 | mh-current-folder) | |
| c3d9274a | 250 | ((eq major-mode 'mh-letter-mode) |
| bdcfe844 BW |
251 | (when (string-match mh-user-path buffer-file-name) |
| 252 | (let* ((rel-path (substring buffer-file-name (match-end 0))) | |
| c3d9274a | 253 | (directory-end (mh-search-from-end ?/ rel-path))) |
| bdcfe844 BW |
254 | (when directory-end |
| 255 | (format "+%s" (substring rel-path 0 directory-end))))))))) | |
| 256 | ||
| 257 | (defun mh-speed-add-buttons (folder level) | |
| 258 | "Add speedbar button for FOLDER which is at indented by LEVEL amount." | |
| 259 | (let ((folder-list (mh-speed-folders folder))) | |
| 260 | (mapc | |
| 261 | (lambda (f) | |
| 262 | (let* ((folder-name (format "%s%s%s" (or folder "+") | |
| 263 | (if folder "/" "") (car f))) | |
| 264 | (counts (gethash folder-name mh-speed-flists-cache))) | |
| 265 | (speedbar-with-writable | |
| 266 | (speedbar-make-tag-line | |
| 267 | 'bracket (if (cdr f) ?+ ? ) | |
| 268 | 'mh-speed-toggle nil | |
| 269 | (format "%s%s" | |
| 270 | (car f) | |
| 271 | (if counts | |
| 272 | (format " (%s/%s)" (car counts) (cdr counts)) | |
| 273 | "")) | |
| 274 | 'mh-speed-view nil | |
| 275 | (if (and counts (> (car counts) 0)) | |
| 276 | 'mh-speedbar-folder-with-unseen-messages-face | |
| 277 | 'mh-speedbar-folder-face) | |
| 278 | level) | |
| 279 | (save-excursion | |
| 280 | (forward-line -1) | |
| 281 | (setf (gethash folder-name mh-speed-folder-map) | |
| 282 | (set-marker (make-marker) (1+ (line-beginning-position)))) | |
| 283 | (add-text-properties | |
| 284 | (line-beginning-position) (1+ (line-beginning-position)) | |
| 285 | `(mh-folder ,folder-name | |
| c3d9274a BW |
286 | mh-expanded nil |
| 287 | mh-children-p ,(not (not (cdr f))) | |
| 288 | ,@(if counts `(mh-count | |
| 289 | (,(car counts) . ,(cdr counts))) ()) | |
| 290 | mh-level ,level)))))) | |
| bdcfe844 BW |
291 | folder-list))) |
| 292 | ||
| c3d9274a | 293 | ;;;###mh-autoload |
| bdcfe844 BW |
294 | (defun mh-speed-toggle (&rest args) |
| 295 | "Toggle the display of child folders. | |
| 296 | The otional ARGS are ignored and there for compatibilty with speedbar." | |
| 297 | (interactive) | |
| 298 | (declare (ignore args)) | |
| 299 | (beginning-of-line) | |
| 300 | (let ((parent (get-text-property (point) 'mh-folder)) | |
| 301 | (kids-p (get-text-property (point) 'mh-children-p)) | |
| 302 | (expanded (get-text-property (point) 'mh-expanded)) | |
| 303 | (level (get-text-property (point) 'mh-level)) | |
| 304 | (point (point)) | |
| 305 | start-region) | |
| 306 | (speedbar-with-writable | |
| 307 | (cond ((not kids-p) nil) | |
| 308 | (expanded | |
| 309 | (forward-line) | |
| 310 | (setq start-region (point)) | |
| 311 | (while (and (get-text-property (point) 'mh-level) | |
| 312 | (> (get-text-property (point) 'mh-level) level)) | |
| 313 | (remhash (get-text-property (point) 'mh-folder) | |
| 314 | mh-speed-folder-map) | |
| 315 | (forward-line)) | |
| 316 | (delete-region start-region (point)) | |
| 317 | (forward-line -1) | |
| 318 | (speedbar-change-expand-button-char ?+) | |
| 319 | (add-text-properties | |
| 320 | (line-beginning-position) (1+ (line-beginning-position)) | |
| 321 | '(mh-expanded nil))) | |
| 322 | (t | |
| 323 | (forward-line) | |
| 324 | (mh-speed-add-buttons parent (1+ level)) | |
| 325 | (goto-char point) | |
| 326 | (speedbar-change-expand-button-char ?-) | |
| 327 | (add-text-properties | |
| 328 | (line-beginning-position) (1+ (line-beginning-position)) | |
| 329 | `(mh-expanded t))))))) | |
| 330 | ||
| 331 | (defalias 'mh-speed-expand-folder 'mh-speed-toggle) | |
| 332 | (defalias 'mh-speed-contract-folder 'mh-speed-toggle) | |
| 333 | ||
| c3d9274a | 334 | ;;;###mh-autoload |
| bdcfe844 BW |
335 | (defun mh-speed-view (&rest args) |
| 336 | "View folder on current line. | |
| 337 | Optional ARGS are ignored." | |
| 338 | (interactive) | |
| 339 | (declare (ignore args)) | |
| 340 | (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) | |
| c3d9274a | 341 | (range (and (stringp folder) (mh-read-msg-range folder)))) |
| bdcfe844 BW |
342 | (when (stringp folder) |
| 343 | (speedbar-with-attached-buffer | |
| 344 | (mh-visit-folder folder range) | |
| 345 | (delete-other-windows))))) | |
| 346 | ||
| 347 | (defun mh-speed-folders (folder) | |
| 348 | "Find the subfolders of FOLDER. | |
| 349 | The function avoids running folders unnecessarily by caching the results of | |
| 350 | the actual folders call." | |
| 351 | (let ((match (gethash folder mh-speed-folders-cache 'no-result))) | |
| 352 | (cond ((eq match 'no-result) | |
| 353 | (setf (gethash folder mh-speed-folders-cache) | |
| 354 | (mh-speed-folders-actual folder))) | |
| 355 | (t match)))) | |
| 356 | ||
| 357 | (defun mh-speed-folders-actual (folder) | |
| 358 | "Execute the command folders to return the sub-folders of FOLDER. | |
| 359 | Filters out the folder names that start with \".\" so that directories that | |
| 360 | aren't usually mail folders are hidden." | |
| 361 | (let* ((folder (cond ((and (stringp folder) | |
| 362 | (equal (substring folder 0 1) "+")) | |
| 363 | folder) | |
| 364 | (t nil))) | |
| 365 | (arg-list `(,(expand-file-name "folders" mh-progs) | |
| 366 | nil (t nil) nil "-noheader" "-norecurse" | |
| 367 | ,@(if (stringp folder) (list folder) ()))) | |
| 368 | (results ())) | |
| 369 | (with-temp-buffer | |
| 370 | (apply #'call-process arg-list) | |
| 371 | (goto-char (point-min)) | |
| 372 | (while (not (and (eolp) (bolp))) | |
| c3d9274a BW |
373 | (goto-char (line-end-position)) |
| 374 | (let ((has-pos (search-backward " has " (line-beginning-position) t))) | |
| 375 | (when (integerp has-pos) | |
| 376 | (while (or (equal (char-after has-pos) ? ) | |
| 377 | (equal (char-after has-pos) ?+)) | |
| 378 | (decf has-pos)) | |
| 379 | (incf has-pos) | |
| 380 | (let ((name (buffer-substring (line-beginning-position) has-pos))) | |
| bdcfe844 BW |
381 | (let ((first-char (substring name 0 1))) |
| 382 | (unless (or (string-equal first-char ".") | |
| 383 | (string-equal first-char "#") | |
| 384 | (string-equal first-char ",")) | |
| 385 | (push | |
| c3d9274a BW |
386 | (cons name |
| 387 | (search-forward "(others)" (line-end-position) t)) | |
| 388 | results))))) | |
| bdcfe844 BW |
389 | (forward-line 1)))) |
| 390 | (setq results (nreverse results)) | |
| 391 | (when (stringp folder) | |
| 392 | (setq results (cdr results)) | |
| 393 | (let ((folder-name-len (length (format "%s/" (substring folder 1))))) | |
| 394 | (setq results (mapcar (lambda (f) | |
| 395 | (cons (substring (car f) folder-name-len) | |
| 396 | (cdr f))) | |
| 397 | results)))) | |
| 398 | results)) | |
| 399 | ||
| c3d9274a | 400 | ;;;###mh-autoload |
| bdcfe844 BW |
401 | (defun mh-speed-flists (force) |
| 402 | "Execute flists -recurse and update message counts. | |
| 403 | If FORCE is non-nil the timer is reset." | |
| 404 | (interactive (list t)) | |
| 405 | (when force | |
| 406 | (when (timerp mh-speed-flists-timer) | |
| 407 | (cancel-timer mh-speed-flists-timer)) | |
| 408 | (setq mh-speed-flists-timer nil) | |
| 409 | (when (and (processp mh-speed-flists-process) | |
| 410 | (not (eq (process-status mh-speed-flists-process) 'exit))) | |
| 411 | (kill-process mh-speed-flists-process) | |
| 412 | (setq mh-speed-flists-process nil))) | |
| 413 | (unless mh-speed-flists-timer | |
| 414 | (setq mh-speed-flists-timer | |
| 415 | (run-at-time | |
| 416 | nil mh-speed-flists-interval | |
| 417 | (lambda () | |
| 418 | (unless (and (processp mh-speed-flists-process) | |
| 419 | (not (eq (process-status mh-speed-flists-process) | |
| 420 | 'exit))) | |
| 421 | (setq mh-speed-flists-process | |
| 422 | (start-process (expand-file-name "flists" mh-progs) nil | |
| c3d9274a BW |
423 | "flists" "-recurse" |
| 424 | "-sequence" (symbol-name mh-unseen-seq))) | |
| bdcfe844 BW |
425 | (set-process-filter mh-speed-flists-process |
| 426 | 'mh-speed-parse-flists-output))))))) | |
| 427 | ||
| 428 | ;; Copied from mh-make-folder-list-filter... | |
| 429 | (defun mh-speed-parse-flists-output (process output) | |
| 430 | "Parse the incremental results from flists. | |
| 431 | PROCESS is the flists process and OUTPUT is the results that must be handled | |
| 432 | next." | |
| 433 | (let ((prevailing-match-data (match-data)) | |
| 434 | (position 0) | |
| 435 | line-end line folder unseen total) | |
| 436 | (unwind-protect | |
| 437 | (while (setq line-end (string-match "\n" output position)) | |
| 438 | (setq line (format "%s%s" | |
| 439 | mh-speed-partial-line | |
| 440 | (substring output position line-end)) | |
| 441 | mh-speed-partial-line "") | |
| c3d9274a BW |
442 | (multiple-value-setq (folder unseen total) |
| 443 | (mh-parse-flist-output-line line)) | |
| 444 | (when (and folder unseen total) | |
| 445 | (setf (gethash folder mh-speed-flists-cache) (cons unseen total)) | |
| 446 | (save-excursion | |
| 447 | (when (buffer-live-p (get-buffer speedbar-buffer)) | |
| 448 | (set-buffer speedbar-buffer) | |
| 449 | (speedbar-with-writable | |
| 450 | (when (get-text-property (point-min) 'mh-level) | |
| 451 | (let ((pos (gethash folder mh-speed-folder-map)) | |
| 452 | face) | |
| 453 | (when pos | |
| 454 | (goto-char pos) | |
| 455 | (goto-char (line-beginning-position)) | |
| 456 | (cond | |
| 457 | ((null (get-text-property (point) 'mh-count)) | |
| 458 | (goto-char (line-end-position)) | |
| 459 | (setq face (get-text-property (1- (point)) 'face)) | |
| 460 | (insert (format " (%s/%s)" unseen total)) | |
| 461 | (mh-speed-highlight 'unknown face) | |
| 462 | (goto-char (line-beginning-position)) | |
| 463 | (add-text-properties (point) (1+ (point)) | |
| 464 | `(mh-count (,unseen . ,total)))) | |
| 465 | ((not (equal (get-text-property (point) 'mh-count) | |
| 466 | (cons unseen total))) | |
| 467 | (goto-char (line-end-position)) | |
| 468 | (setq face (get-text-property (1- (point)) 'face)) | |
| 469 | (re-search-backward " " (line-beginning-position) t) | |
| 470 | (delete-region (point) (line-end-position)) | |
| 471 | (insert (format " (%s/%s)" unseen total)) | |
| 472 | (mh-speed-highlight 'unknown face) | |
| 473 | (goto-char (line-beginning-position)) | |
| 474 | (add-text-properties | |
| 475 | (point) (1+ (point)) | |
| 476 | `(mh-count (,unseen . ,total)))))))))))) | |
| bdcfe844 BW |
477 | (setq position (1+ line-end))) |
| 478 | (set-match-data prevailing-match-data)) | |
| c3d9274a | 479 | (setq mh-speed-partial-line (substring output position)))) |
| bdcfe844 | 480 | |
| c3d9274a | 481 | ;;;###mh-autoload |
| bdcfe844 BW |
482 | (defun mh-speed-invalidate-map (folder) |
| 483 | "Remove FOLDER from various optimization caches." | |
| 484 | (interactive (list "")) | |
| 485 | (save-excursion | |
| 486 | (set-buffer speedbar-buffer) | |
| 487 | (let* ((speedbar-update-flag nil) | |
| c3d9274a | 488 | (last-slash (mh-search-from-end ?/ folder)) |
| bdcfe844 BW |
489 | (parent (if last-slash (substring folder 0 last-slash) nil)) |
| 490 | (parent-position (gethash parent mh-speed-folder-map)) | |
| 491 | (parent-change nil)) | |
| 492 | (remhash parent mh-speed-folders-cache) | |
| 493 | (remhash folder mh-speed-folders-cache) | |
| 494 | (when parent-position | |
| 495 | (let ((parent-kids (mh-speed-folders parent))) | |
| 496 | (cond ((null parent-kids) | |
| 497 | (setq parent-change ?+)) | |
| 498 | ((and (null (cdr parent-kids)) | |
| 499 | (equal (if last-slash | |
| 500 | (substring folder (1+ last-slash)) | |
| 501 | (substring folder 1)) | |
| 502 | (caar parent-kids))) | |
| 503 | (setq parent-change ? )))) | |
| 504 | (goto-char parent-position) | |
| 505 | (when (equal (get-text-property (line-beginning-position) 'mh-folder) | |
| 506 | parent) | |
| 507 | (when (get-text-property (line-beginning-position) 'mh-expanded) | |
| 508 | (mh-speed-toggle)) | |
| 509 | (when parent-change | |
| 510 | (speedbar-with-writable | |
| 511 | (mh-speedbar-change-expand-button-char parent-change) | |
| 512 | (add-text-properties | |
| 513 | (line-beginning-position) (1+ (line-beginning-position)) | |
| 514 | `(mh-children-p ,(equal parent-change ?+))))) | |
| 515 | (mh-speed-highlight mh-speed-last-selected-folder | |
| 516 | 'mh-speedbar-folder-face) | |
| 517 | (setq mh-speed-last-selected-folder nil) | |
| 518 | (setq mh-speed-refresh-flag t))) | |
| 519 | (when (equal folder "") | |
| 520 | (clrhash mh-speed-folders-cache))))) | |
| 521 | ||
| c3d9274a | 522 | ;;;###mh-autoload |
| bdcfe844 BW |
523 | (defun mh-speed-add-folder (folder) |
| 524 | "Add FOLDER since it is being created. | |
| 525 | The function invalidates the latest ancestor that is present." | |
| 526 | (save-excursion | |
| 527 | (set-buffer speedbar-buffer) | |
| 528 | (let ((speedbar-update-flag nil) | |
| c3d9274a | 529 | (last-slash (mh-search-from-end ?/ folder)) |
| bdcfe844 BW |
530 | (ancestor folder) |
| 531 | (ancestor-pos nil)) | |
| 532 | (block while-loop | |
| 533 | (while last-slash | |
| 534 | (setq ancestor (substring ancestor 0 last-slash)) | |
| 535 | (setq ancestor-pos (gethash ancestor mh-speed-folder-map)) | |
| 536 | (when ancestor-pos | |
| 537 | (return-from while-loop)) | |
| c3d9274a | 538 | (setq last-slash (mh-search-from-end ?/ ancestor)))) |
| bdcfe844 BW |
539 | (unless ancestor-pos (setq ancestor nil)) |
| 540 | (goto-char (or ancestor-pos (gethash nil mh-speed-folder-map))) | |
| 541 | (speedbar-with-writable | |
| 542 | (mh-speedbar-change-expand-button-char ?+) | |
| 543 | (add-text-properties | |
| 544 | (line-beginning-position) (1+ (line-beginning-position)) | |
| 545 | `(mh-children-p t))) | |
| 546 | (when (get-text-property (line-beginning-position) 'mh-expanded) | |
| 547 | (mh-speed-toggle)) | |
| 548 | (remhash ancestor mh-speed-folders-cache) | |
| 549 | (setq mh-speed-refresh-flag t)))) | |
| 550 | ||
| 551 | ;; Make it slightly more general to allow for [ ] buttons to be changed to | |
| 552 | ;; [+]. | |
| 553 | (defun mh-speedbar-change-expand-button-char (char) | |
| 554 | "Change the expansion button character to CHAR for the current line." | |
| 555 | (save-excursion | |
| 556 | (beginning-of-line) | |
| 557 | (if (re-search-forward "\\[.\\]" (line-end-position) t) | |
| c3d9274a | 558 | (speedbar-with-writable |
| bdcfe844 | 559 | (backward-char 2) |
| c3d9274a BW |
560 | (delete-char 1) |
| 561 | (insert-char char 1 t) | |
| 562 | (put-text-property (point) (1- (point)) 'invisible nil) | |
| 563 | ;; make sure we fix the image on the text here. | |
| 564 | (speedbar-insert-image-button-maybe (- (point) 2) 3))))) | |
| bdcfe844 BW |
565 | |
| 566 | (provide 'mh-speed) | |
| 567 | ||
| 568 | ;;; Local Variables: | |
| c3d9274a | 569 | ;;; indent-tabs-mode: nil |
| bdcfe844 BW |
570 | ;;; sentence-end-double-space: nil |
| 571 | ;;; End: | |
| 572 | ||
| 573 | ;;; mh-speed.el ends here |