Mercurial > hg > xemacs-beta
comparison lisp/vm/vm-summary.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | 859a2309aef8 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; Summary gathering and formatting routines for VM | |
| 2 ;;; Copyright (C) 1989, 1990, 1993, 1994, 1995 Kyle E. Jones | |
| 3 ;;; | |
| 4 ;;; This program is free software; you can redistribute it and/or modify | |
| 5 ;;; it under the terms of the GNU General Public License as published by | |
| 6 ;;; the Free Software Foundation; either version 1, or (at your option) | |
| 7 ;;; any later version. | |
| 8 ;;; | |
| 9 ;;; This program is distributed in the hope that it will be useful, | |
| 10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 12 ;;; GNU General Public License for more details. | |
| 13 ;;; | |
| 14 ;;; You should have received a copy of the GNU General Public License | |
| 15 ;;; along with this program; if not, write to the Free Software | |
| 16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 17 | |
| 18 (provide 'vm-summary) | |
| 19 | |
| 20 (defun vm-summary-mode-internal () | |
| 21 (setq mode-name "VM Summary" | |
| 22 major-mode 'vm-summary-mode | |
| 23 mode-line-format vm-mode-line-format | |
| 24 ;; must come after the setting of major-mode | |
| 25 mode-popup-menu (and vm-use-menus | |
| 26 (vm-menu-support-possible-p) | |
| 27 (vm-menu-mode-menu)) | |
| 28 buffer-read-only t | |
| 29 vm-summary-pointer nil | |
| 30 vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "") | |
| 31 vm-summary-no-=> (make-string (length vm-summary-=>) ? ) | |
| 32 truncate-lines t) | |
| 33 ;; horizontal scrollbar off by default | |
| 34 ;; user can turn it on in summary hook if desired. | |
| 35 (and (fboundp 'set-specifier) | |
| 36 scrollbar-height | |
| 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 (and (vm-mouse-support-possible-p) | |
| 42 (vm-mouse-xemacs-mouse-p) | |
| 43 (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) | |
| 44 (if (or vm-frame-per-folder vm-frame-per-summary) | |
| 45 (vm-set-hooks-for-frame-deletion)) | |
| 46 (run-hooks 'vm-summary-mode-hook) | |
| 47 ;; Lucid Emacs apparently used this name | |
| 48 (run-hooks 'vm-summary-mode-hooks)) | |
| 49 | |
| 50 (fset 'vm-summary-mode 'vm-mode) | |
| 51 (put 'vm-summary-mode 'mode-class 'special) | |
| 52 | |
| 53 (defun vm-summarize (&optional display) | |
| 54 "Summarize the contents of the folder in a summary buffer. | |
| 55 The format is as described by the variable vm-summary-format. Generally | |
| 56 one line per message is most pleasing to the eye but this is not | |
| 57 mandatory." | |
| 58 (interactive "p") | |
| 59 (vm-select-folder-buffer) | |
| 60 (vm-check-for-killed-summary) | |
| 61 (if (null vm-summary-buffer) | |
| 62 (let ((b (current-buffer)) | |
| 63 (read-only vm-folder-read-only)) | |
| 64 (setq vm-summary-buffer | |
| 65 (get-buffer-create (format "%s Summary" (buffer-name)))) | |
| 66 (save-excursion | |
| 67 (set-buffer vm-summary-buffer) | |
| 68 (abbrev-mode 0) | |
| 69 (auto-fill-mode 0) | |
| 70 (if (fboundp 'buffer-disable-undo) | |
| 71 (buffer-disable-undo (current-buffer)) | |
| 72 ;; obfuscation to make the v19 compiler not whine | |
| 73 ;; about obsolete functions. | |
| 74 (let ((x 'buffer-flush-undo)) | |
| 75 (funcall x (current-buffer)))) | |
| 76 (setq vm-mail-buffer b | |
| 77 vm-folder-read-only read-only) | |
| 78 (vm-summary-mode-internal)) | |
| 79 (vm-set-summary-redo-start-point t))) | |
| 80 (if display | |
| 81 (save-excursion | |
| 82 (if vm-frame-per-summary | |
| 83 (let ((w (vm-get-buffer-window vm-summary-buffer))) | |
| 84 (if (null w) | |
| 85 (progn | |
| 86 (vm-goto-new-frame 'summary) | |
| 87 (vm-set-hooks-for-frame-deletion)) | |
| 88 (save-excursion | |
| 89 (select-window w) | |
| 90 (and vm-warp-mouse-to-new-frame | |
| 91 (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))) | |
| 92 (vm-display vm-summary-buffer t | |
| 93 '(vm-summarize | |
| 94 vm-summarize-other-frame) | |
| 95 (list this-command)) | |
| 96 ;; need to do this after any frame creation because the | |
| 97 ;; toolbar sets frame-specific height and width specifiers. | |
| 98 (set-buffer vm-summary-buffer) | |
| 99 (and (vm-toolbar-support-possible-p) vm-use-toolbar | |
| 100 (vm-toolbar-install-toolbar))) | |
| 101 (vm-display nil nil '(vm-summarize vm-summarize-other-frame) | |
| 102 (list this-command))) | |
| 103 (vm-update-summary-and-mode-line)) | |
| 104 | |
| 105 (defun vm-summarize-other-frame (&optional display) | |
| 106 "Like vm-summarize, but run in a newly created frame." | |
| 107 (interactive "p") | |
| 108 (if (vm-multiple-frames-possible-p) | |
| 109 (vm-goto-new-frame 'summary)) | |
| 110 (vm-summarize display) | |
| 111 (if (vm-multiple-frames-possible-p) | |
| 112 (vm-set-hooks-for-frame-deletion))) | |
| 113 | |
| 114 (defun vm-do-summary (&optional start-point) | |
| 115 (let ((m-list (or start-point vm-message-list)) | |
| 116 mp | |
| 117 (n 0) | |
| 118 ;; Just for laughs, make the update interval vary. | |
| 119 (modulus (+ (% (vm-abs (random)) 11) 10)) | |
| 120 (mouse-track-func | |
| 121 (and (vm-mouse-support-possible-p) | |
| 122 (vm-mouse-fsfemacs-mouse-p) | |
| 123 (function vm-mouse-set-mouse-track-highlight))) | |
| 124 summary) | |
| 125 (setq mp m-list) | |
| 126 (save-excursion | |
| 127 (set-buffer vm-summary-buffer) | |
| 128 (let ((buffer-read-only nil) | |
| 129 (modified (buffer-modified-p))) | |
| 130 (unwind-protect | |
| 131 (progn | |
| 132 (if start-point | |
| 133 (if (vm-su-start-of (car mp)) | |
| 134 (progn | |
| 135 (goto-char (vm-su-start-of (car mp))) | |
| 136 (delete-region (point) (point-max))) | |
| 137 (goto-char (point-max))) | |
| 138 (erase-buffer) | |
| 139 (setq vm-summary-pointer nil)) | |
| 140 ;; avoid doing long runs down the marker chain while | |
| 141 ;; building the summary. use integers to store positions | |
| 142 ;; and then convert them to markers after all the | |
| 143 ;; insertions are done. | |
| 144 (while mp | |
| 145 (setq summary (vm-su-summary (car mp))) | |
| 146 (vm-set-su-start-of (car mp) (point)) | |
| 147 (insert vm-summary-no-=>) | |
| 148 (vm-tokenized-summary-insert (car mp) (vm-su-summary (car mp))) | |
| 149 (vm-set-su-end-of (car mp) (point)) | |
| 150 (setq mp (cdr mp) n (1+ n)) | |
| 151 (if (zerop (% n modulus)) | |
| 152 (vm-unsaved-message "Generating summary... %d" n))) | |
| 153 ;; now convert the ints to markers. | |
| 154 (if (>= n modulus) | |
| 155 (vm-unsaved-message "Generating summary markers... ")) | |
| 156 (setq mp m-list) | |
| 157 (while mp | |
| 158 (and mouse-track-func (funcall mouse-track-func | |
| 159 (vm-su-start-of (car mp)) | |
| 160 (vm-su-end-of (car mp)))) | |
| 161 (vm-set-su-start-of (car mp) (vm-marker (vm-su-start-of (car mp)))) | |
| 162 (vm-set-su-end-of (car mp) (vm-marker (vm-su-end-of (car mp)))) | |
| 163 (setq mp (cdr mp)))) | |
| 164 (set-buffer-modified-p modified)) | |
| 165 (run-hooks 'vm-summary-redo-hook))) | |
| 166 (if (>= n modulus) | |
| 167 (vm-unsaved-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 (mouse-track-func | |
| 191 (and (vm-mouse-support-possible-p) | |
| 192 (vm-mouse-fsfemacs-mouse-p) | |
| 193 (function vm-mouse-set-mouse-track-highlight))) | |
| 194 summary) | |
| 195 (save-excursion | |
| 196 (setq summary (vm-su-summary m)) | |
| 197 (set-buffer (marker-buffer (vm-su-start-of m))) | |
| 198 (let ((buffer-read-only nil) | |
| 199 (selected nil) | |
| 200 (modified (buffer-modified-p))) | |
| 201 (unwind-protect | |
| 202 (save-excursion | |
| 203 (goto-char (vm-su-start-of m)) | |
| 204 (setq selected (not (looking-at vm-summary-no-=>))) | |
| 205 ;; We do a little dance to update the text in | |
| 206 ;; order to make the markets in the text do | |
| 207 ;; what we want. | |
| 208 ;; | |
| 209 ;; 1. We need to avoid having the su-start-of | |
| 210 ;; and su-end-of market clumping together at | |
| 211 ;; the start position. | |
| 212 ;; | |
| 213 ;; 2. We want the window point market (w->pointm | |
| 214 ;; in the Emacs display code) to move to the | |
| 215 ;; start of the summary entry if it is | |
| 216 ;; anywhere within the su-start-of to | |
| 217 ;; su-end-of region. | |
| 218 ;; | |
| 219 ;; We achieve (2) by deleting before inserting. | |
| 220 ;; Reversing the order of insertion/deletion | |
| 221 ;; pushes the point marker into the next | |
| 222 ;; summary entry. We achieve (1) by inserting a | |
| 223 ;; placeholder character at the end of the | |
| 224 ;; summary entry before deleting the region. | |
| 225 (goto-char (vm-su-end-of m)) | |
| 226 (insert-before-markers "z") | |
| 227 (goto-char (vm-su-start-of m)) | |
| 228 (delete-region (point) (1- (vm-su-end-of m))) | |
| 229 (if (not selected) | |
| 230 (insert vm-summary-no-=>) | |
| 231 (insert vm-summary-=>)) | |
| 232 (vm-tokenized-summary-insert m (vm-su-summary m)) | |
| 233 (delete-char 1) | |
| 234 (run-hooks 'vm-summary-update-hook) | |
| 235 (and mouse-track-func (funcall mouse-track-func | |
| 236 (vm-su-start-of m) | |
| 237 (vm-su-end-of m))) | |
| 238 (if (and selected vm-summary-highlight-face) | |
| 239 (vm-summary-highlight-region (vm-su-start-of m) (point) | |
| 240 vm-summary-highlight-face))) | |
| 241 (set-buffer-modified-p modified))))))) | |
| 242 | |
| 243 (defun vm-set-summary-pointer (m) | |
| 244 (if vm-summary-buffer | |
| 245 (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) | |
| 246 (mouse-track-func | |
| 247 (and (vm-mouse-support-possible-p) | |
| 248 (vm-mouse-fsfemacs-mouse-p) | |
| 249 (function vm-mouse-set-mouse-track-highlight))) | |
| 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 mouse-track-func | |
| 267 (funcall mouse-track-func | |
| 268 (- (point) (length vm-summary-=>)) | |
| 269 (point))))) | |
| 270 (setq vm-summary-pointer m) | |
| 271 (goto-char (vm-su-start-of m)) | |
| 272 (let ((modified (buffer-modified-p))) | |
| 273 (unwind-protect | |
| 274 (progn | |
| 275 (insert vm-summary-=>) | |
| 276 (delete-char (length vm-summary-=>)) | |
| 277 (and mouse-track-func | |
| 278 (funcall mouse-track-func | |
| 279 (- (point) (length vm-summary-=>)) | |
| 280 (point)))) | |
| 281 (set-buffer-modified-p modified))) | |
| 282 (forward-char (- (length vm-summary-=>))) | |
| 283 (if vm-summary-highlight-face | |
| 284 (vm-summary-highlight-region | |
| 285 (vm-su-start-of m) (vm-su-end-of m) | |
| 286 vm-summary-highlight-face)) | |
| 287 (and w vm-auto-center-summary (vm-auto-center-summary)) | |
| 288 (run-hooks 'vm-summary-pointer-update-hook))) | |
| 289 (and old-window (select-window old-window))))))) | |
| 290 | |
| 291 (defun vm-summary-highlight-region (start end face) | |
| 292 (cond ((fboundp 'make-overlay) | |
| 293 (if (and vm-summary-overlay (overlay-buffer vm-summary-overlay)) | |
| 294 (move-overlay vm-summary-overlay start end) | |
| 295 (setq vm-summary-overlay (make-overlay start end)) | |
| 296 (overlay-put vm-summary-overlay 'evaporate nil) | |
| 297 (overlay-put vm-summary-overlay 'face face))) | |
| 298 ((fboundp 'make-extent) | |
| 299 (if (and vm-summary-overlay (extent-end-position vm-summary-overlay)) | |
| 300 (set-extent-endpoints vm-summary-overlay start end) | |
| 301 (setq vm-summary-overlay (make-extent start end)) | |
| 302 (set-extent-property vm-summary-overlay 'detachable nil) | |
| 303 (set-extent-property vm-summary-overlay 'face face))))) | |
| 304 | |
| 305 (defun vm-auto-center-summary () | |
| 306 (if vm-auto-center-summary | |
| 307 (if (or (eq vm-auto-center-summary t) (not (one-window-p t))) | |
| 308 (recenter '(4))))) | |
| 309 | |
| 310 (defun vm-sprintf (format-variable message &optional tokenize) | |
| 311 ;; compile the format into an eval'able s-expression | |
| 312 ;; if it hasn't been compiled already. | |
| 313 (if (not (eq (get format-variable 'vm-compiled-format) | |
| 314 (symbol-value format-variable))) | |
| 315 (vm-compile-format format-variable tokenize)) | |
| 316 ;; The local variable name `vm-su-message' is mandatory here for | |
| 317 ;; the format s-expression to work. | |
| 318 (let ((vm-su-message message)) | |
| 319 (eval (get format-variable 'vm-format-sexp)))) | |
| 320 | |
| 321 (defun vm-tokenized-summary-insert (message tokens) | |
| 322 (if (stringp tokens) | |
| 323 (insert tokens) | |
| 324 (let (token) | |
| 325 (while tokens | |
| 326 (setq token (car tokens)) | |
| 327 (cond ((stringp token) | |
| 328 (insert token)) | |
| 329 ((eq token 'number) | |
| 330 (insert (vm-padded-number-of message))) | |
| 331 ((eq token 'mark) | |
| 332 (insert (vm-su-mark message))) | |
| 333 ((eq token 'thread-indent) | |
| 334 (if (and vm-summary-show-threads | |
| 335 (natnump vm-summary-thread-indent-level)) | |
| 336 (insert-char ?\ (* vm-summary-thread-indent-level | |
| 337 (vm-th-thread-indentation message)))))) | |
| 338 (setq tokens (cdr tokens)))))) | |
| 339 | |
| 340 (defun vm-compile-format (format-variable &optional tokenize) | |
| 341 (let ((format (symbol-value format-variable)) | |
| 342 (case-fold-search nil) | |
| 343 (done nil) | |
| 344 (list nil) | |
| 345 (sexp nil) | |
| 346 (sexp-fmt nil) | |
| 347 (last-match-end 0) | |
| 348 token conv-spec) | |
| 349 (store-match-data nil) | |
| 350 (while (not done) | |
| 351 (setq token nil) | |
| 352 (while | |
| 353 (and (not token) | |
| 354 (string-match | |
| 355 "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([aAcdfFhHiIlLmMnstTwyz*%]\\|U[A-Za-z]\\)" | |
| 356 format (match-end 0))) | |
| 357 (setq conv-spec (aref format (match-beginning 5))) | |
| 358 (if (memq conv-spec '(?a ?A ?c ?d ?f ?F ?h ?H ?i ?L ?I ?l ?M | |
| 359 ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* )) | |
| 360 (progn | |
| 361 (cond ((= conv-spec ?a) | |
| 362 (setq sexp (cons (list 'vm-su-attribute-indicators | |
| 363 'vm-su-message) sexp))) | |
| 364 ((= conv-spec ?A) | |
| 365 (setq sexp (cons (list 'vm-su-attribute-indicators-long | |
| 366 'vm-su-message) sexp))) | |
| 367 ((= conv-spec ?c) | |
| 368 (setq sexp (cons (list 'vm-su-byte-count | |
| 369 'vm-su-message) sexp))) | |
| 370 ((= conv-spec ?d) | |
| 371 (setq sexp (cons (list 'vm-su-monthday | |
| 372 'vm-su-message) sexp))) | |
| 373 ((= conv-spec ?f) | |
| 374 (setq sexp (cons (list 'vm-su-interesting-from | |
| 375 'vm-su-message) sexp))) | |
| 376 ((= conv-spec ?F) | |
| 377 (setq sexp (cons (list 'vm-su-interesting-full-name | |
| 378 'vm-su-message) sexp))) | |
| 379 ((= conv-spec ?h) | |
| 380 (setq sexp (cons (list 'vm-su-hour | |
| 381 'vm-su-message) sexp))) | |
| 382 ((= conv-spec ?H) | |
| 383 (setq sexp (cons (list 'vm-su-hour-short | |
| 384 'vm-su-message) sexp))) | |
| 385 ((= conv-spec ?i) | |
| 386 (setq sexp (cons (list 'vm-su-message-id | |
| 387 'vm-su-message) sexp))) | |
| 388 ((= conv-spec ?I) | |
| 389 (if tokenize | |
| 390 (setq token ''thread-indent) | |
| 391 (setq sexp (cons (list 'vm-su-thread-indent | |
| 392 'vm-su-message) sexp)))) | |
| 393 ((= conv-spec ?l) | |
| 394 (setq sexp (cons (list 'vm-su-line-count | |
| 395 'vm-su-message) sexp))) | |
| 396 ((= conv-spec ?L) | |
| 397 (setq sexp (cons (list 'vm-su-labels | |
| 398 'vm-su-message) sexp))) | |
| 399 ((= conv-spec ?m) | |
| 400 (setq sexp (cons (list 'vm-su-month | |
| 401 'vm-su-message) sexp))) | |
| 402 ((= conv-spec ?M) | |
| 403 (setq sexp (cons (list 'vm-su-month-number | |
| 404 'vm-su-message) sexp))) | |
| 405 ((= conv-spec ?n) | |
| 406 (if tokenize | |
| 407 (setq token ''number) | |
| 408 (setq sexp (cons (list 'vm-padded-number-of | |
| 409 'vm-su-message) sexp)))) | |
| 410 ((= conv-spec ?s) | |
| 411 (setq sexp (cons (list 'vm-su-subject | |
| 412 'vm-su-message) sexp))) | |
| 413 ((= conv-spec ?T) | |
| 414 (setq sexp (cons (list 'vm-su-to-names | |
| 415 'vm-su-message) sexp))) | |
| 416 ((= conv-spec ?t) | |
| 417 (setq sexp (cons (list 'vm-su-to | |
| 418 'vm-su-message) sexp))) | |
| 419 ((= conv-spec ?U) | |
| 420 (setq sexp | |
| 421 (cons (list 'vm-run-user-summary-function | |
| 422 (list 'quote | |
| 423 (intern | |
| 424 (concat | |
| 425 "vm-summary-function-" | |
| 426 (substring | |
| 427 format | |
| 428 (1+ (match-beginning 5)) | |
| 429 (+ 2 (match-beginning 5)))))) | |
| 430 'vm-su-message) sexp))) | |
| 431 ((= conv-spec ?w) | |
| 432 (setq sexp (cons (list 'vm-su-weekday | |
| 433 'vm-su-message) sexp))) | |
| 434 ((= conv-spec ?y) | |
| 435 (setq sexp (cons (list 'vm-su-year | |
| 436 'vm-su-message) sexp))) | |
| 437 ((= conv-spec ?z) | |
| 438 (setq sexp (cons (list 'vm-su-zone | |
| 439 'vm-su-message) sexp))) | |
| 440 ((= conv-spec ?*) | |
| 441 (if tokenize | |
| 442 (setq token ''mark) | |
| 443 (setq sexp (cons (list 'vm-su-mark | |
| 444 'vm-su-message) sexp))))) | |
| 445 (cond ((and (not token) (match-beginning 1)) | |
| 446 (setcar sexp | |
| 447 (list 'vm-left-justify-string (car sexp) | |
| 448 (string-to-int | |
| 449 (substring format | |
| 450 (match-beginning 2) | |
| 451 (match-end 2)))))) | |
| 452 ((and (not token) (match-beginning 2)) | |
| 453 (setcar sexp | |
| 454 (list 'vm-right-justify-string (car sexp) | |
| 455 (string-to-int | |
| 456 (substring format | |
| 457 (match-beginning 2) | |
| 458 (match-end 2))))))) | |
| 459 (cond ((and (not token) (match-beginning 3)) | |
| 460 (setcar sexp | |
| 461 (list 'vm-truncate-string (car sexp) | |
| 462 (string-to-int | |
| 463 (substring format | |
| 464 (match-beginning 4) | |
| 465 (match-end 4))))))) | |
| 466 (setq sexp-fmt | |
| 467 (cons (if token "" "%s") | |
| 468 (cons (substring format | |
| 469 last-match-end | |
| 470 (match-beginning 0)) | |
| 471 sexp-fmt)))) | |
| 472 (setq sexp-fmt | |
| 473 (cons "%%" | |
| 474 (cons (substring format | |
| 475 (or last-match-end 0) | |
| 476 (match-beginning 0)) | |
| 477 sexp-fmt)))) | |
| 478 (setq last-match-end (match-end 0))) | |
| 479 (if (not token) | |
| 480 (setq sexp-fmt | |
| 481 (cons (substring format last-match-end (length format)) | |
| 482 sexp-fmt) | |
| 483 done t)) | |
| 484 (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) | |
| 485 (if sexp | |
| 486 (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) | |
| 487 (setq sexp sexp-fmt)) | |
| 488 (if tokenize | |
| 489 (setq list (nconc list (if (equal sexp "") nil (list sexp)) | |
| 490 (and token (list token))) | |
| 491 sexp nil | |
| 492 sexp-fmt nil))) | |
| 493 (put format-variable 'vm-compiled-format format) | |
| 494 (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp)))) | |
| 495 | |
| 496 (defun vm-get-header-contents (message header-name-regexp) | |
| 497 (let ((contents nil) | |
| 498 regexp) | |
| 499 (setq regexp (concat "^\\(" header-name-regexp "\\)") | |
| 500 message (vm-real-message-of message)) | |
| 501 (save-excursion | |
| 502 (set-buffer (vm-buffer-of (vm-real-message-of message))) | |
| 503 (save-restriction | |
| 504 (widen) | |
| 505 (goto-char (vm-headers-of message)) | |
| 506 (let ((case-fold-search t)) | |
| 507 (while (and (re-search-forward regexp (vm-text-of message) t) | |
| 508 (save-excursion (goto-char (match-beginning 0)) | |
| 509 (vm-match-header))) | |
| 510 (if contents | |
| 511 (setq contents | |
| 512 (concat contents ", " (vm-matched-header-contents))) | |
| 513 (setq contents (vm-matched-header-contents)))))) | |
| 514 contents ))) | |
| 515 | |
| 516 (defun vm-left-justify-string (string width) | |
| 517 (if (>= (length string) width) | |
| 518 string | |
| 519 (concat string (make-string (- width (length string)) ?\ )))) | |
| 520 | |
| 521 (defun vm-right-justify-string (string width) | |
| 522 (if (>= (length string) width) | |
| 523 string | |
| 524 (concat (make-string (- width (length string)) ?\ ) string))) | |
| 525 | |
| 526 (defun vm-truncate-string (string width) | |
| 527 (cond ((<= (length string) width) | |
| 528 string) | |
| 529 ((< width 0) | |
| 530 (substring string width)) | |
| 531 (t | |
| 532 (substring string 0 width)))) | |
| 533 | |
| 534 (defun vm-su-attribute-indicators (m) | |
| 535 (concat | |
| 536 (cond ((vm-deleted-flag m) "D") | |
| 537 ((vm-new-flag m) "N") | |
| 538 ((vm-unread-flag m) "U") | |
| 539 (t " ")) | |
| 540 (cond ((vm-filed-flag m) "F") | |
| 541 ((vm-written-flag m) "W") | |
| 542 (t " ")) | |
| 543 (cond ((vm-replied-flag m) "R") | |
| 544 ((vm-forwarded-flag m) "Z") | |
| 545 ((vm-redistributed-flag m) "B") | |
| 546 (t " ")) | |
| 547 (cond ((vm-edited-flag m) "E") | |
| 548 (t " ")))) | |
| 549 | |
| 550 (defun vm-su-attribute-indicators-long (m) | |
| 551 (concat | |
| 552 (cond ((vm-deleted-flag m) "D") | |
| 553 ((vm-new-flag m) "N") | |
| 554 ((vm-unread-flag m) "U") | |
| 555 (t " ")) | |
| 556 (if (vm-replied-flag m) "r" " ") | |
| 557 (if (vm-forwarded-flag m) "z" " ") | |
| 558 (if (vm-redistributed-flag m) "b" " ") | |
| 559 (if (vm-filed-flag m) "f" " ") | |
| 560 (if (vm-written-flag m) "w" " ") | |
| 561 (if (vm-edited-flag m) "e" " "))) | |
| 562 | |
| 563 (defun vm-su-byte-count (m) | |
| 564 (or (vm-byte-count-of m) | |
| 565 (vm-set-byte-count-of | |
| 566 m | |
| 567 (int-to-string | |
| 568 (- (vm-text-end-of (vm-real-message-of m)) | |
| 569 (vm-text-of (vm-real-message-of m))))))) | |
| 570 | |
| 571 (defun vm-su-weekday (m) | |
| 572 (or (vm-weekday-of m) | |
| 573 (progn (vm-su-do-date m) (vm-weekday-of m)))) | |
| 574 | |
| 575 (defun vm-su-monthday (m) | |
| 576 (or (vm-monthday-of m) | |
| 577 (progn (vm-su-do-date m) (vm-monthday-of m)))) | |
| 578 | |
| 579 (defun vm-su-month (m) | |
| 580 (or (vm-month-of m) | |
| 581 (progn (vm-su-do-date m) (vm-month-of m)))) | |
| 582 | |
| 583 (defun vm-su-month-number (m) | |
| 584 (or (vm-month-number-of m) | |
| 585 (progn (vm-su-do-date m) (vm-month-number-of m)))) | |
| 586 | |
| 587 (defun vm-su-year (m) | |
| 588 (or (vm-year-of m) | |
| 589 (progn (vm-su-do-date m) (vm-year-of m)))) | |
| 590 | |
| 591 (defun vm-su-hour-short (m) | |
| 592 (let ((string (vm-su-hour m))) | |
| 593 (if (> (length string) 5) | |
| 594 (substring string 0 5) | |
| 595 string))) | |
| 596 | |
| 597 (defun vm-su-hour (m) | |
| 598 (or (vm-hour-of m) | |
| 599 (progn (vm-su-do-date m) (vm-hour-of m)))) | |
| 600 | |
| 601 (defun vm-su-zone (m) | |
| 602 (or (vm-zone-of m) | |
| 603 (progn (vm-su-do-date m) (vm-zone-of m)))) | |
| 604 | |
| 605 (defun vm-su-mark (m) (if (vm-mark-of m) "*" " ")) | |
| 606 | |
| 607 ;; Some yogurt-headed delivery agents don't provide a Date: header. | |
| 608 (defun vm-grok-From_-date (message) | |
| 609 ;; This works only on the From_ types, obviously | |
| 610 (if (not (memq (vm-message-type-of message) | |
| 611 '(From_ From_-with-Content-Length))) | |
| 612 nil | |
| 613 (save-excursion | |
| 614 (set-buffer (vm-buffer-of (vm-real-message-of message))) | |
| 615 (save-restriction | |
| 616 (widen) | |
| 617 (goto-char (vm-start-of message)) | |
| 618 (let ((case-fold-search nil)) | |
| 619 (if (or (looking-at | |
| 620 ;; special case this so that the "remote from blah" | |
| 621 ;; isn't included. | |
| 622 "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") | |
| 623 (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) | |
| 624 (vm-buffer-substring-no-properties | |
| 625 (match-beginning 1) | |
| 626 (match-end 1)))))))) | |
| 627 | |
| 628 (defun vm-parse-date (date) | |
| 629 (let ((weekday "") | |
| 630 (monthday "") | |
| 631 (month "") | |
| 632 (year "") | |
| 633 (hour "") | |
| 634 (timezone "") | |
| 635 (start nil) | |
| 636 string | |
| 637 (case-fold-search t)) | |
| 638 (if (string-match "sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat" date) | |
| 639 (setq weekday (substring date (match-beginning 0) (match-end 0)))) | |
| 640 (if (string-match "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|jul\\|aug\\|sep\\|oct\\|nov\\|dec" date) | |
| 641 (setq month (substring date (match-beginning 0) (match-end 0)))) | |
| 642 (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(:[0-9][0-9]\\)?" date) | |
| 643 (setq hour (substring date (match-beginning 0) (match-end 0)))) | |
| 644 (if (or (string-match "[^a-z][+---][0-9][0-9][0-9][0-9]" date) | |
| 645 (string-match "e[ds]t\\|c[ds]t\\|p[ds]t\\|m[ds]t" date) | |
| 646 (string-match "ast\\|nst\\|met\\|eet\\|jst\\|bst\\|ut" date) | |
| 647 (string-match "gmt\\([+---][0-9]+\\)?" date)) | |
| 648 (setq timezone (substring date (match-beginning 0) (match-end 0)))) | |
| 649 (while (string-match "\\(\\`\\|[^:+---0-9]\\|[a-z]-\\)[0-9]+\\(\\'\\|[^:]\\)" | |
| 650 date start) | |
| 651 (setq string (substring date (match-end 1) (match-beginning 2)) | |
| 652 start (match-end 0)) | |
| 653 (cond ((string-match "\\`[4-9]." string) | |
| 654 ;; Assume that any two digits less than 40 are a date and not | |
| 655 ;; a year. The world will surely end soon. | |
| 656 (setq year (concat "19" string))) | |
| 657 ((< (length string) 3) | |
| 658 (setq monthday string)) | |
| 659 (t (setq year string)))) | |
| 660 | |
| 661 (aset vm-parse-date-workspace 0 weekday) | |
| 662 (aset vm-parse-date-workspace 1 monthday) | |
| 663 (aset vm-parse-date-workspace 2 month) | |
| 664 (aset vm-parse-date-workspace 3 year) | |
| 665 (aset vm-parse-date-workspace 4 hour) | |
| 666 (aset vm-parse-date-workspace 5 timezone) | |
| 667 vm-parse-date-workspace)) | |
| 668 | |
| 669 (defun vm-su-do-date (m) | |
| 670 (let ((case-fold-search t) | |
| 671 vector date) | |
| 672 (setq date (or (vm-get-header-contents m "Date:") (vm-grok-From_-date m))) | |
| 673 (cond | |
| 674 ((null date) | |
| 675 (vm-set-weekday-of m "") | |
| 676 (vm-set-monthday-of m "") | |
| 677 (vm-set-month-of m "") | |
| 678 (vm-set-month-number-of m "") | |
| 679 (vm-set-year-of m "") | |
| 680 (vm-set-hour-of m "") | |
| 681 (vm-set-zone-of m "")) | |
| 682 ((string-match | |
| 683 ;; The date format recognized here is the one specified in RFC 822. | |
| 684 ;; Some slop is allowed e.g. dashes between the monthday, month and year | |
| 685 ;; because such malformed headers have been observed. | |
| 686 "\\(\\([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]?\\|[---+][0-9][0-9][0-9][0-9]\\)" | |
| 687 date) | |
| 688 (if (match-beginning 2) | |
| 689 (vm-set-weekday-of m (substring date (match-beginning 2) | |
| 690 (match-end 2))) | |
| 691 (vm-set-weekday-of m "")) | |
| 692 (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3))) | |
| 693 (vm-su-do-month m (substring date (match-beginning 4) (match-end 4))) | |
| 694 (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) | |
| 695 (if (= 2 (length (vm-year-of m))) | |
| 696 (vm-set-year-of m (concat "19" (vm-year-of m)))) | |
| 697 (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6))) | |
| 698 (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7)))) | |
| 699 ((string-match | |
| 700 ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for | |
| 701 ;; the possibility of a timezone at the end. | |
| 702 "\\([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]?\\|[---+][0-9][0-9][0-9][0-9]\\)?" | |
| 703 date) | |
| 704 (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1))) | |
| 705 (vm-su-do-month m (substring date (match-beginning 2) (match-end 2))) | |
| 706 (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3))) | |
| 707 (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4))) | |
| 708 (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) | |
| 709 (if (match-beginning 6) | |
| 710 (vm-set-zone-of m (substring date (match-beginning 6) | |
| 711 (match-end 6))))) | |
| 712 (t | |
| 713 (setq vector (vm-parse-date date)) | |
| 714 (vm-set-weekday-of m (elt vector 0)) | |
| 715 (vm-set-monthday-of m (elt vector 1)) | |
| 716 (vm-su-do-month m (elt vector 2)) | |
| 717 (vm-set-year-of m (elt vector 3)) | |
| 718 (vm-set-hour-of m (elt vector 4)) | |
| 719 (vm-set-zone-of m (elt vector 5))))) | |
| 720 | |
| 721 ;; Normalize all hour and date specifications to avoid jagged margins. | |
| 722 ;; If the hour is " 3:..." or "3:...", turn it into "03:...". | |
| 723 ;; If the date is "03", turn it into " 3". | |
| 724 (cond ((null (vm-hour-of m)) nil) | |
| 725 ((string-match "\\`[0-9]:" (vm-hour-of m)) | |
| 726 (vm-set-hour-of m (concat "0" (vm-hour-of m))))) | |
| 727 (cond ((null (vm-monthday-of m)) nil) | |
| 728 ((string-match "\\`0[0-9]\\'" (vm-monthday-of m)) | |
| 729 (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2)))) | |
| 730 ) | |
| 731 | |
| 732 (defun vm-su-do-month (m month-abbrev) | |
| 733 (let ((val (assoc (downcase month-abbrev) vm-month-alist))) | |
| 734 (if val | |
| 735 (progn (vm-set-month-of m (nth 1 val)) | |
| 736 (vm-set-month-number-of m (nth 2 val))) | |
| 737 (vm-set-month-of m "") | |
| 738 (vm-set-month-number-of m "")))) | |
| 739 | |
| 740 (defun vm-run-user-summary-function (function message) | |
| 741 (let ((message (vm-real-message-of message))) | |
| 742 (save-excursion | |
| 743 (set-buffer (vm-buffer-of message)) | |
| 744 (save-restriction | |
| 745 (widen) | |
| 746 (save-excursion | |
| 747 (narrow-to-region (vm-headers-of message) (vm-text-end-of message)) | |
| 748 (funcall function message)))))) | |
| 749 | |
| 750 (defun vm-su-full-name (m) | |
| 751 (or (vm-full-name-of m) | |
| 752 (progn (vm-su-do-author m) (vm-full-name-of m)))) | |
| 753 | |
| 754 (defun vm-su-interesting-full-name (m) | |
| 755 (if vm-summary-uninteresting-senders | |
| 756 (let ((case-fold-search nil)) | |
| 757 (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) | |
| 758 (concat vm-summary-uninteresting-senders-arrow (vm-su-to-names m)) | |
| 759 (vm-su-full-name m))) | |
| 760 (vm-su-full-name m))) | |
| 761 | |
| 762 (defun vm-su-from (m) | |
| 763 (or (vm-from-of m) | |
| 764 (progn (vm-su-do-author m) (vm-from-of m)))) | |
| 765 | |
| 766 (defun vm-su-interesting-from (m) | |
| 767 (if vm-summary-uninteresting-senders | |
| 768 (let ((case-fold-search nil)) | |
| 769 (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) | |
| 770 (concat vm-summary-uninteresting-senders-arrow (vm-su-to m)) | |
| 771 (vm-su-from m))) | |
| 772 (vm-su-from m))) | |
| 773 | |
| 774 ;; Some yogurt-headed delivery agents don't even provide a From: header. | |
| 775 (defun vm-grok-From_-author (message) | |
| 776 ;; This works only on the From_ types, obviously | |
| 777 (if (not (memq (vm-message-type-of message) | |
| 778 '(From_ From_-with-Content-Length))) | |
| 779 nil | |
| 780 (save-excursion | |
| 781 (set-buffer (vm-buffer-of message)) | |
| 782 (save-restriction | |
| 783 (widen) | |
| 784 (goto-char (vm-start-of message)) | |
| 785 (let ((case-fold-search nil)) | |
| 786 (if (looking-at "From \\([^ \t\n]+\\)") | |
| 787 (vm-buffer-substring-no-properties | |
| 788 (match-beginning 1) | |
| 789 (match-end 1)))))))) | |
| 790 | |
| 791 (defun vm-su-do-author (m) | |
| 792 (let ((full-name (vm-get-header-contents m "Full-Name:")) | |
| 793 (from (or (vm-get-header-contents m "From:") | |
| 794 (vm-grok-From_-author m))) | |
| 795 pair) | |
| 796 (if (and full-name (string-match "^[ \t]*$" full-name)) | |
| 797 (setq full-name nil)) | |
| 798 (if (null from) | |
| 799 (progn | |
| 800 (setq from "???") | |
| 801 (if (null full-name) | |
| 802 (setq full-name "???"))) | |
| 803 (setq pair (funcall vm-chop-full-name-function from) | |
| 804 from (or (nth 1 pair) from) | |
| 805 full-name (or full-name (nth 0 pair) from))) | |
| 806 (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) | |
| 807 (setq full-name | |
| 808 (substring full-name (match-beginning 1) (match-end 1)))) | |
| 809 (vm-set-full-name-of m full-name) | |
| 810 (vm-set-from-of m from))) | |
| 811 | |
| 812 (defun vm-default-chop-full-name (address) | |
| 813 (let ((from address) | |
| 814 (full-name nil)) | |
| 815 (cond ((string-match | |
| 816 "\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*<\\([^>]+\\)>[ \t\n]*\\'" | |
| 817 address) | |
| 818 (if (match-beginning 1) | |
| 819 (setq full-name | |
| 820 (substring address (match-beginning 1) (match-end 1)))) | |
| 821 (setq from | |
| 822 (substring address (match-beginning 3) (match-end 3)))) | |
| 823 ((string-match | |
| 824 "\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'" | |
| 825 address) | |
| 826 (if (match-beginning 3) | |
| 827 (setq full-name | |
| 828 (substring address (match-beginning 3) (match-end 3)))) | |
| 829 (setq from | |
| 830 (substring address (match-beginning 1) (match-end 1))))) | |
| 831 (list full-name from))) | |
| 832 | |
| 833 ;; test for existence and functionality of mail-extract-address-components | |
| 834 ;; there are versions out there that don't work right, so we run | |
| 835 ;; some test data through it to see if we can trust it. | |
| 836 (defun vm-choose-chop-full-name-function (address) | |
| 837 (let ((test-data '(("kyle@uunet.uu.net" . | |
| 838 (nil "kyle@uunet.uu.net")) | |
| 839 ("c++std=lib@inet.research.att.com" . | |
| 840 (nil "c++std=lib@inet.research.att.com")) | |
| 841 ("\"Piet.Rypens\" <rypens@reks.uia.ac.be>" . | |
| 842 ("Piet Rypens" "rypens@reks.uia.ac.be")) | |
| 843 ("makke@wins.uia.ac.be (Marc.Gemis)" . | |
| 844 ("Marc Gemis" "makke@wins.uia.ac.be")) | |
| 845 ("" . (nil nil)))) | |
| 846 (failed nil) | |
| 847 result) | |
| 848 (while test-data | |
| 849 (setq result (condition-case nil | |
| 850 (mail-extract-address-components (car (car test-data))) | |
| 851 (error nil))) | |
| 852 (if (not (equal result (cdr (car test-data)))) | |
| 853 ;; failed test, use default | |
| 854 (setq failed t | |
| 855 test-data nil) | |
| 856 (setq test-data (cdr test-data)))) | |
| 857 (if failed | |
| 858 ;; it failed, use default | |
| 859 (setq vm-chop-full-name-function 'vm-default-chop-full-name) | |
| 860 ;; it passed the tests | |
| 861 (setq vm-chop-full-name-function 'mail-extract-address-components)) | |
| 862 (funcall vm-chop-full-name-function address))) | |
| 863 | |
| 864 (defun vm-su-do-recipients (m) | |
| 865 (let ((mail-use-rfc822 t) names addresses to cc all list) | |
| 866 (setq to (or (vm-get-header-contents m "To:") | |
| 867 (vm-get-header-contents m "Apparently-To:") | |
| 868 ;; desperation.... | |
| 869 (user-login-name)) | |
| 870 cc (vm-get-header-contents m "Cc:") | |
| 871 all to | |
| 872 all (if all (concat all ", " cc) cc) | |
| 873 addresses (rfc822-addresses all)) | |
| 874 (setq list (vm-parse-addresses all)) | |
| 875 (while list | |
| 876 (cond ((string= (car list) "")) | |
| 877 ((string-match "^\\(\"?\\([^<]+[^ \t\n\"]\\)\"?[ \t\n]+\\)?<\\([^>]+\\)>" | |
| 878 (car list)) | |
| 879 (if (match-beginning 2) | |
| 880 (setq names | |
| 881 (cons | |
| 882 (substring (car list) (match-beginning 2) | |
| 883 (match-end 2)) | |
| 884 names)) | |
| 885 (setq names | |
| 886 (cons | |
| 887 (substring (car list) (match-beginning 3) | |
| 888 (match-end 3)) | |
| 889 names)))) | |
| 890 ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list)) | |
| 891 (setq names | |
| 892 (cons (substring (car list) (match-beginning 1) | |
| 893 (match-end 1)) | |
| 894 names))) | |
| 895 (t (setq names (cons (car list) names)))) | |
| 896 (setq list (cdr list))) | |
| 897 (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses | |
| 898 (vm-set-to-of m (mapconcat 'identity addresses ", ")) | |
| 899 (vm-set-to-names-of m (mapconcat 'identity names ", ")))) | |
| 900 | |
| 901 (defun vm-su-to (m) | |
| 902 (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m)))) | |
| 903 | |
| 904 (defun vm-su-to-names (m) | |
| 905 (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m)))) | |
| 906 | |
| 907 (defun vm-su-message-id (m) | |
| 908 (or (vm-message-id-of m) | |
| 909 (vm-set-message-id-of | |
| 910 m | |
| 911 (or (vm-get-header-contents m "Message-Id:") | |
| 912 ;; try running md5 on the message body to produce an ID | |
| 913 ;; better than nothing. | |
| 914 (save-excursion | |
| 915 (set-buffer (vm-buffer-of (vm-real-message-of m))) | |
| 916 (save-restriction | |
| 917 (widen) | |
| 918 (condition-case nil | |
| 919 (concat "<fake-VM-id." | |
| 920 (vm-pop-md5-string | |
| 921 (buffer-substring | |
| 922 (vm-text-of (vm-real-message-of m)) | |
| 923 (vm-text-end-of (vm-real-message-of m)))) | |
| 924 "@talos.iv>") | |
| 925 (error nil)))) | |
| 926 (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>"))))) | |
| 927 | |
| 928 (defun vm-su-line-count (m) | |
| 929 (or (vm-line-count-of m) | |
| 930 (vm-set-line-count-of | |
| 931 m | |
| 932 (save-excursion | |
| 933 (set-buffer (vm-buffer-of (vm-real-message-of m))) | |
| 934 (save-restriction | |
| 935 (widen) | |
| 936 (int-to-string | |
| 937 (count-lines (vm-text-of (vm-real-message-of m)) | |
| 938 (vm-text-end-of (vm-real-message-of m))))))))) | |
| 939 | |
| 940 (defun vm-su-subject (m) | |
| 941 (or (vm-subject-of m) | |
| 942 (vm-set-subject-of | |
| 943 m | |
| 944 (let ((subject (or (vm-get-header-contents m "Subject:") "")) | |
| 945 (i nil)) | |
| 946 (if vm-summary-subject-no-newlines | |
| 947 (while (setq i (string-match "\n" subject i)) | |
| 948 (aset subject i ?\ ))) | |
| 949 subject )))) | |
| 950 | |
| 951 (defun vm-su-summary (m) | |
| 952 (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m))) | |
| 953 (or (vm-virtual-summary-of m) | |
| 954 (save-excursion | |
| 955 (vm-select-folder-buffer) | |
| 956 (vm-set-virtual-summary-of m (vm-sprintf 'vm-summary-format m t)) | |
| 957 (vm-virtual-summary-of m))) | |
| 958 (or (vm-summary-of m) | |
| 959 (save-excursion | |
| 960 (vm-select-folder-buffer) | |
| 961 (vm-set-summary-of m (vm-sprintf 'vm-summary-format m t)) | |
| 962 (vm-summary-of m))))) | |
| 963 | |
| 964 (defun vm-fix-my-summary!!! () | |
| 965 (interactive) | |
| 966 (vm-select-folder-buffer) | |
| 967 (vm-check-for-killed-summary) | |
| 968 (vm-error-if-folder-empty) | |
| 969 (vm-unsaved-message "Fixing your summary...") | |
| 970 (let ((mp vm-message-list)) | |
| 971 (while mp | |
| 972 (vm-set-summary-of (car mp) nil) | |
| 973 (vm-mark-for-summary-update (car mp)) | |
| 974 (vm-stuff-attributes (car mp)) | |
| 975 (setq mp (cdr mp))) | |
| 976 (set-buffer-modified-p t) | |
| 977 (vm-update-summary-and-mode-line)) | |
| 978 (vm-unsaved-message "Fixing your summary... done")) | |
| 979 | |
| 980 (defun vm-su-thread-indent (m) | |
| 981 (if (natnump vm-summary-thread-indent-level) | |
| 982 (make-string (* (vm-th-thread-indentation m) | |
| 983 vm-summary-thread-indent-level) | |
| 984 ?\ ) | |
| 985 "" )) | |
| 986 | |
| 987 (defun vm-su-labels (m) | |
| 988 (or (vm-label-string-of m) | |
| 989 (vm-set-label-string-of | |
| 990 m | |
| 991 (mapconcat 'identity (vm-labels-of m) ",")) | |
| 992 (vm-label-string-of m))) |