|
0
|
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)))
|
