cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-summary.el

   1 ;;; vm-summary.el --- Summary gathering and formatting routines for VM
   2 ;;
   3 ;; Copyright (C) 1989-1995, 2000 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (defun vm-summary-mode-internal ()
  22   (setq mode-name "VM Summary"
  23         major-mode 'vm-summary-mode
  24         mode-line-format vm-mode-line-format
  25         ;; must come after the setting of major-mode
  26         mode-popup-menu (and vm-use-menus
  27                              (vm-menu-support-possible-p)
  28                              (vm-menu-mode-menu))
  29         buffer-read-only t
  30         vm-summary-pointer nil
  31         vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "")
  32         vm-summary-no-=> (make-string (length vm-summary-=>) ? )
  33         truncate-lines t)
  34   ;; horizontal scrollbar off by default
  35   ;; user can turn it on in summary hook if desired.
  36   (and vm-xemacs-p (featurep 'scrollbar)
  37        (set-specifier scrollbar-height (cons (current-buffer) 0)))
  38   (use-local-map vm-summary-mode-map)
  39   (and (vm-menu-support-possible-p)
  40        (vm-menu-install-menus))
  41 ;; using the 'mouse-face property gives faster highlighting than this.
  42 ;;  (and vm-mouse-track-summary
  43 ;;       (vm-mouse-support-possible-p)
  44 ;;       (vm-mouse-xemacs-mouse-p)
  45 ;;       (add-hook 'mode-motion-hook 'mode-motion-highlight-line))
  46   (if (and vm-mutable-frames (or vm-frame-per-folder vm-frame-per-summary))
  47       (vm-set-hooks-for-frame-deletion))
  48   (run-hooks 'vm-summary-mode-hook)
  49   ;; Lucid Emacs apparently used this name
  50   (run-hooks 'vm-summary-mode-hooks))
  51
  52 (fset 'vm-summary-mode 'vm-mode)
  53 (put 'vm-summary-mode 'mode-class 'special)
  54
  55 ;;;###autoload
  56 (defun vm-summarize (&optional display raise)
  57   "Summarize the contents of the folder in a summary buffer.
  58 The format is as described by the variable `vm-summary-format'.  Generally
  59 one line per message is most pleasing to the eye but this is not
  60 mandatory."
  61   (interactive "p\np")
  62   (vm-select-folder-buffer)
  63   (vm-check-for-killed-summary)
  64   (if (null vm-summary-buffer)
  65       (let ((b (current-buffer))
  66             (read-only vm-folder-read-only))
  67         (setq vm-summary-buffer
  68               (let ((default-enable-multibyte-characters t))
  69                 (get-buffer-create (format "%s Summary" (buffer-name)))))
  70         (save-excursion
  71           (set-buffer vm-summary-buffer)
  72           (abbrev-mode 0)
  73           (auto-fill-mode 0)
  74           (vm-fsfemacs-nonmule-display-8bit-chars)
  75           (if (fboundp 'buffer-disable-undo)
  76               (buffer-disable-undo (current-buffer))
  77             ;; obfuscation to make the v19 compiler not whine
  78             ;; about obsolete functions.
  79             (let ((x 'buffer-flush-undo))
  80               (funcall x (current-buffer))))
  81           (setq vm-mail-buffer b
  82                 vm-folder-read-only read-only)
  83           (vm-summary-mode-internal))
  84         (vm-set-summary-redo-start-point t)))
  85   (if display
  86       (save-excursion
  87         (vm-goto-new-summary-frame-maybe)
  88         (vm-display vm-summary-buffer t
  89                     '(vm-summarize
  90                       vm-summarize-other-frame)
  91                     (list this-command) (not raise))
  92         ;; need to do this after any frame creation because the
  93         ;; toolbar sets frame-specific height and width specifiers.
  94         (set-buffer vm-summary-buffer)
  95         (vm-toolbar-install-or-uninstall-toolbar))
  96     (vm-display nil nil '(vm-summarize vm-summarize-other-frame)
  97                 (list this-command)))
  98   (vm-update-summary-and-mode-line))
  99
 100 ;;;###autoload
 101 (defun vm-summarize-other-frame (&optional display)
 102   "Like vm-summarize, but run in a newly created frame."
 103   (interactive "p")
 104   (if (vm-multiple-frames-possible-p)
 105       (vm-goto-new-frame 'summary))
 106   (vm-summarize display)
 107   (if (vm-multiple-frames-possible-p)
 108       (vm-set-hooks-for-frame-deletion)))
 109
 110 (defun vm-do-summary (&optional start-point)
 111   (let ((m-list (or start-point vm-message-list))
 112         mp m
 113         (n 0)
 114         ;; Just for laughs, make the update interval vary.
 115         (modulus (+ (% (vm-abs (random)) 11) 10))
 116         (do-mouse-track
 117             (and vm-mouse-track-summary
 118                  (vm-mouse-support-possible-p)))
 119         summary)
 120     (setq mp m-list)
 121     (save-excursion
 122       (set-buffer vm-summary-buffer)
 123       (let ((buffer-read-only nil)
 124             (modified (buffer-modified-p)))
 125         (unwind-protect
 126             (progn
 127               (if start-point
 128                   (if (vm-su-start-of (car mp))
 129                       (progn
 130                         (goto-char (vm-su-start-of (car mp)))
 131                         (delete-region (point) (point-max)))
 132                     (goto-char (point-max)))
 133                 (erase-buffer)
 134                 (setq vm-summary-pointer nil))
 135               ;; avoid doing long runs down the marker chain while
 136               ;; building the summary.  use integers to store positions
 137               ;; and then convert them to markers after all the
 138               ;; insertions are done.
 139               (while mp
 140                 (setq summary (vm-su-summary (car mp)))
 141                 (vm-set-su-start-of (car mp) (point))
 142                 (insert vm-summary-no-=>)
 143                 (vm-tokenized-summary-insert (car mp) (vm-su-summary (car mp)))
 144                 (vm-set-su-end-of (car mp) (point))
 145                 (setq mp (cdr mp) n (1+ n))
 146                 (if (zerop (% n modulus))
 147                     (message "Generating summary... %d" n)))
 148               ;; now convert the ints to markers.
 149               (if (>= n modulus)
 150                   (message "Generating summary markers... "))
 151               (setq mp m-list)
 152               (while mp
 153                 (setq m (car mp))
 154                 (and do-mouse-track
 155                      (vm-set-su-summary-mouse-track-overlay-of
 156                       m
 157                       (vm-mouse-set-mouse-track-highlight
 158                        (vm-su-start-of m)
 159                        (vm-su-end-of m)
 160                        (vm-su-summary-mouse-track-overlay-of m))))
 161                 (vm-set-su-start-of m (vm-marker (vm-su-start-of m)))
 162                 (vm-set-su-end-of m (vm-marker (vm-su-end-of m)))
 163                 (setq mp (cdr mp))))
 164           (set-buffer-modified-p modified))
 165         (run-hooks 'vm-summary-redo-hook)))
 166     (if (>= n modulus)
 167         (message "Generating summary... done"))))
 168
 169 (defun vm-do-needed-summary-rebuild ()
 170   (if (and vm-summary-redo-start-point vm-summary-buffer)
 171       (progn
 172         (vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads)
 173         (vm-do-summary (and (consp vm-summary-redo-start-point)
 174                             vm-summary-redo-start-point))
 175         (setq vm-summary-redo-start-point nil)
 176         (and vm-message-pointer
 177              (vm-set-summary-pointer (car vm-message-pointer)))
 178         (setq vm-need-summary-pointer-update nil))
 179     (and vm-need-summary-pointer-update
 180          vm-summary-buffer
 181          vm-message-pointer
 182          (progn
 183            (vm-set-summary-pointer (car vm-message-pointer))
 184            (setq vm-need-summary-pointer-update nil)))))
 185
 186 (defun vm-update-message-summary (m)
 187   (if (and (vm-su-start-of m)
 188            (marker-buffer (vm-su-start-of m)))
 189       (let ((modified (buffer-modified-p))
 190             (do-mouse-track
 191              (and vm-mouse-track-summary
 192                   (vm-mouse-support-possible-p)))
 193             summary)
 194         (save-excursion
 195           (setq summary (vm-su-summary m))
 196           (set-buffer (marker-buffer (vm-su-start-of m)))
 197           (let ((buffer-read-only nil)
 198                 (selected nil)
 199                 (modified (buffer-modified-p)))
 200             (unwind-protect
 201                 (save-excursion
 202                   (goto-char (vm-su-start-of m))
 203                   (setq selected (not (looking-at vm-summary-no-=>)))
 204                   ;; We do a little dance to update the text in
 205                   ;; order to make the markers in the text do
 206                   ;; what we want.
 207                   ;;
 208                   ;; 1. We need to avoid having the su-start-of
 209                   ;;    and su-end-of markers clumping together at
 210                   ;;    the start position.
 211                   ;;
 212                   ;; 2. We want the window point marker (w->pointm
 213                   ;;    in the Emacs display code) to move to the
 214                   ;;    start of the summary entry if it is
 215                   ;;    anywhere within the su-start-of to
 216                   ;;    su-end-of region.
 217                   ;;
 218                   ;; We achieve (2) by deleting before inserting.
 219                   ;; Reversing the order of insertion/deletion
 220                   ;; pushes the point marker into the next
 221                   ;; summary entry. We achieve (1) by inserting a
 222                   ;; placeholder character at the end of the
 223                   ;; summary entry before deleting the region.
 224                   (goto-char (vm-su-end-of m))
 225                   (insert-before-markers "z")
 226                   (goto-char (vm-su-start-of m))
 227                   (delete-region (point) (1- (vm-su-end-of m)))
 228                   (if (not selected)
 229                       (insert vm-summary-no-=>)
 230                     (insert vm-summary-=>))
 231                   (vm-tokenized-summary-insert m (vm-su-summary m))
 232                   (delete-char 1)
 233                   (run-hooks 'vm-summary-update-hook)
 234                   (and do-mouse-track
 235                        (vm-mouse-set-mouse-track-highlight
 236                         (vm-su-start-of m)
 237                         (vm-su-end-of m)
 238                         (vm-su-summary-mouse-track-overlay-of m)))
 239                   (if (and selected vm-summary-highlight-face)
 240                       (vm-summary-highlight-region (vm-su-start-of m) (point)
 241                                                    vm-summary-highlight-face)))
 242               (set-buffer-modified-p modified)))))))
 243
 244 (defun vm-set-summary-pointer (m)
 245   (if vm-summary-buffer
 246       (let ((w (vm-get-visible-buffer-window vm-summary-buffer))
 247             (do-mouse-track
 248                (and vm-mouse-track-summary
 249                     (vm-mouse-support-possible-p)))
 250             (old-window nil))
 251         (vm-save-buffer-excursion
 252           (unwind-protect
 253               (progn
 254                 (set-buffer vm-summary-buffer)
 255                 (if w
 256                     (progn
 257                       (setq old-window (selected-window))
 258                       (select-window w)))
 259                 (let ((buffer-read-only nil))
 260                   (if (and vm-summary-pointer
 261                            (vm-su-start-of vm-summary-pointer))
 262                       (progn
 263                         (goto-char (vm-su-start-of vm-summary-pointer))
 264                         (insert vm-summary-no-=>)
 265                         (delete-char (length vm-summary-=>))
 266                         (and do-mouse-track
 267                              (vm-mouse-set-mouse-track-highlight
 268                               (vm-su-start-of vm-summary-pointer)
 269                               (vm-su-end-of vm-summary-pointer)
 270                               (vm-su-summary-mouse-track-overlay-of
 271                                vm-summary-pointer)))))
 272                   (setq vm-summary-pointer m)
 273                   (goto-char (vm-su-start-of m))
 274                   (let ((modified (buffer-modified-p)))
 275                     (unwind-protect
 276                         (progn
 277                           (insert vm-summary-=>)
 278                           (delete-char (length vm-summary-=>))
 279                           (and do-mouse-track
 280                                (vm-mouse-set-mouse-track-highlight
 281                                 (vm-su-start-of m) (vm-su-end-of m)
 282                                 (vm-su-summary-mouse-track-overlay-of m))))
 283                       (set-buffer-modified-p modified)))
 284                   (forward-char (- (length vm-summary-=>)))
 285                   (if vm-summary-highlight-face
 286                       (vm-summary-highlight-region
 287                        (vm-su-start-of m) (vm-su-end-of m)
 288                        vm-summary-highlight-face))
 289                   (and w vm-auto-center-summary (vm-auto-center-summary))
 290                   (run-hooks 'vm-summary-pointer-update-hook)))
 291             (and old-window (select-window old-window)))))))
 292
 293 (defun vm-summary-highlight-region (start end face)
 294   (vm-summary-xxxx-highlight-region start end face 'vm-summary-overlay))
 295
 296 (defun vm-folders-summary-highlight-region (start end face)
 297   (vm-summary-xxxx-highlight-region start end face
 298                                     'vm-folders-summary-overlay))
 299
 300 (defun vm-summary-xxxx-highlight-region (start end face var)
 301   (let ((ooo (symbol-value var)))
 302     (cond (vm-fsfemacs-p
 303            (if (and ooo (overlay-buffer ooo))
 304                (move-overlay ooo start end)
 305              (setq ooo (make-overlay start end))
 306              (set var ooo)
 307              (overlay-put ooo 'evaporate nil)
 308              (overlay-put ooo 'face face)))
 309           (vm-xemacs-p
 310            (if (and ooo (extent-end-position ooo))
 311                (set-extent-endpoints ooo start end)
 312              (setq ooo (make-extent start end))
 313              (set var ooo)
 314              ;; the reason this isn't needed under FSF Emacs is
 315              ;; that insert-before-markers also inserts before
 316              ;; overlays!  so a summary update of an entry just
 317              ;; before this overlay in the summary buffer won't
 318              ;; leak into the overlay, but it _will_ leak into an
 319              ;; XEmacs extent.
 320              (set-extent-property ooo 'start-open t)
 321              (set-extent-property ooo 'detachable nil)
 322              (set-extent-property ooo 'face face))))))
 323
 324 (defun vm-auto-center-summary ()
 325   (if vm-auto-center-summary
 326       (if (or (eq vm-auto-center-summary t) (not (one-window-p t)))
 327           (recenter '(4)))))
 328
 329 (defun vm-summary-sprintf (format message &optional tokenize)
 330   ;; compile the format into an eval'able s-expression
 331   ;; if it hasn't been compiled already.
 332   (let* ((alist-var (if tokenize
 333                         'vm-summary-tokenized-compiled-format-alist
 334                       'vm-summary-untokenized-compiled-format-alist))
 335          (match (assoc format (symbol-value alist-var))))
 336     (if (null match)
 337         (progn
 338           (vm-summary-compile-format format tokenize)
 339           (setq match (assoc format (symbol-value alist-var)))))
 340     ;; The local variable name `vm-su-message' is mandatory here for
 341     ;; the format s-expression to work.
 342     (let ((vm-su-message message))
 343       (if (or tokenize (null vm-display-using-mime))
 344           (eval (cdr match))
 345         (vm-decode-mime-encoded-words-in-string (eval (cdr match)))))))
 346
 347 (defun vm-summary-compile-format (format tokenize)
 348   (let ((return-value (nth 1 (vm-summary-compile-format-1 format tokenize))))
 349     (if tokenize
 350         (setq vm-summary-tokenized-compiled-format-alist
 351               (cons (cons format return-value)
 352                     vm-summary-tokenized-compiled-format-alist))
 353       (setq vm-summary-untokenized-compiled-format-alist
 354             (cons (cons format return-value)
 355                   vm-summary-untokenized-compiled-format-alist)))))
 356
 357 (defun vm-tokenized-summary-insert (message tokens)
 358   (if (stringp tokens)
 359       (insert tokens)
 360     (let (token group-list)
 361       (while tokens
 362         (setq token (car tokens))
 363         (cond ((stringp token)
 364                (if vm-display-using-mime
 365                    (insert (vm-decode-mime-encoded-words-in-string token))
 366                  (insert token)))
 367               ((eq token 'group-begin)
 368                (setq group-list (cons (list (point) (nth 1 tokens)
 369                                             (nth 2 tokens))
 370                                       group-list)
 371                      tokens (cdr (cdr tokens))))
 372               ((eq token 'group-end)
 373                (let* ((space (string-to-char " "))
 374                       (blob (car group-list))
 375                       (start (car blob))
 376                       (field-width (nth 1 blob))
 377                       (precision (nth 2 blob))
 378                       (end (vm-marker (point))))
 379                  (if (integerp field-width)
 380                      (if (< (- end start) (vm-abs field-width))
 381                          (if (< field-width 0)
 382                              (insert-char space (vm-abs (+ field-width
 383                                                            (- end start))))
 384                            (save-excursion
 385                              (goto-char start)
 386                              (insert-char space (- field-width
 387                                                    (- end start)))))))
 388                  (if (integerp precision)
 389                      (if (> (- end start) (vm-abs precision))
 390                          (if (> precision 0)
 391                              (delete-char (- precision (- end start)))
 392                            (save-excursion
 393                              (goto-char start)
 394                              (delete-char (vm-abs (+ precision
 395                                                      (- end start))))))))
 396                  (setq group-list (cdr group-list))))
 397               ((eq token 'number)
 398                (insert (vm-padded-number-of message)))
 399               ((eq token 'mark)
 400                (insert (vm-su-mark message)))
 401               ((eq token 'thread-indent)
 402                (if (and vm-summary-show-threads
 403                         (natnump vm-summary-thread-indent-level))
 404                    (insert-char ?\ (* vm-summary-thread-indent-level
 405                                       (vm-th-thread-indentation message))))))
 406         (setq tokens (cdr tokens))))))
 407
 408 (defun vm-summary-compile-format-1 (format &optional tokenize start-index)
 409   (or start-index (setq start-index 0))
 410   (let ((case-fold-search nil)
 411         (finished-parsing-format nil)
 412         (list nil)
 413         (sexp nil)
 414         (sexp-fmt nil)
 415         (saw-close-group nil)
 416         (last-match-end start-index)
 417         new-match-end token conv-spec splice)
 418     (store-match-data nil)
 419     (while (and (not saw-close-group) (not finished-parsing-format))
 420       (setq token nil
 421             splice nil)
 422       (while
 423           (and (not saw-close-group) (not token)
 424                (string-match
 425                 "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()aAcdfFhHiIlLmMnstTwyz*%]\\|U[A-Za-z]\\)"
 426                 format last-match-end))
 427         (setq conv-spec (aref format (match-beginning 5)))
 428         (setq new-match-end (match-end 0))
 429         (if (and (memq conv-spec '(?\( ?\) ?a ?A ?c ?d ?f ?F ?h ?H ?i ?I
 430                                    ?l ?L ?M ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* ))
 431                  ;; for the non-tokenized path, we don't want
 432                  ;; the close group spcifier processed here, we
 433                  ;; want to just bail out and return, which is
 434                  ;; accomplished by setting a flag in the other
 435                  ;; branch of this 'if'.
 436                  (or tokenize (not (= conv-spec ?\)))))
 437             (progn
 438               (cond ((= conv-spec ?\()
 439                      (if (not tokenize)
 440                          (save-match-data
 441                            (let ((retval (vm-summary-compile-format-1
 442                                           format tokenize (match-end 5))))
 443                              (setq sexp (cons (nth 1 retval) sexp)
 444                                    new-match-end (car retval))))
 445                        (setq token `('group-begin
 446                                      ,(if (match-beginning 2)
 447                                           (string-to-number
 448                                            (concat (match-string 1 format)
 449                                                    (match-string 2 format))))
 450                                      ,(string-to-number
 451                                        (match-string 4 format)))
 452                              splice t)))
 453                     ((= conv-spec ?\))
 454                      (setq token ''group-end))
 455                     ((= conv-spec ?a)
 456                      (setq sexp (cons (list 'vm-su-attribute-indicators
 457                                             'vm-su-message) sexp)))
 458                     ((= conv-spec ?A)
 459                      (setq sexp (cons (list 'vm-su-attribute-indicators-long
 460                                             'vm-su-message) sexp)))
 461                     ((= conv-spec ?c)
 462                      (setq sexp (cons (list 'vm-su-byte-count
 463                                             'vm-su-message) sexp)))
 464                     ((= conv-spec ?d)
 465                      (setq sexp (cons (list 'vm-su-monthday
 466                                             'vm-su-message) sexp)))
 467                     ((= conv-spec ?f)
 468                      (setq sexp (cons (list 'vm-su-interesting-from
 469                                             'vm-su-message) sexp)))
 470                     ((= conv-spec ?F)
 471                      (setq sexp (cons (list 'vm-su-interesting-full-name
 472                                             'vm-su-message) sexp)))
 473                     ((= conv-spec ?h)
 474                      (setq sexp (cons (list 'vm-su-hour
 475                                             'vm-su-message) sexp)))
 476                     ((= conv-spec ?H)
 477                      (setq sexp (cons (list 'vm-su-hour-short
 478                                             'vm-su-message) sexp)))
 479                     ((= conv-spec ?i)
 480                      (setq sexp (cons (list 'vm-su-message-id
 481                                             'vm-su-message) sexp)))
 482                     ((= conv-spec ?I)
 483                      (if tokenize
 484                          (setq token ''thread-indent)
 485                        (setq sexp (cons (list 'vm-su-thread-indent
 486                                               'vm-su-message) sexp))))
 487                     ((= conv-spec ?l)
 488                      (setq sexp (cons (list 'vm-su-line-count
 489                                             'vm-su-message) sexp)))
 490                     ((= conv-spec ?L)
 491                      (setq sexp (cons (list 'vm-su-labels
 492                                             'vm-su-message) sexp)))
 493                     ((= conv-spec ?m)
 494                      (setq sexp (cons (list 'vm-su-month
 495                                             'vm-su-message) sexp)))
 496                     ((= conv-spec ?M)
 497                      (setq sexp (cons (list 'vm-su-month-number
 498                                             'vm-su-message) sexp)))
 499                     ((= conv-spec ?n)
 500                      (if tokenize
 501                          (setq token ''number)
 502                        (setq sexp (cons (list 'vm-padded-number-of
 503                                               'vm-su-message) sexp))))
 504                     ((= conv-spec ?s)
 505                      (setq sexp (cons (list 'vm-su-subject
 506                                             'vm-su-message) sexp)))
 507                     ((= conv-spec ?T)
 508                      (setq sexp (cons (list 'vm-su-to-names
 509                                             'vm-su-message) sexp)))
 510                     ((= conv-spec ?t)
 511                      (setq sexp (cons (list 'vm-su-to
 512                                             'vm-su-message) sexp)))
 513                     ((= conv-spec ?U)
 514                      (setq sexp
 515                            (cons (list 'vm-run-user-summary-function
 516                                        (list 'quote
 517                                              (intern
 518                                               (concat
 519                                                "vm-summary-function-"
 520                                                (substring
 521                                                 format
 522                                                 (1+ (match-beginning 5))
 523                                                 (+ 2 (match-beginning 5))))))
 524                                        'vm-su-message) sexp)))
 525                     ((= conv-spec ?w)
 526                      (setq sexp (cons (list 'vm-su-weekday
 527                                             'vm-su-message) sexp)))
 528                     ((= conv-spec ?y)
 529                      (setq sexp (cons (list 'vm-su-year
 530                                             'vm-su-message) sexp)))
 531                     ((= conv-spec ?z)
 532                      (setq sexp (cons (list 'vm-su-zone
 533                                             'vm-su-message) sexp)))
 534                     ((= conv-spec ?*)
 535                      (if tokenize
 536                          (setq token ''mark)
 537                        (setq sexp (cons (list 'vm-su-mark
 538                                               'vm-su-message) sexp)))))
 539               (cond ((and (not token) vm-display-using-mime)
 540                      (setcar sexp
 541                              (list 'vm-decode-mime-encoded-words-in-string
 542                                    (car sexp)))))
 543               (cond ((and (not token) (match-beginning 1) (match-beginning 2))
 544                      (setcar sexp
 545                              (list
 546                               (if (eq (aref format (match-beginning 2)) ?0)
 547                                   'vm-numeric-left-justify-string
 548                                 'vm-left-justify-string)
 549                               (car sexp)
 550                               (string-to-number
 551                                (substring format
 552                                           (match-beginning 2)
 553                                           (match-end 2))))))
 554                     ((and (not token) (match-beginning 2))
 555                      (setcar sexp
 556                              (list
 557                               (if (eq (aref format (match-beginning 2)) ?0)
 558                                   'vm-numeric-right-justify-string
 559                                 'vm-right-justify-string)
 560                               (car sexp)
 561                               (string-to-number
 562                                (substring format
 563                                           (match-beginning 2)
 564                                           (match-end 2)))))))
 565               (cond ((and (not token) (match-beginning 3))
 566                      (setcar sexp
 567                              (list 'vm-truncate-string (car sexp)
 568                                    (string-to-number
 569                                     (substring format
 570                                                (match-beginning 4)
 571                                                (match-end 4)))))))
 572               (cond ((and (not token) vm-display-using-mime)
 573                      (setcar sexp
 574                              (list 'vm-reencode-mime-encoded-words-in-string
 575                                    (car sexp)))))
 576               (setq sexp-fmt
 577                     (cons (if token "" "%s")
 578                           (cons (substring format
 579                                            last-match-end
 580                                            (match-beginning 0))
 581                                 sexp-fmt))))
 582           (setq sexp-fmt
 583                 (cons (if (eq conv-spec ?\))
 584                           (prog1 "" (setq saw-close-group t))
 585                         "%%")
 586                       (cons (substring format
 587                                        (or last-match-end 0)
 588                                        (match-beginning 0))
 589                             sexp-fmt))))
 590           (setq last-match-end new-match-end))
 591       (if (and (not saw-close-group) (not token))
 592           (setq sexp-fmt
 593                 (cons (substring format last-match-end (length format))
 594                       sexp-fmt)
 595                 finished-parsing-format t))
 596       (setq sexp-fmt (apply 'concat (nreverse sexp-fmt)))
 597       (if sexp
 598           (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
 599         (setq sexp sexp-fmt))
 600       (if tokenize
 601           (setq list (nconc list (if (equal sexp "") nil (list sexp))
 602                             (and token (if splice token (list token))))
 603                 sexp nil
 604                 sexp-fmt nil)))
 605     (list last-match-end (if list (cons 'list list) sexp))))
 606
 607 (defun vm-get-header-contents (message header-name-regexp &optional clump-sep)
 608   (let ((contents nil)
 609         regexp)
 610     (setq regexp (concat "^\\(" header-name-regexp "\\)")
 611           message (vm-real-message-of message))
 612     (save-excursion
 613       (set-buffer (vm-buffer-of (vm-real-message-of message)))
 614       (save-restriction
 615         (widen)
 616         (goto-char (vm-headers-of message))
 617         (let ((case-fold-search t))
 618           (while (and (or (null contents) clump-sep)
 619                       (re-search-forward regexp (vm-text-of message) t)
 620                       (save-excursion (goto-char (match-beginning 0))
 621                                       (vm-match-header)))
 622             (if contents
 623                 (setq contents
 624                       (concat contents clump-sep (vm-matched-header-contents)))
 625               (setq contents (vm-matched-header-contents))))))
 626       contents )))
 627
 628 ;; Do not use Emacs 20's string-width here.
 629 ;; It does not consider buffer-display-table.
 630 (defun vm-string-width (string)
 631   (if (not (fboundp 'char-width))
 632       (length string)
 633     (let ((i 0)
 634           (lim (length string))
 635           (total 0))
 636       (while (< i lim)
 637         (setq total (+ total (char-width (aref string i)))
 638               i (1+ i)))
 639       total )))
 640
 641 (defun vm-left-justify-string (string width)
 642   (let ((sw (vm-string-width string)))
 643     (if (>= sw width)
 644         string
 645       (concat string (make-string (- width sw) ?\ )))))
 646
 647 (defun vm-right-justify-string (string width)
 648   (let ((sw (vm-string-width string)))
 649     (if (>= sw width)
 650         string
 651       (concat (make-string (- width sw) ?\ ) string))))
 652
 653 ;; I don't think number glyphs ever have a width > 1
 654 (defun vm-numeric-left-justify-string (string width)
 655   (let ((sw (length string)))
 656     (if (>= sw width)
 657         string
 658       (concat string (make-string (- width sw) ?0)))))
 659
 660 ;; I don't think number glyphs ever have a width > 1
 661 (defun vm-numeric-right-justify-string (string width)
 662   (let ((sw (length string)))
 663     (if (>= sw width)
 664         string
 665       (concat (make-string (- width sw) ?0) string))))
 666
 667 (defun vm-truncate-string (string width)
 668   (cond ((fboundp 'char-width)
 669          (cond ((> width 0)
 670                 (let ((i 0)
 671                       (lim (length string))
 672                       (total 0))
 673                   (while (and (< i lim) (< total width))
 674                     (setq total (+ total (char-width (aref string i)))
 675                           i (1+ i)))
 676                   (if (< total width)
 677                       string
 678                     (substring string 0 i))))
 679                (t
 680                 (let ((i (1- (length string)))
 681                       (lim -1)
 682                       (total 0))
 683                   (setq width (- width))
 684                   (while (and (> i lim) (< total width))
 685                     (setq total (+ total (char-width (aref string i)))
 686                           i (1- i)))
 687                   (if (< total width)
 688                       string
 689                     (substring string (1+ i)))))))
 690         (t (vm-truncate-roman-string string width))))
 691
 692 (defun vm-truncate-roman-string (string width)
 693   (cond ((<= (length string) (vm-abs width))
 694          string)
 695         ((< width 0)
 696          (substring string width))
 697         (t
 698          (substring string 0 width))))
 699
 700 (defun vm-su-attribute-indicators (m)
 701   (concat
 702    (cond ((vm-deleted-flag m) "D")
 703          ((vm-new-flag m) "N")
 704          ((vm-unread-flag m) "U")
 705          (t " "))
 706    (cond ((vm-filed-flag m) "F")
 707          ((vm-written-flag m) "W")
 708          (t " "))
 709    (cond ((vm-replied-flag m) "R")
 710          ((vm-forwarded-flag m) "Z")
 711          ((vm-redistributed-flag m) "B")
 712          (t " "))
 713    (cond ((vm-edited-flag m) "E")
 714          (t " "))))
 715
 716 (defun vm-su-attribute-indicators-long (m)
 717   (concat
 718    (cond ((vm-deleted-flag m) "D")
 719          ((vm-new-flag m) "N")
 720          ((vm-unread-flag m) "U")
 721          (t " "))
 722    (if (vm-replied-flag m) "r" " ")
 723    (if (vm-forwarded-flag m) "z" " ")
 724    (if (vm-redistributed-flag m) "b" " ")
 725    (if (vm-filed-flag m) "f" " ")
 726    (if (vm-written-flag m) "w" " ")
 727    (if (vm-edited-flag m) "e" " ")))
 728
 729 (defun vm-su-byte-count (m)
 730   (or (vm-byte-count-of m)
 731       (vm-set-byte-count-of
 732        m
 733        (int-to-string
 734         (- (vm-text-end-of (vm-real-message-of m))
 735            (vm-text-of (vm-real-message-of m)))))))
 736
 737 (defun vm-su-spam-score-aux (m)
 738   "Return the numeric spam level for M."
 739   (let ((spam-status (vm-get-header-contents m "X-Spam-Status:")))
 740     (if (string-match "hits=\\([+-]?[0-9.]+\\)" spam-status)
 741         (string-to-number (match-string 1 spam-status))
 742       0)))
 743
 744 (defun vm-su-spam-score (m)
 745   "Return the numeric spam level for M (possibly using cache)."
 746   (or (vm-spam-score-of m)
 747       (vm-set-spam-score-of m (vm-su-spam-score-aux m))))
 748
 749 (defun vm-su-weekday (m)
 750   (or (vm-weekday-of m)
 751       (progn (vm-su-do-date m) (vm-weekday-of m))))
 752
 753 (defun vm-su-monthday (m)
 754   (or (vm-monthday-of m)
 755       (progn (vm-su-do-date m) (vm-monthday-of m))))
 756
 757 (defun vm-su-month (m)
 758   (or (vm-month-of m)
 759       (progn (vm-su-do-date m) (vm-month-of m))))
 760
 761 (defun vm-su-month-number (m)
 762   (or (vm-month-number-of m)
 763       (progn (vm-su-do-date m) (vm-month-number-of m))))
 764
 765 (defun vm-su-year (m)
 766   (or (vm-year-of m)
 767       (progn (vm-su-do-date m) (vm-year-of m))))
 768
 769 (defun vm-su-hour-short (m)
 770   (let ((string (vm-su-hour m)))
 771     (if (> (length string) 5)
 772         (substring string 0 5)
 773       string)))
 774
 775 (defun vm-su-hour (m)
 776   (or (vm-hour-of m)
 777       (progn (vm-su-do-date m) (vm-hour-of m))))
 778
 779 (defun vm-su-zone (m)
 780   (or (vm-zone-of m)
 781       (progn (vm-su-do-date m) (vm-zone-of m))))
 782
 783 (defun vm-su-mark (m) (if (vm-mark-of m) "*" " "))
 784
 785 ;; Some yogurt-headed delivery agents don't provide a Date: header.
 786 (defun vm-grok-From_-date (message)
 787   ;; This works only on the From_ types, obviously
 788   (if (not (memq (vm-message-type-of message)
 789                  '(BellFrom_ From_ From_-with-Content-Length)))
 790       nil
 791     (save-excursion
 792       (set-buffer (vm-buffer-of (vm-real-message-of message)))
 793       (save-excursion
 794         (save-restriction
 795           (widen)
 796           (goto-char (vm-start-of message))
 797           (let ((case-fold-search nil))
 798             (if (or (looking-at
 799                      ;; special case this so that the "remote from blah"
 800                      ;; isn't included.
 801                      "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*")
 802                     (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)"))
 803                 (vm-buffer-substring-no-properties
 804                  (match-beginning 1)
 805                  (match-end 1)))))))))
 806
 807 (defun vm-parse-date (date)
 808   (let ((weekday "")
 809         (monthday "")
 810         (month "")
 811         (year "")
 812         (hour "")
 813         (timezone "")
 814         (start nil)
 815         string
 816         (case-fold-search t))
 817     (if (string-match "sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat" date)
 818         (setq weekday (substring date (match-beginning 0) (match-end 0))))
 819     (if (string-match "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|jul\\|aug\\|sep\\|oct\\|nov\\|dec" date)
 820         (setq month (substring date (match-beginning 0) (match-end 0))))
 821     (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(:[0-9][0-9]\\)?" date)
 822         (setq hour (substring date (match-beginning 0) (match-end 0))))
 823     (cond ((string-match "[^a-z][+---][0-9][0-9][0-9][0-9]" date)
 824            (setq timezone (substring date (1+ (match-beginning 0))
 825                                      (match-end 0))))
 826           ((or (string-match "e[ds]t\\|c[ds]t\\|p[ds]t\\|m[ds]t" date)
 827                (string-match "ast\\|nst\\|met\\|eet\\|jst\\|bst\\|ut" date)
 828                (string-match "gmt\\([+---][0-9]+\\)?" date))
 829            (setq timezone (substring date (match-beginning 0) (match-end 0)))))
 830     (while (and (or (zerop (length monthday))
 831                     (zerop (length year)))
 832                 (string-match "\\(^\\| \\)\\([0-9]+\\)\\($\\| \\)" date start))
 833       (setq string (substring date (match-beginning 2) (match-end 2))
 834             start (match-end 0))
 835       (cond ((and (zerop (length monthday))
 836                   (<= (length string) 2))
 837              (setq monthday string))
 838             ((= (length string) 2)
 839              (if (< (string-to-number string) 70)
 840                  (setq year (concat "20" string))
 841                (setq year (concat "19" string))))
 842             (t (setq year string))))
 843
 844     (aset vm-parse-date-workspace 0 weekday)
 845     (aset vm-parse-date-workspace 1 monthday)
 846     (aset vm-parse-date-workspace 2 month)
 847     (aset vm-parse-date-workspace 3 year)
 848     (aset vm-parse-date-workspace 4 hour)
 849     (aset vm-parse-date-workspace 5 timezone)
 850     vm-parse-date-workspace))
 851
 852 (defun vm-su-do-date (m)
 853   (let ((case-fold-search t)
 854         vector date)
 855     (setq date (or (vm-get-header-contents m "Date:") (vm-grok-From_-date m)))
 856     (cond
 857      ((null date)
 858       (vm-set-weekday-of m "")
 859       (vm-set-monthday-of m "")
 860       (vm-set-month-of m "")
 861       (vm-set-month-number-of m "")
 862       (vm-set-year-of m "")
 863       (vm-set-hour-of m "")
 864       (vm-set-zone-of m ""))
 865      ((string-match
 866 ;; The date format recognized here is the one specified in RFC 822.
 867 ;; Some slop is allowed e.g. dashes between the monthday, month and year
 868 ;; because such malformed headers have been observed.
 869 "\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|\\(-\\|\\+\\)[01][0-9][0-9][0-9]\\)"
 870        date)
 871       (if (match-beginning 2)
 872           (vm-su-do-weekday m (substring date (match-beginning 2)
 873                                             (match-end 2)))
 874         (vm-set-weekday-of m ""))
 875       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
 876       (vm-su-do-month m (substring date (match-beginning 4) (match-end 4)))
 877       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
 878       (if (= 2 (length (vm-year-of m)))
 879           (save-match-data
 880             (cond ((string-match "^[0-6]" (vm-year-of m))
 881                    (vm-set-year-of m (concat "20" (vm-year-of m))))
 882                   (t
 883                    (vm-set-year-of m (concat "19" (vm-year-of m)))))))
 884       (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
 885       (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7))))
 886      ((string-match
 887 ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for
 888 ;; the possibility of a timezone at the end.
 889 "\\([a-z][a-z][a-z]\\)[ \t\n]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|\\(-\\|\\+\\)[01][0-9][0-9][0-9]\\)?"
 890        date)
 891       (vm-su-do-weekday m (substring date (match-beginning 1)
 892                                      (match-end 1)))
 893       (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
 894       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
 895       (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
 896       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
 897       (if (match-beginning 6)
 898           (vm-set-zone-of m (substring date (match-beginning 6)
 899                                        (match-end 6)))
 900         (vm-set-zone-of m "")))
 901      (t
 902       (setq vector (vm-parse-date date))
 903       (vm-su-do-weekday m (elt vector 0))
 904       (vm-set-monthday-of m (elt vector 1))
 905       (vm-su-do-month m (elt vector 2))
 906       (vm-set-year-of m (elt vector 3))
 907       (vm-set-hour-of m (elt vector 4))
 908       (vm-set-zone-of m (elt vector 5)))))
 909
 910   ;; Normalize all hour and date specifications to avoid jagged margins.
 911   ;; If the hour is " 3:..." or "3:...", turn it into "03:...".
 912   ;; If the date is "03", turn it into " 3".
 913   (cond ((null (vm-hour-of m)) nil)
 914         ((string-match "\\`[0-9]:" (vm-hour-of m))
 915          (vm-set-hour-of m (concat "0" (vm-hour-of m)))))
 916   (cond ((null (vm-monthday-of m)) nil)
 917         ((string-match "\\`0[0-9]\\'" (vm-monthday-of m))
 918          (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2))))
 919   )
 920
 921 (defun vm-su-do-month (m month-abbrev)
 922   (let ((val (assoc (downcase month-abbrev) vm-month-alist)))
 923     (if val
 924         (progn (vm-set-month-of m (nth 1 val))
 925                (vm-set-month-number-of m (nth 2 val)))
 926       (vm-set-month-of m "")
 927       (vm-set-month-number-of m ""))))
 928
 929 (defun vm-su-do-weekday (m weekday-abbrev)
 930   (let ((val (assoc (downcase weekday-abbrev) vm-weekday-alist)))
 931     (if val
 932         (vm-set-weekday-of m (nth 1 val))
 933       (vm-set-weekday-of m ""))))
 934
 935 (defun vm-run-user-summary-function (function message)
 936   (let ((message (vm-real-message-of message)))
 937     (save-excursion
 938       (set-buffer (vm-buffer-of message))
 939       (save-restriction
 940         (widen)
 941         (save-excursion
 942           (narrow-to-region (vm-headers-of message) (vm-text-end-of message))
 943           (funcall function message))))))
 944
 945 (defun vm-su-full-name (m)
 946   (or (vm-full-name-of m)
 947       (progn (vm-su-do-author m) (vm-full-name-of m))))
 948
 949 (defun vm-su-interesting-full-name (m)
 950   (if vm-summary-uninteresting-senders
 951       (let ((case-fold-search nil))
 952         (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
 953             (concat vm-summary-uninteresting-senders-arrow (vm-su-to-names m))
 954           (vm-su-full-name m)))
 955     (vm-su-full-name m)))
 956
 957 (defun vm-su-from (m)
 958   (or (vm-from-of m)
 959       (progn (vm-su-do-author m) (vm-from-of m))))
 960
 961 (defun vm-su-interesting-from (m)
 962   (if vm-summary-uninteresting-senders
 963       (let ((case-fold-search nil))
 964         (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
 965             (concat vm-summary-uninteresting-senders-arrow (vm-su-to m))
 966           (vm-su-from m)))
 967     (vm-su-from m)))
 968
 969 ;; Some yogurt-headed delivery agents don't even provide a From: header.
 970 (defun vm-grok-From_-author (message)
 971   ;; This works only on the From_ types, obviously
 972   (if (not (memq (vm-message-type-of message)
 973                  '(From_ BellFrom_ From_-with-Content-Length)))
 974       nil
 975     (save-excursion
 976       (set-buffer (vm-buffer-of message))
 977       (save-excursion
 978         (save-restriction
 979           (widen)
 980           (goto-char (vm-start-of message))
 981           (let ((case-fold-search nil))
 982             (if (looking-at "From \\([^ \t\n]+\\)")
 983                 (vm-buffer-substring-no-properties
 984                  (match-beginning 1)
 985                  (match-end 1)))))))))
 986
 987 (defun vm-su-do-author (m)
 988   (let ((full-name (vm-get-header-contents m "Full-Name:"))
 989         (from (or (vm-get-header-contents m "From:" ", ")
 990                   (vm-grok-From_-author m)))
 991         pair i)
 992     (if (and full-name (string-match "^[ \t]*$" full-name))
 993         (setq full-name nil))
 994     (if (null from)
 995         (progn
 996           (setq from "???")
 997           (if (null full-name)
 998               (setq full-name "???")))
 999       (setq pair (funcall vm-chop-full-name-function from)
1000             from (or (nth 1 pair) from)
1001             full-name (or full-name (nth 0 pair) from)))
1002     (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
1003         (setq full-name
1004               (substring full-name (match-beginning 1) (match-end 1))))
1005     (while (setq i (string-match "\n" full-name i))
1006       (aset full-name i ?\ ))
1007     (vm-set-full-name-of m full-name)
1008     (vm-set-from-of m from)))
1009
1010 (defun vm-default-chop-full-name (address)
1011   (let ((from address)
1012         (full-name nil))
1013     (cond ((string-match
1014 "\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*<\\([^>]+\\)>[ \t\n]*\\'"
1015                          address)
1016            (if (match-beginning 1)
1017                (setq full-name
1018                      (substring address (match-beginning 1) (match-end 1))))
1019            (setq from
1020                  (substring address (match-beginning 3) (match-end 3))))
1021           ((string-match
1022 "\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'"
1023                          address)
1024            (if (match-beginning 3)
1025                (setq full-name
1026                      (substring address (match-beginning 3) (match-end 3))))
1027            (setq from
1028                  (substring address (match-beginning 1) (match-end 1)))))
1029     (list full-name from)))
1030
1031 ;; test for existence and functionality of mail-extract-address-components
1032 ;; there are versions out there that don't work right, so we run
1033 ;; some test data through it to see if we can trust it.
1034 (defun vm-choose-chop-full-name-function (address)
1035   (let ((test-data '(("kyle@uunet.uu.net" .
1036                       (nil "kyle@uunet.uu.net"))
1037                      ("c++std=lib@inet.research.att.com" .
1038                       (nil "c++std=lib@inet.research.att.com"))
1039                      ("\"Piet.Rypens\" <rypens@reks.uia.ac.be>" .
1040                       ("Piet Rypens" "rypens@reks.uia.ac.be"))
1041                      ("makke@wins.uia.ac.be (Marc.Gemis)" .
1042                       ("Marc Gemis" "makke@wins.uia.ac.be"))
1043                      ("" . (nil nil))))
1044         (failed nil)
1045         result)
1046     (while test-data
1047       (setq result (condition-case nil
1048                        (mail-extract-address-components (car (car test-data)))
1049                      (error nil)))
1050       (if (not (equal result (cdr (car test-data))))
1051           ;; failed test, use default
1052           (setq failed t
1053                 test-data nil)
1054         (setq test-data (cdr test-data))))
1055     (if failed
1056         ;; it failed, use default
1057         (setq vm-chop-full-name-function 'vm-default-chop-full-name)
1058       ;; it passed the tests
1059       (setq vm-chop-full-name-function 'mail-extract-address-components))
1060     (funcall vm-chop-full-name-function address)))
1061
1062 (defun vm-su-do-recipients (m)
1063   (let ((mail-use-rfc822 t) i names addresses to cc all list full-name)
1064     (setq to (or (vm-get-header-contents m "To:" ", ")
1065                  (vm-get-header-contents m "Apparently-To:" ", ")
1066                  (vm-get-header-contents m "Newsgroups:" ", ")
1067                  ;; desperation....
1068                  (user-login-name))
1069           cc (or (vm-get-header-contents m "Cc:" ", ")
1070                  (vm-get-header-contents m "Bcc:" ", "))
1071           all to
1072           all (if all (concat all ", " cc) cc)
1073           addresses (rfc822-addresses all))
1074     (setq list (vm-parse-addresses all))
1075     (while list
1076       ;; Just like vm-su-do-author:
1077       (setq full-name (or (nth 0 (funcall vm-chop-full-name-function
1078                                           (car list)))
1079                           (car list)))
1080       ;; If double quotes are around the full name, fish the name out.
1081       (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
1082           (setq full-name
1083                 (substring full-name (match-beginning 1) (match-end 1))))
1084       (while (setq i (string-match "\n" full-name i))
1085         (aset full-name i ?\ ))
1086       (setq names (cons full-name names))
1087       (setq list (cdr list)))
1088     (setq names (nreverse names))
1089     ;; added by jwz for fixed vm-parse-addresses
1090     (vm-set-to-of m (mapconcat 'identity addresses ", "))
1091     (vm-set-to-names-of m (mapconcat 'identity names ", "))))
1092
1093 (defun vm-su-to (m)
1094   (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m))))
1095
1096 (defun vm-su-to-names (m)
1097   (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m))))
1098
1099 (defun vm-su-message-id (m)
1100   (or (vm-message-id-of m)
1101       (vm-set-message-id-of
1102        m
1103        (or (let ((id (vm-get-header-contents m "Message-Id:")))
1104              (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)"))))
1105            ;; try running md5 on the message body to produce an ID
1106            ;; better than nothing.
1107            (save-excursion
1108              (set-buffer (vm-buffer-of (vm-real-message-of m)))
1109              (save-restriction
1110                (widen)
1111                (condition-case nil
1112                    (concat "<fake-VM-id."
1113                            (vm-pop-md5-string
1114                             (buffer-substring
1115                              (vm-text-of (vm-real-message-of m))
1116                              (vm-text-end-of (vm-real-message-of m))))
1117                            "@talos.iv>")
1118                  (error nil))))
1119            (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>")))))
1120
1121 (defun vm-su-line-count (m)
1122   (or (vm-line-count-of m)
1123       (vm-set-line-count-of
1124        m
1125        (save-excursion
1126          (set-buffer (vm-buffer-of (vm-real-message-of m)))
1127          (save-restriction
1128            (widen)
1129            (int-to-string
1130             (count-lines (vm-text-of (vm-real-message-of m))
1131                          (vm-text-end-of (vm-real-message-of m)))))))))
1132
1133 (defun vm-su-subject (m)
1134   (or (vm-subject-of m)
1135       (vm-set-subject-of
1136        m
1137        (let ((subject (vm-decode-mime-encoded-words-in-string
1138                        (or (vm-get-header-contents m "Subject:") "")))
1139              (i nil))
1140          (while (string-match "\n[ \t]*" subject)
1141            (setq subject (replace-match " " nil t subject)))
1142          subject ))))
1143
1144 (defun vm-su-summary (m)
1145   (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m)))
1146       (or (vm-virtual-summary-of m)
1147           (save-excursion
1148             (vm-select-folder-buffer)
1149             (vm-set-virtual-summary-of m (vm-summary-sprintf
1150                                           vm-summary-format m t))
1151             (vm-virtual-summary-of m)))
1152     (or (vm-summary-of m)
1153         (save-excursion
1154           (vm-select-folder-buffer)
1155           (vm-set-summary-of m (vm-summary-sprintf vm-summary-format m t))
1156           (vm-summary-of m)))))
1157
1158 ;;;###autoload
1159 (defun vm-fix-my-summary!!! ()
1160   "Rebuilts the summary.
1161 Call this function if you made changes to `vm-summary-format'."
1162   (interactive)
1163   (vm-select-folder-buffer)
1164   (vm-check-for-killed-summary)
1165   (vm-error-if-folder-empty)
1166   (message "Fixing your summary...")
1167   (let ((mp vm-message-list))
1168     (while mp
1169       (vm-set-summary-of (car mp) nil)
1170       (vm-mark-for-summary-update (car mp))
1171       (vm-set-stuff-flag-of (car mp) t)
1172       (setq mp (cdr mp)))
1173     (message "Stuffing attributes...")
1174     (vm-stuff-folder-attributes nil)
1175     (message "Stuffing attributes... done")
1176     (set-buffer-modified-p t)
1177     (vm-update-summary-and-mode-line))
1178   (message "Fixing your summary... done"))
1179
1180 (defun vm-su-thread-indent (m)
1181   (if (and vm-summary-show-threads (natnump vm-summary-thread-indent-level))
1182       (make-string (* (vm-th-thread-indentation m)
1183                       vm-summary-thread-indent-level)
1184                    ?\ )
1185     "" ))
1186
1187 (defun vm-su-labels (m)
1188   (or (vm-label-string-of m)
1189       (vm-set-label-string-of
1190        m
1191        (mapconcat 'identity (vm-labels-of m) ","))
1192       (vm-label-string-of m)))
1193
1194 (defun vm-substring (string from &optional to)
1195   (let ((work-buffer nil))
1196     (unwind-protect
1197         (save-excursion
1198           (setq work-buffer (vm-make-work-buffer))
1199           (set-buffer work-buffer)
1200           (insert string)
1201           (if (null to)
1202               (setq to (length string))
1203             (if (< to 0)
1204                 (setq to (+ (length string) to))))
1205           ;; string indices start at 0, buffers start at 1.
1206           (setq from (1+ from)
1207                 to (1+ to))
1208           (if (> from (point-min))
1209               (delete-region (point-min) from))
1210           (if (< to (point-max))
1211               (delete-region to (point-max)))
1212           (buffer-string))
1213       (and work-buffer (kill-buffer work-buffer)))))
1214
1215 (defun vm-make-folder-summary ()
1216   (make-vector vm-folder-summary-vector-length nil))
1217
1218 (defun vm-fs-folder-of (fs) (aref fs 0))
1219 (defun vm-fs-total-count-of (fs) (aref fs 1))
1220 (defun vm-fs-new-count-of (fs) (aref fs 2))
1221 (defun vm-fs-unread-count-of (fs) (aref fs 3))
1222 (defun vm-fs-deleted-count-of (fs) (aref fs 4))
1223 (defun vm-fs-start-of (fs) (aref fs 5))
1224 (defun vm-fs-end-of (fs) (aref fs 6))
1225 (defun vm-fs-folder-key-of (fs) (aref fs 7))
1226 (defun vm-fs-mouse-track-overlay-of (fs) (aref fs 8))
1227 (defun vm-fs-short-folder-of (fs) (aref fs 9))
1228 (defun vm-fs-modflag-of (fs) (aref fs 10))
1229
1230 (defun vm-set-fs-folder-of (fs x) (aset fs 0 x))
1231 (defun vm-set-fs-total-count-of (fs x) (aset fs 1 x))
1232 (defun vm-set-fs-new-count-of (fs x) (aset fs 2 x))
1233 (defun vm-set-fs-unread-count-of (fs x) (aset fs 3 x))
1234 (defun vm-set-fs-deleted-count-of (fs x) (aset fs 4 x))
1235 (defun vm-set-fs-start-of (fs x) (aset fs 5 x))
1236 (defun vm-set-fs-end-of (fs x) (aset fs 6 x))
1237 (defun vm-set-fs-folder-key-of (fs x) (aset fs 7 x))
1238 (defun vm-set-fs-mouse-track-overlay-of (fs x) (aset fs 8 x))
1239 (defun vm-set-fs-short-folder-of (fs x) (aset fs 9 x))
1240 (defun vm-set-fs-modflag-of (fs x) (aset fs 10 x))
1241
1242 (defun vm-fs-spooled (fs)
1243   (let ((count 0)
1244         (list (symbol-value
1245                (intern-soft (vm-fs-folder-key-of fs)
1246                             vm-folders-summary-folder-hash))))
1247     (while list
1248       (setq count (+ count (car (vm-get-folder-totals (car list))))
1249             list (cdr list)))
1250     (int-to-string count)))
1251
1252 (defun vm-make-folders-summary-key (folder &optional dir)
1253   (cond ((and (stringp vm-recognize-pop-maildrops)
1254               (string-match vm-recognize-pop-maildrops folder))
1255          (vm-safe-popdrop-string folder))
1256         ((and (stringp vm-recognize-imap-maildrops)
1257               (string-match vm-recognize-imap-maildrops folder))
1258          (vm-safe-imapdrop-string folder))
1259         (t
1260          (concat "folder-summary0:"
1261                  (file-truename
1262                   (expand-file-name folder (or dir vm-folder-directory)))))))
1263
1264 (defun vm-open-folders-summary-database (mode)
1265   (condition-case data
1266       (open-database vm-folders-summary-database 'berkeley-db 'hash mode)
1267     (error (message "open-database signaled: %S" data)
1268            (sleep-for 2)
1269            nil )))
1270
1271 (defun vm-get-folder-totals (folder)
1272   (let ((default "(0 0 0 0)") fs db key data)
1273     (catch 'done
1274       (if (null vm-folders-summary-database)
1275           (throw 'done (read default)))
1276       (if (not (featurep 'berkeley-db))
1277           (throw 'done (read default)))
1278       (if (null (setq db (vm-open-folders-summary-database "rw+")))
1279           (throw 'done (read default)))
1280       (setq key (vm-make-folders-summary-key folder)
1281             data (read (get-database key db default)))
1282       (close-database db)
1283       data )))
1284
1285 (defun vm-store-folder-totals (folder totals)
1286   (let (fs db key data)
1287     (catch 'done
1288       (if (null vm-folders-summary-database)
1289           (throw 'done nil))
1290       (if (not (featurep 'berkeley-db))
1291           (throw 'done nil))
1292       (if (null (setq db (vm-open-folders-summary-database "rw+")))
1293           (throw 'done nil))
1294       (setq key (vm-make-folders-summary-key folder)
1295             data (prin1-to-string totals))
1296       (put-database key data db t)
1297       (close-database db)
1298       (if (null vm-folders-summary-hash)
1299           nil
1300         (setq fs (intern-soft key vm-folders-summary-hash)
1301               fs (symbol-value fs))
1302         (if (null fs)
1303             nil
1304           (vm-set-fs-total-count-of fs (int-to-string (car totals)))
1305           (vm-set-fs-new-count-of fs (int-to-string (nth 1 totals)))
1306           (vm-set-fs-unread-count-of fs (int-to-string (nth 2 totals)))
1307           (vm-set-fs-deleted-count-of fs (int-to-string (nth 3 totals)))))
1308       (vm-mark-for-folders-summary-update folder))))
1309
1310 (defun vm-modify-folder-totals (folder action &rest objects)
1311   (let (fs db totals key data)
1312     (catch 'done
1313       (if (null vm-folders-summary-database)
1314           (throw 'done nil))
1315       (if (not (featurep 'berkeley-db))
1316           (throw 'done nil))
1317       (if (null (setq db (vm-open-folders-summary-database "r")))
1318           (throw 'done nil))
1319       (setq key (vm-make-folders-summary-key folder))
1320       (setq totals (get-database key db))
1321       (close-database db)
1322       (if (null totals)
1323           (throw 'done nil))
1324       (setq totals (read totals))
1325       (cond ((eq action 'arrived)
1326              (let ((arrived (car objects)) c n)
1327                (setcar totals (+ (car totals) arrived))
1328                (setq c (cdr totals))
1329                (setcar c (+ (car c) arrived))))
1330             ((eq action 'saved)
1331              (let ((arrived (car objects))
1332                    (m (nth 1 objects)) c n)
1333                (setcar totals (+ (car totals) arrived))
1334                ;; increment new and unread counts if necessary.
1335                ;; messages are never saved with the deleted flag
1336                ;; set no need to check that.
1337                (setq c (cdr totals))
1338                (if (eq (car c) -1)
1339                    nil
1340                  (if (vm-new-flag m)
1341                      (setcar c (+ (car c) arrived))))
1342                (setq c (cdr c))
1343                (if (eq (car c) -1)
1344                    nil
1345                  (if (vm-unread-flag m)
1346                      (setcar c (+ (car c) arrived)))))))
1347       (setq data (prin1-to-string totals))
1348       (if (null (setq db (vm-open-folders-summary-database "rw+")))
1349           (throw 'done nil))
1350       (put-database key data db t)
1351       (close-database db)
1352       (if (null vm-folders-summary-hash)
1353           nil
1354         (setq fs (intern-soft key vm-folders-summary-hash)
1355               fs (symbol-value fs))
1356         (if (null fs)
1357             nil
1358           (vm-set-fs-total-count-of fs (int-to-string (car totals)))
1359           (vm-set-fs-new-count-of fs (int-to-string (nth 1 totals)))
1360           (vm-set-fs-unread-count-of fs (int-to-string (nth 2 totals)))
1361           (vm-set-fs-deleted-count-of fs (int-to-string (nth 3 totals)))))
1362       (vm-mark-for-folders-summary-update folder))))
1363
1364 (defun vm-folders-summary-sprintf (format layout)
1365   ;; compile the format into an eval'able s-expression
1366   ;; if it hasn't been compiled already.
1367   (let ((match (assoc format vm-folders-summary-compiled-format-alist)))
1368     (if (null match)
1369         (progn
1370           (vm-folders-summary-compile-format format)
1371           (setq match
1372                 (assoc format vm-folders-summary-compiled-format-alist))))
1373     ;; The local variable name `vm-folder-summary' is mandatory here for
1374     ;; the format s-expression to work.
1375     (let ((vm-folder-summary layout))
1376       (eval (cdr match)))))
1377
1378 (defun vm-folders-summary-compile-format (format)
1379   (let ((return-value (vm-folders-summary-compile-format-1 format 0)))
1380     (setq vm-folders-summary-compiled-format-alist
1381           (cons (cons format (nth 1 return-value))
1382                 vm-folders-summary-compiled-format-alist))))
1383
1384 (defun vm-folders-summary-compile-format-1 (format start-index)
1385   (let ((case-fold-search nil)
1386         (done nil)
1387         (sexp nil)
1388         (sexp-fmt nil)
1389         (last-match-end start-index)
1390         new-match-end conv-spec)
1391     (store-match-data nil)
1392     (while (not done)
1393       (while
1394           (and (not done)
1395                (string-match
1396                 "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()dfnstu%]\\)"
1397                 format last-match-end))
1398         (setq conv-spec (aref format (match-beginning 5)))
1399         (setq new-match-end (match-end 0))
1400         (if (memq conv-spec '(?\( ?d ?f ?n ?s ?t ?u))
1401             (progn
1402               (cond ((= conv-spec ?\()
1403                      (save-match-data
1404                        (let ((retval
1405                               (vm-folder-summary-compile-format-1
1406                                format
1407                                (match-end 5))))
1408                          (setq sexp (cons (nth 1 retval) sexp)
1409                                new-match-end (car retval)))))
1410                     ((= conv-spec ?d)
1411                      (setq sexp (cons (list 'vm-fs-deleted-count-of
1412                                             'vm-folder-summary) sexp)))
1413                     ((= conv-spec ?f)
1414                      (setq sexp (cons (list 'vm-fs-short-folder-of
1415                                             'vm-folder-summary) sexp)))
1416                     ((= conv-spec ?n)
1417                      (setq sexp (cons (list 'vm-fs-new-count-of
1418                                             'vm-folder-summary) sexp)))
1419                     ((= conv-spec ?t)
1420                      (setq sexp (cons (list 'vm-fs-total-count-of
1421                                             'vm-folder-summary) sexp)))
1422                     ((= conv-spec ?s)
1423                      (setq sexp (cons (list 'vm-fs-spooled
1424                                             'vm-folder-summary) sexp)))
1425                     ((= conv-spec ?u)
1426                      (setq sexp (cons (list 'vm-fs-unread-count-of
1427                                             'vm-folder-summary) sexp))))
1428               (cond ((and (match-beginning 1) (match-beginning 2))
1429                      (setcar sexp
1430                              (list
1431                               (if (eq (aref format (match-beginning 2)) ?0)
1432                                   'vm-numeric-left-justify-string
1433                                 'vm-left-justify-string)
1434                               (car sexp)
1435                               (string-to-number
1436                                (substring format
1437                                           (match-beginning 2)
1438                                           (match-end 2))))))
1439                     ((match-beginning 2)
1440                      (setcar sexp
1441                              (list
1442                               (if (eq (aref format (match-beginning 2)) ?0)
1443                                   'vm-numeric-right-justify-string
1444                                 'vm-right-justify-string)
1445                               (car sexp)
1446                               (string-to-number
1447                                (substring format
1448                                           (match-beginning 2)
1449                                           (match-end 2)))))))
1450               (cond ((match-beginning 3)
1451                      (setcar sexp
1452                              (list 'vm-truncate-string (car sexp)
1453                                    (string-to-number
1454                                     (substring format
1455                                                (match-beginning 4)
1456                                                (match-end 4)))))))
1457               (setq sexp-fmt
1458                     (cons "%s"
1459                           (cons (substring format
1460                                            last-match-end
1461                                            (match-beginning 0))
1462                                 sexp-fmt))))
1463           (setq sexp-fmt
1464                 (cons (if (eq conv-spec ?\))
1465                           (prog1 "" (setq done t))
1466                         "%%")
1467                       (cons (substring format
1468                                        (or last-match-end 0)
1469                                        (match-beginning 0))
1470                             sexp-fmt))))
1471         (setq last-match-end new-match-end))
1472       (if (not done)
1473           (setq sexp-fmt
1474                 (cons (substring format last-match-end (length format))
1475                       sexp-fmt)
1476                 done t))
1477       (setq sexp-fmt (apply 'concat (nreverse sexp-fmt)))
1478       (if sexp
1479           (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
1480         (setq sexp sexp-fmt)))
1481     (list last-match-end sexp)))
1482
1483 (defun vm-update-folders-summary-entry (fs)
1484   (if (and (vm-fs-start-of fs)
1485            (marker-buffer (vm-fs-start-of fs)))
1486       (let ((modified (buffer-modified-p))
1487             (do-mouse-track
1488              (and vm-mouse-track-summary
1489                   (vm-mouse-support-possible-p)))
1490             summary)
1491         (save-excursion
1492           (set-buffer (marker-buffer (vm-fs-start-of fs)))
1493           (let ((buffer-read-only nil))
1494             (unwind-protect
1495                 (save-excursion
1496                   (goto-char (vm-fs-start-of fs))
1497                   ;; We do a little dance to update the text in
1498                   ;; order to make the markers in the text do
1499                   ;; what we want.
1500                   ;;
1501                   ;; 1. We need to avoid having the start
1502                   ;;    and end markers clumping together at
1503                   ;;    the start position.
1504                   ;;
1505                   ;; 2. We want the window point marker (w->pointm
1506                   ;;    in the Emacs display code) to move to the
1507                   ;;    start of the summary entry if it is
1508                   ;;    anywhere within the su-start-of to
1509                   ;;    su-end-of region.
1510                   ;;
1511                   ;; We achieve (2) by deleting before inserting.
1512                   ;; Reversing the order of insertion/deletion
1513                   ;; pushes the point marker into the next
1514                   ;; summary entry. We achieve (1) by inserting a
1515                   ;; placeholder character at the end of the
1516                   ;; summary entry before deleting the region.
1517                   (goto-char (vm-fs-end-of fs))
1518                   (insert-before-markers "z")
1519                   (goto-char (vm-fs-start-of fs))
1520                   (delete-region (point) (1- (vm-fs-end-of fs)))
1521                   (insert
1522                    (vm-folders-summary-sprintf vm-folders-summary-format fs))
1523                   (delete-char 1)
1524                   (and do-mouse-track
1525                        (vm-mouse-set-mouse-track-highlight
1526                         (vm-fs-start-of fs)
1527                         (vm-fs-end-of fs)
1528                         (vm-fs-mouse-track-overlay-of fs))))
1529               (set-buffer-modified-p modified)))))))
1530
1531 (defun vm-folders-summary-mode-internal ()
1532   (setq mode-name "VM Folders Summary"
1533         major-mode 'vm-folders-summary-mode
1534         mode-line-format '("     %b")
1535         ;; must come after the setting of major-mode
1536         mode-popup-menu (and vm-use-menus
1537                              (vm-menu-support-possible-p)
1538                              (vm-menu-mode-menu))
1539         buffer-read-only t
1540         buffer-offer-save nil
1541         truncate-lines t)
1542   (and vm-xemacs-p (featurep 'scrollbar)
1543        (set-specifier scrollbar-height (cons (current-buffer) 0)))
1544   (use-local-map vm-folders-summary-mode-map)
1545   (and (vm-menu-support-possible-p)
1546        (vm-menu-install-menus))
1547   (if (and vm-mutable-frames vm-frame-per-folders-summary)
1548       (vm-set-hooks-for-frame-deletion))
1549   (run-hooks 'vm-folders-summary-mode-hook))
1550
1551 (defun vm-do-folders-summary ()
1552   (catch 'done
1553     (let ((fs-hash (make-vector 89 0)) db dp fp f key fs totals
1554           (format vm-folders-summary-format)
1555           (do-mouse-track (and vm-mouse-track-summary
1556                                (vm-mouse-support-possible-p))))
1557       (save-excursion
1558         (set-buffer vm-folders-summary-buffer)
1559         (erase-buffer)
1560         (let ((buffer-read-only nil))
1561           (if (null vm-folders-summary-database)
1562               (throw 'done nil))
1563           (if (not (featurep 'berkeley-db))
1564               (throw 'done nil))
1565           (if (null (setq db (vm-open-folders-summary-database "r")))
1566               (throw 'done nil))
1567           (setq dp vm-folders-summary-directories)
1568           (while dp
1569             (if (cdr vm-folders-summary-directories)
1570                 (insert (car dp) ":\n"))
1571             (let ((default-directory (car dp)))
1572               (setq fp (sort (vm-delete-backup-file-names
1573                               (vm-delete-auto-save-file-names
1574                                (vm-delete-index-file-names
1575                                 (vm-delete-directory-names
1576                                  (directory-files (car dp))))))
1577                              (function string-lessp))))
1578             (while fp
1579               (setq f (car fp)
1580                     key (vm-make-folders-summary-key f (car dp))
1581                     totals (get-database key db))
1582               (if (null totals)
1583                   (let ((ff (expand-file-name f (car dp))))
1584                     (setq totals (list (or (vm-count-messages-in-file ff) -1)
1585                                        -1 -1 -1))
1586                     (if (eq (car totals) -1)
1587                         nil
1588                       (vm-store-folder-totals ff totals)))
1589                 (setq totals (read totals)))
1590               (if (eq (car totals) -1)
1591                   nil
1592                 (setq fs (vm-make-folder-summary))
1593                 (vm-set-fs-folder-of fs (expand-file-name f (car dp)))
1594                 (vm-set-fs-short-folder-of fs f)
1595                 (vm-set-fs-total-count-of fs (vm-nonneg-string (car totals)))
1596                 (vm-set-fs-new-count-of fs (vm-nonneg-string (nth 1 totals)))
1597                 (vm-set-fs-unread-count-of fs (vm-nonneg-string
1598                                                (nth 2 totals)))
1599                 (vm-set-fs-deleted-count-of fs (vm-nonneg-string
1600                                                 (nth 3 totals)))
1601                 (vm-set-fs-folder-key-of fs key)
1602                 (vm-set-fs-start-of fs (vm-marker (point)))
1603                 (insert (vm-folders-summary-sprintf format fs))
1604                 (vm-set-fs-end-of fs (vm-marker (point)))
1605                 (and do-mouse-track
1606                      (vm-set-fs-mouse-track-overlay-of
1607                       fs
1608                       (vm-mouse-set-mouse-track-highlight
1609                        (vm-fs-start-of fs)
1610                        (vm-fs-end-of fs))))
1611                 (set (intern key fs-hash) fs))
1612               (setq fp (cdr fp)))
1613             (setq dp (cdr dp)))
1614           (close-database db)
1615           (setq vm-folders-summary-hash fs-hash))
1616         (goto-char (point-min))))))
1617
1618 (defun vm-update-folders-summary-highlight ()
1619   (if (or (null vm-mail-buffer)
1620           (null (buffer-file-name vm-mail-buffer))
1621           (null vm-folders-summary-hash))
1622       (progn
1623         (and vm-folders-summary-overlay
1624              (vm-set-extent-endpoints vm-folders-summary-overlay 1 1))
1625         (setq vm-mail-buffer nil))
1626     (let ((ooo vm-folders-summary-overlay)
1627           (fs (symbol-value (intern-soft (vm-make-folders-summary-key
1628                                           (buffer-file-name vm-mail-buffer))
1629                                          vm-folders-summary-hash))))
1630       (if (and fs
1631                (or (null ooo)
1632                    (null (vm-extent-object ooo))
1633                    (/= (vm-extent-end-position ooo)
1634                        (vm-fs-end-of fs))))
1635           (vm-folders-summary-highlight-region
1636            (vm-fs-start-of fs) (vm-fs-end-of fs)
1637            vm-summary-highlight-face)))))
1638
1639 (defun vm-do-needed-folders-summary-update ()
1640   (if (null vm-folders-summary-buffer)
1641       nil
1642     (save-excursion
1643       (set-buffer vm-folders-summary-buffer)
1644       (if (or (eq vm-modification-counter vm-flushed-modification-counter)
1645               (null vm-folders-summary-hash))
1646           nil
1647         (mapatoms
1648          (function
1649           (lambda (sym)
1650             (let ((fs (symbol-value sym)))
1651               (if (null (vm-fs-modflag-of fs))
1652                   nil
1653                 (vm-update-folders-summary-entry fs)
1654                 (vm-set-fs-modflag-of fs nil)))))
1655           vm-folders-summary-hash)
1656         (vm-update-folders-summary-highlight)
1657         (setq vm-flushed-modification-counter vm-modification-counter)))))
1658
1659 (defun vm-mark-for-folders-summary-update (folder &optional dont-descend)
1660   (let ((key (vm-make-folders-summary-key folder))
1661         (hash vm-folders-summary-hash)
1662         (spool-hash vm-folders-summary-spool-hash)
1663         list fs )
1664     (setq fs (symbol-value (intern-soft key hash)))
1665     (if (not fs)
1666         nil
1667       (vm-set-fs-modflag-of fs t)
1668       (vm-check-for-killed-summary)
1669       (if vm-folders-summary-buffer
1670           (save-excursion
1671             (set-buffer vm-folders-summary-buffer)
1672             (vm-increment vm-modification-counter))))
1673     (if dont-descend
1674         nil
1675       (setq list (symbol-value (intern-soft key spool-hash)))
1676       (while list
1677         (vm-mark-for-folders-summary-update (car list) t)
1678         (setq list (cdr list))))))
1679
1680 (defun vm-make-folders-summary-associative-hashes ()
1681   (let ((triples (vm-compute-spool-files t))
1682         (spool-hash (make-vector 61 0))
1683         (folder-hash (make-vector 61 0))
1684         s-list f-list folder-key spool-key)
1685     (while triples
1686       (setq folder-key (vm-make-folders-summary-key (car (car triples)))
1687             spool-key (vm-make-folders-summary-key (nth 1 (car triples)))
1688             s-list (symbol-value (intern-soft spool-key spool-hash))
1689             s-list (cons (car (car triples)) s-list)
1690             f-list (symbol-value (intern-soft folder-key folder-hash))
1691             f-list (cons (nth 1 (car triples)) f-list)
1692             triples (cdr triples))
1693       (set (intern spool-key spool-hash) s-list)
1694       (set (intern folder-key folder-hash) f-list))
1695     (setq vm-folders-summary-spool-hash spool-hash)
1696     (setq vm-folders-summary-folder-hash folder-hash)))
1697
1698 (defun vm-follow-folders-summary-cursor ()
1699   (if (or (not (eq major-mode 'vm-folders-summary-mode))
1700           (null vm-folders-summary-hash))
1701       nil
1702     (catch 'done
1703       (mapatoms
1704        (function
1705         (lambda (sym)
1706           (let ((fs (symbol-value sym)))
1707             (if (and (>= (point) (vm-fs-start-of fs))
1708                      (< (point) (vm-fs-end-of fs))
1709                      (or (null vm-mail-buffer)
1710                          (not (eq vm-mail-buffer
1711                                   (vm-get-file-buffer (vm-fs-folder-of fs))))))
1712                 (progn
1713                   (setq vm-mail-buffer
1714                         (save-excursion
1715                           (vm-visit-folder (vm-fs-folder-of fs))
1716                           (current-buffer)))
1717                   (vm-increment vm-modification-counter)
1718                   (vm-update-summary-and-mode-line)
1719                   (throw 'done t))))))
1720        vm-folders-summary-hash)
1721       nil )))
1722
1723 (provide 'vm-summary)
1724
1725 ;;; vm-summary.el ends here