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