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