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