1 |
;;; mh-seq.el --- MH-E sequences support |
;;; mh-seq.el --- MH-E sequences support |
2 |
|
|
3 |
;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc. |
;; Copyright (C) 1993, 1995, 2001, 02, 03, 2004 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Bill Wohler <wohler@newt.com> |
;; Author: Bill Wohler <wohler@newt.com> |
6 |
;; Maintainer: Bill Wohler <wohler@newt.com> |
;; Maintainer: Bill Wohler <wohler@newt.com> |
70 |
|
|
71 |
;;; Code: |
;;; Code: |
72 |
|
|
73 |
(require 'cl) |
(require 'mh-utils) |
74 |
|
(mh-require-cl) |
75 |
(require 'mh-e) |
(require 'mh-e) |
76 |
|
|
77 |
;; Shush the byte-compiler |
;; Shush the byte-compiler |
111 |
"Table to look up message identifier from message index.") |
"Table to look up message identifier from message index.") |
112 |
(defvar mh-thread-scan-line-map nil |
(defvar mh-thread-scan-line-map nil |
113 |
"Map of message index to various parts of the scan line.") |
"Map of message index to various parts of the scan line.") |
114 |
(defvar mh-thread-old-scan-line-map nil |
(defvar mh-thread-scan-line-map-stack nil |
115 |
"Old map of message index to various parts of the scan line. |
"Old map of message index to various parts of the scan line. |
116 |
This is the original map that is stored when the folder is narrowed.") |
This is the original map that is stored when the folder is narrowed.") |
117 |
(defvar mh-thread-subject-container-hash nil |
(defvar mh-thread-subject-container-hash nil |
132 |
(make-variable-buffer-local 'mh-thread-id-index-map) |
(make-variable-buffer-local 'mh-thread-id-index-map) |
133 |
(make-variable-buffer-local 'mh-thread-index-id-map) |
(make-variable-buffer-local 'mh-thread-index-id-map) |
134 |
(make-variable-buffer-local 'mh-thread-scan-line-map) |
(make-variable-buffer-local 'mh-thread-scan-line-map) |
135 |
(make-variable-buffer-local 'mh-thread-old-scan-line-map) |
(make-variable-buffer-local 'mh-thread-scan-line-map-stack) |
136 |
(make-variable-buffer-local 'mh-thread-subject-container-hash) |
(make-variable-buffer-local 'mh-thread-subject-container-hash) |
137 |
(make-variable-buffer-local 'mh-thread-duplicates) |
(make-variable-buffer-local 'mh-thread-duplicates) |
138 |
(make-variable-buffer-local 'mh-thread-history) |
(make-variable-buffer-local 'mh-thread-history) |
141 |
(defun mh-delete-seq (sequence) |
(defun mh-delete-seq (sequence) |
142 |
"Delete the SEQUENCE." |
"Delete the SEQUENCE." |
143 |
(interactive (list (mh-read-seq-default "Delete" t))) |
(interactive (list (mh-read-seq-default "Delete" t))) |
144 |
(let ((msg-list (mh-seq-to-msgs sequence))) |
(let ((msg-list (mh-seq-to-msgs sequence)) |
145 |
|
(internal-flag (mh-internal-seq sequence)) |
146 |
|
(folders-changed (list mh-current-folder))) |
147 |
|
(mh-iterate-on-range msg sequence |
148 |
|
(mh-remove-sequence-notation msg internal-flag)) |
149 |
(mh-undefine-sequence sequence '("all")) |
(mh-undefine-sequence sequence '("all")) |
150 |
(mh-delete-seq-locally sequence) |
(mh-delete-seq-locally sequence) |
151 |
(mh-iterate-on-messages-in-region msg (point-min) (point-max) |
(when mh-index-data |
152 |
(cond ((and mh-tick-seq (eq sequence mh-tick-seq)) |
(setq folders-changed |
153 |
(mh-notate-tick msg ())) |
(append folders-changed |
154 |
((and (member msg msg-list) (not (mh-seq-containing-msg msg nil))) |
(mh-index-delete-from-sequence sequence msg-list)))) |
155 |
(mh-notate nil ? (1+ mh-cmd-note))))))) |
(when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) |
156 |
|
(apply #'mh-speed-flists t folders-changed)))) |
157 |
|
|
158 |
;; Avoid compiler warnings |
;; Avoid compiler warnings |
159 |
(defvar view-exit-action) |
(defvar view-exit-action) |
227 |
(interactive (list (mh-read-seq "Narrow to" t))) |
(interactive (list (mh-read-seq "Narrow to" t))) |
228 |
(with-mh-folder-updating (t) |
(with-mh-folder-updating (t) |
229 |
(cond ((mh-seq-to-msgs sequence) |
(cond ((mh-seq-to-msgs sequence) |
|
(mh-widen) |
|
230 |
(mh-remove-all-notation) |
(mh-remove-all-notation) |
231 |
(let ((eob (point-max)) |
(let ((eob (point-max)) |
232 |
(msg-at-cursor (mh-get-msg-num nil))) |
(msg-at-cursor (mh-get-msg-num nil))) |
233 |
(setq mh-thread-old-scan-line-map mh-thread-scan-line-map) |
(push mh-thread-scan-line-map mh-thread-scan-line-map-stack) |
234 |
(setq mh-thread-scan-line-map (make-hash-table :test #'eql)) |
(setq mh-thread-scan-line-map (make-hash-table :test #'eql)) |
235 |
(mh-copy-seq-to-eob sequence) |
(mh-copy-seq-to-eob sequence) |
236 |
(narrow-to-region eob (point-max)) |
(push (buffer-substring-no-properties (point-min) eob) |
237 |
(setq mh-narrowed-to-seq sequence) |
mh-folder-view-stack) |
238 |
(mh-notate-user-sequences) |
(delete-region (point-min) eob) |
239 |
(mh-notate-deleted-and-refiled) |
(mh-notate-deleted-and-refiled) |
240 |
(mh-notate-cur) |
(mh-notate-cur) |
241 |
(when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) |
(when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) |
257 |
(error "No messages in sequence `%s'" (symbol-name sequence)))))) |
(error "No messages in sequence `%s'" (symbol-name sequence)))))) |
258 |
|
|
259 |
;;;###mh-autoload |
;;;###mh-autoload |
260 |
(defun mh-put-msg-in-seq (msg-or-seq sequence) |
(defun mh-put-msg-in-seq (range sequence) |
261 |
"Add MSG-OR-SEQ to SEQUENCE. |
"Add RANGE to SEQUENCE. |
262 |
Default is the displayed message. |
|
263 |
If optional prefix argument is provided, then prompt for the message sequence. |
Check the documentation of `mh-interactive-range' to see how RANGE is read in |
264 |
If variable `transient-mark-mode' is non-nil and the mark is active, then the |
interactive use." |
265 |
selected region is added to the sequence. |
(interactive (list (mh-interactive-range "Add messages from") |
|
In a program, MSG-OR-SEQ can be a message number, a list of message numbers, a |
|
|
region in a cons cell, or a sequence." |
|
|
(interactive (list (mh-interactive-msg-or-seq "Add messages from") |
|
266 |
(mh-read-seq-default "Add to" nil))) |
(mh-read-seq-default "Add to" nil))) |
267 |
(when (and (interactive-p) mh-tick-seq (eq sequence mh-tick-seq)) |
(unless (mh-valid-seq-p sequence) |
268 |
(error "Use `mh-toggle-tick' to add messages to %s" mh-tick-seq)) |
(error "Can't put message in invalid sequence `%s'" sequence)) |
269 |
(let* ((internal-seq-flag (mh-internal-seq sequence)) |
(let* ((internal-seq-flag (mh-internal-seq sequence)) |
270 |
(note-seq (if internal-seq-flag nil mh-note-seq)) |
(original-msgs (mh-seq-msgs (mh-find-seq sequence))) |
271 |
|
(folders (list mh-current-folder)) |
272 |
(msg-list ())) |
(msg-list ())) |
273 |
(mh-iterate-on-msg-or-seq m msg-or-seq |
(mh-iterate-on-range m range |
274 |
(push m msg-list) |
(push m msg-list) |
275 |
(mh-notate nil note-seq (1+ mh-cmd-note))) |
(unless (memq m original-msgs) |
276 |
|
(mh-add-sequence-notation m internal-seq-flag))) |
277 |
(mh-add-msgs-to-seq msg-list sequence nil t) |
(mh-add-msgs-to-seq msg-list sequence nil t) |
278 |
(if (not internal-seq-flag) |
(if (not internal-seq-flag) |
279 |
(setq mh-last-seq-used sequence)) |
(setq mh-last-seq-used sequence)) |
280 |
|
(when mh-index-data |
281 |
|
(setq folders |
282 |
|
(append folders (mh-index-add-to-sequence sequence msg-list)))) |
283 |
(when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) |
(when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) |
284 |
(mh-speed-flists t mh-current-folder)))) |
(apply #'mh-speed-flists t folders)))) |
285 |
|
|
286 |
(defun mh-valid-view-change-operation-p (op) |
(defun mh-valid-view-change-operation-p (op) |
287 |
"Check if the view change operation can be performed. |
"Check if the view change operation can be performed. |
291 |
(t nil))) |
(t nil))) |
292 |
|
|
293 |
;;;###mh-autoload |
;;;###mh-autoload |
294 |
(defun mh-widen () |
(defun mh-widen (&optional all-flag) |
295 |
"Remove restrictions from current folder, thereby showing all messages." |
"Remove last restriction from current folder. |
296 |
(interactive) |
If optional prefix argument ALL-FLAG is non-nil, then unwind to the beginning |
297 |
|
of the view stack thereby showing all messages that the buffer originally |
298 |
|
contained." |
299 |
|
(interactive "P") |
300 |
(let ((msg (mh-get-msg-num nil))) |
(let ((msg (mh-get-msg-num nil))) |
301 |
(when mh-narrowed-to-seq |
(when mh-folder-view-stack |
302 |
(cond ((mh-valid-view-change-operation-p 'widen) nil) |
(cond (all-flag |
303 |
|
(while (cdr mh-view-ops) |
304 |
|
(setq mh-view-ops (cdr mh-view-ops))) |
305 |
|
(when (eq (car mh-view-ops) 'widen) |
306 |
|
(setq mh-view-ops (cdr mh-view-ops)))) |
307 |
|
((mh-valid-view-change-operation-p 'widen) nil) |
308 |
((memq 'widen mh-view-ops) |
((memq 'widen mh-view-ops) |
309 |
(while (not (eq (car mh-view-ops) 'widen)) |
(while (not (eq (car mh-view-ops) 'widen)) |
310 |
(setq mh-view-ops (cdr mh-view-ops))) |
(setq mh-view-ops (cdr mh-view-ops))) |
311 |
(pop mh-view-ops)) |
(setq mh-view-ops (cdr mh-view-ops))) |
312 |
(t (error "Widening is not applicable"))) |
(t (error "Widening is not applicable"))) |
313 |
(when (memq 'unthread mh-view-ops) |
;; If ALL-FLAG is non-nil then rewind stacks |
314 |
(setq mh-thread-scan-line-map mh-thread-old-scan-line-map)) |
(when all-flag |
315 |
|
(while (cdr mh-thread-scan-line-map-stack) |
316 |
|
(setq mh-thread-scan-line-map-stack |
317 |
|
(cdr mh-thread-scan-line-map-stack))) |
318 |
|
(while (cdr mh-folder-view-stack) |
319 |
|
(setq mh-folder-view-stack (cdr mh-folder-view-stack)))) |
320 |
|
(setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack)) |
321 |
(with-mh-folder-updating (t) |
(with-mh-folder-updating (t) |
322 |
(delete-region (point-min) (point-max)) |
(delete-region (point-min) (point-max)) |
323 |
(widen) |
(insert (pop mh-folder-view-stack)) |
324 |
|
(mh-remove-all-notation) |
325 |
(setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) |
(setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) |
326 |
(mh-make-folder-mode-line)) |
(mh-make-folder-mode-line)) |
327 |
(if msg |
(if msg |
328 |
(mh-goto-msg msg t t)) |
(mh-goto-msg msg t t)) |
|
(setq mh-narrowed-to-seq nil) |
|
|
(setq mh-tick-seq-changed-when-narrowed-flag nil) |
|
329 |
(mh-notate-deleted-and-refiled) |
(mh-notate-deleted-and-refiled) |
330 |
(mh-notate-user-sequences) |
(mh-notate-user-sequences) |
331 |
(mh-notate-cur) |
(mh-notate-cur) |
332 |
(mh-recenter nil))) |
(mh-recenter nil))) |
333 |
(when (and (boundp 'tool-bar-mode) tool-bar-mode) |
(when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode) |
334 |
(set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) |
(set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) |
335 |
(when (buffer-live-p (get-buffer mh-show-buffer)) |
(when (buffer-live-p (get-buffer mh-show-buffer)) |
336 |
(save-excursion |
(save-excursion |
339 |
|
|
340 |
;; FIXME? We may want to clear all notations and add one for current-message |
;; FIXME? We may want to clear all notations and add one for current-message |
341 |
;; and process user sequences. |
;; and process user sequences. |
342 |
|
;;;###mh-autoload |
343 |
(defun mh-notate-deleted-and-refiled () |
(defun mh-notate-deleted-and-refiled () |
344 |
"Notate messages marked for deletion or refiling. |
"Notate messages marked for deletion or refiling. |
345 |
Messages to be deleted are given by `mh-delete-list' while messages to be |
Messages to be deleted are given by `mh-delete-list' while messages to be |
363 |
;;; of the form: |
;;; of the form: |
364 |
;;; ((seq-name msgs ...) (seq-name msgs ...) ...) |
;;; ((seq-name msgs ...) (seq-name msgs ...) ...) |
365 |
|
|
366 |
|
(defvar mh-sequence-history ()) |
367 |
|
|
368 |
|
;;;###mh-autoload |
369 |
(defun mh-read-seq-default (prompt not-empty) |
(defun mh-read-seq-default (prompt not-empty) |
370 |
"Read and return sequence name with default narrowed or previous sequence. |
"Read and return sequence name with default narrowed or previous sequence. |
371 |
PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a |
PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a |
372 |
non-empty sequence is read." |
non-empty sequence is read." |
373 |
(mh-read-seq prompt not-empty |
(mh-read-seq prompt not-empty |
374 |
(or mh-narrowed-to-seq |
(or mh-last-seq-used |
|
mh-last-seq-used |
|
375 |
(car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) |
(car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) |
376 |
|
|
377 |
(defun mh-read-seq (prompt not-empty &optional default) |
(defun mh-read-seq (prompt not-empty &optional default) |
383 |
(if default |
(if default |
384 |
(format "[%s] " default) |
(format "[%s] " default) |
385 |
"")) |
"")) |
386 |
(mh-seq-names mh-seq-list))) |
(mh-seq-names mh-seq-list) |
387 |
|
nil nil nil 'mh-sequence-history)) |
388 |
(seq (cond ((equal input "%") |
(seq (cond ((equal input "%") |
389 |
(car (mh-seq-containing-msg (mh-get-msg-num t) nil))) |
(car (mh-seq-containing-msg (mh-get-msg-num t) nil))) |
390 |
((equal input "") default) |
((equal input "") default) |
394 |
(error "No messages in sequence `%s'" seq)) |
(error "No messages in sequence `%s'" seq)) |
395 |
seq)) |
seq)) |
396 |
|
|
397 |
|
;;; Functions to read ranges with completion... |
398 |
|
(defvar mh-range-seq-names) |
399 |
|
(defvar mh-range-history ()) |
400 |
|
(defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map)) |
401 |
|
(define-key mh-range-completion-map " " 'self-insert-command) |
402 |
|
|
403 |
|
(defun mh-range-completion-function (string predicate flag) |
404 |
|
"Programmable completion of message ranges. |
405 |
|
STRING is the user input that is to be completed. PREDICATE if non-nil is a |
406 |
|
function used to filter the possible choices and FLAG determines whether the |
407 |
|
completion is over." |
408 |
|
(let* ((candidates mh-range-seq-names) |
409 |
|
(last-char (and (not (equal string "")) |
410 |
|
(aref string (1- (length string))))) |
411 |
|
(last-word (cond ((null last-char) "") |
412 |
|
((memq last-char '(? ?- ?:)) "") |
413 |
|
(t (car (last (split-string string "[ -:]+")))))) |
414 |
|
(prefix (substring string 0 (- (length string) (length last-word))))) |
415 |
|
(cond ((eq flag nil) |
416 |
|
(let ((res (try-completion last-word candidates predicate))) |
417 |
|
(cond ((null res) nil) |
418 |
|
((eq res t) t) |
419 |
|
(t (concat prefix res))))) |
420 |
|
((eq flag t) |
421 |
|
(all-completions last-word candidates predicate)) |
422 |
|
((eq flag 'lambda) |
423 |
|
(loop for x in candidates |
424 |
|
when (equal x last-word) return t |
425 |
|
finally return nil))))) |
426 |
|
|
427 |
|
;;;###mh-autoload |
428 |
|
(defun mh-read-range (prompt &optional folder default |
429 |
|
expand-flag ask-flag number-as-range-flag) |
430 |
|
"Read a message range with PROMPT. |
431 |
|
|
432 |
|
If FOLDER is non-nil then a range is read from that folder, otherwise use |
433 |
|
`mh-current-folder'. |
434 |
|
|
435 |
|
If DEFAULT is a string then use that as default range to return. If DEFAULT is |
436 |
|
nil then ask user with default answer a range based on the sequences that seem |
437 |
|
relevant. Finally if DEFAULT is t, try to avoid prompting the user. Unseen |
438 |
|
messages, if present, are returned. If the folder has fewer than |
439 |
|
`mh-large-folder' messages then \"all\" messages are returned. Finally as a |
440 |
|
last resort prompt the user. |
441 |
|
|
442 |
|
If EXPAND-FLAG is non-nil then a list of message numbers corresponding to the |
443 |
|
input is returned. If this list is empty then an error is raised. If |
444 |
|
EXPAND-FLAG is nil just return the input string. In this case we don't check |
445 |
|
if the range is empty. |
446 |
|
|
447 |
|
If ASK-FLAG is non-nil, then the user is always queried for a range of |
448 |
|
messages. If ASK-FLAG is nil, then the function checks if the unseen sequence |
449 |
|
is non-empty. If that is the case, `mh-unseen-seq', or the list of messages in |
450 |
|
it depending on the value of EXPAND, is returned. Otherwise if the folder has |
451 |
|
fewer than `mh-large-folder' messages then the list of messages corresponding |
452 |
|
to \"all\" is returned. If neither of the above holds then as a last resort |
453 |
|
the user is queried for a range of messages. |
454 |
|
|
455 |
|
If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as input, it |
456 |
|
is interpreted as the range \"last:N\". |
457 |
|
|
458 |
|
This function replaces the existing function `mh-read-msg-range'. Calls to: |
459 |
|
(mh-read-msg-range folder flag) |
460 |
|
should be replaced with: |
461 |
|
(mh-read-range \"Suitable prompt\" folder t nil flag |
462 |
|
mh-interpret-number-as-range-flag)" |
463 |
|
(setq default (or default mh-last-seq-used |
464 |
|
(car (mh-seq-containing-msg (mh-get-msg-num nil) t))) |
465 |
|
prompt (format "%s range" prompt)) |
466 |
|
(let* ((folder (or folder mh-current-folder)) |
467 |
|
(default (cond ((or (eq default t) (stringp default)) default) |
468 |
|
((symbolp default) (symbol-name default)))) |
469 |
|
(guess (eq default t)) |
470 |
|
(counts (and guess (mh-folder-size folder))) |
471 |
|
(unseen (and counts (> (cadr counts) 0))) |
472 |
|
(large (and counts mh-large-folder (> (car counts) mh-large-folder))) |
473 |
|
(str (cond ((and guess large |
474 |
|
(setq default (format "last:%s" mh-large-folder) |
475 |
|
prompt (format "%s (folder has %s messages)" |
476 |
|
prompt (car counts))) |
477 |
|
nil)) |
478 |
|
((and guess (not large) (setq default "all") nil)) |
479 |
|
((eq default nil) "") |
480 |
|
(t (format "[%s] " default)))) |
481 |
|
(minibuffer-local-completion-map mh-range-completion-map) |
482 |
|
(seq-list (if (eq folder mh-current-folder) |
483 |
|
mh-seq-list |
484 |
|
(mh-read-folder-sequences folder nil))) |
485 |
|
(mh-range-seq-names |
486 |
|
(append '(("first") ("last") ("all") ("prev") ("next")) |
487 |
|
(mh-seq-names seq-list))) |
488 |
|
(input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq)) |
489 |
|
((and (not ask-flag) (not large)) "all") |
490 |
|
(t (completing-read (format "%s: %s" prompt str) |
491 |
|
'mh-range-completion-function nil nil |
492 |
|
nil 'mh-range-history default)))) |
493 |
|
msg-list) |
494 |
|
(when (and number-as-range-flag |
495 |
|
(string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input)) |
496 |
|
(setq input (concat "last:" (match-string 1 input)))) |
497 |
|
(cond ((not expand-flag) input) |
498 |
|
((assoc (intern input) seq-list) |
499 |
|
(cdr (assoc (intern input) seq-list))) |
500 |
|
((setq msg-list (mh-translate-range folder input)) msg-list) |
501 |
|
(t (error "No messages in range `%s'" input))))) |
502 |
|
|
503 |
|
;;;###mh-autoload |
504 |
|
(defun mh-translate-range (folder expr) |
505 |
|
"In FOLDER, translate the string EXPR to a list of messages numbers." |
506 |
|
(save-excursion |
507 |
|
(let ((strings (delete "" (split-string expr "[ \t\n]"))) |
508 |
|
(result ())) |
509 |
|
(ignore-errors |
510 |
|
(apply #'mh-exec-cmd-quiet nil "mhpath" folder strings) |
511 |
|
(set-buffer mh-temp-buffer) |
512 |
|
(goto-char (point-min)) |
513 |
|
(while (re-search-forward "/\\([0-9]*\\)$" nil t) |
514 |
|
(push (car (read-from-string (match-string 1))) result)) |
515 |
|
(nreverse result))))) |
516 |
|
|
517 |
(defun mh-seq-names (seq-list) |
(defun mh-seq-names (seq-list) |
518 |
"Return an alist containing the names of the SEQ-LIST." |
"Return an alist containing the names of the SEQ-LIST." |
519 |
(mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) |
(mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) |
571 |
(defun mh-add-to-sequence (seq msgs) |
(defun mh-add-to-sequence (seq msgs) |
572 |
"The sequence SEQ is augmented with the messages in MSGS." |
"The sequence SEQ is augmented with the messages in MSGS." |
573 |
;; Add to a SEQUENCE each message the list of MSGS. |
;; Add to a SEQUENCE each message the list of MSGS. |
574 |
(if (not (mh-folder-name-p seq)) |
(if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq))) |
575 |
(if msgs |
(if msgs |
576 |
(apply 'mh-exec-cmd "mark" mh-current-folder "-add" |
(apply 'mh-exec-cmd "mark" mh-current-folder "-add" |
577 |
"-sequence" (symbol-name seq) |
"-sequence" (symbol-name seq) |
602 |
(mh-regenerate-headers coalesced-msgs t) |
(mh-regenerate-headers coalesced-msgs t) |
603 |
(cond ((memq 'unthread mh-view-ops) |
(cond ((memq 'unthread mh-view-ops) |
604 |
;; Populate restricted scan-line map |
;; Populate restricted scan-line map |
605 |
(goto-char (point-min)) |
(mh-remove-all-notation) |
606 |
(while (not (eobp)) |
(mh-iterate-on-range msg (cons (point-min) (point-max)) |
607 |
(let ((msg (mh-get-msg-num nil))) |
(setf (gethash msg mh-thread-scan-line-map) |
608 |
(when (numberp msg) |
(mh-thread-parse-scan-line))) |
|
(setf (gethash msg mh-thread-scan-line-map) |
|
|
(mh-thread-parse-scan-line)))) |
|
|
(forward-line)) |
|
609 |
;; Remove scan lines and read results from pre-computed tree |
;; Remove scan lines and read results from pre-computed tree |
610 |
(delete-region (point-min) (point-max)) |
(delete-region (point-min) (point-max)) |
611 |
(mh-thread-print-scan-lines |
(mh-thread-print-scan-lines |
612 |
(mh-thread-generate mh-current-folder ()))) |
(mh-thread-generate mh-current-folder ())) |
613 |
|
(mh-notate-user-sequences)) |
614 |
(mh-index-data |
(mh-index-data |
615 |
(mh-index-insert-folder-headers))))))) |
(mh-index-insert-folder-headers))))))) |
616 |
|
|
651 |
(put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) |
(put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) |
652 |
|
|
653 |
;;;###mh-autoload |
;;;###mh-autoload |
654 |
(defmacro mh-iterate-on-msg-or-seq (var msg-or-seq &rest body) |
(defmacro mh-iterate-on-range (var range &rest body) |
655 |
"Iterate an operation over a region or sequence. |
"Iterate an operation over a region or sequence. |
656 |
|
|
657 |
VAR is bound to each message in turn in a loop over MSG-OR-SEQ, which can be a |
VAR is bound to each message in turn in a loop over RANGE, which can be a |
658 |
message number, a list of message numbers, a sequence, or a region in a cons |
message number, a list of message numbers, a sequence, a region in a cons |
659 |
cell. In each iteration, BODY is executed. |
cell, or a MH range (something like last:20) in a string. In each iteration, |
660 |
|
BODY is executed. |
661 |
|
|
662 |
The parameter MSG-OR-SEQ is usually created with `mh-interactive-msg-or-seq' |
The parameter RANGE is usually created with `mh-interactive-range' |
663 |
in order to provide a uniform interface to MH-E functions." |
in order to provide a uniform interface to MH-E functions." |
664 |
(unless (symbolp var) |
(unless (symbolp var) |
665 |
(error "Can not bind the non-symbol %s" var)) |
(error "Can not bind the non-symbol %s" var)) |
666 |
(let ((binding-needed-flag var) |
(let ((binding-needed-flag var) |
667 |
(msgs (make-symbol "msgs")) |
(msgs (make-symbol "msgs")) |
668 |
(seq-hash-table (make-symbol "seq-hash-table"))) |
(seq-hash-table (make-symbol "seq-hash-table"))) |
669 |
`(cond ((numberp ,msg-or-seq) |
`(cond ((numberp ,range) |
670 |
(when (mh-goto-msg ,msg-or-seq t t) |
(when (mh-goto-msg ,range t t) |
671 |
(let ,(if binding-needed-flag `((,var ,msg-or-seq)) ()) |
(let ,(if binding-needed-flag `((,var ,range)) ()) |
672 |
,@body))) |
,@body))) |
673 |
((and (consp ,msg-or-seq) |
((and (consp ,range) |
674 |
(numberp (car ,msg-or-seq)) (numberp (cdr ,msg-or-seq))) |
(numberp (car ,range)) (numberp (cdr ,range))) |
675 |
(mh-iterate-on-messages-in-region ,var |
(mh-iterate-on-messages-in-region ,var |
676 |
(car ,msg-or-seq) (cdr ,msg-or-seq) |
(car ,range) (cdr ,range) |
677 |
,@body)) |
,@body)) |
678 |
(t (let ((,msgs (if (and ,msg-or-seq (symbolp ,msg-or-seq)) |
(t (let ((,msgs (cond ((and ,range (symbolp ,range)) |
679 |
(mh-seq-to-msgs ,msg-or-seq) |
(mh-seq-to-msgs ,range)) |
680 |
,msg-or-seq)) |
((stringp ,range) |
681 |
|
(mh-translate-range mh-current-folder |
682 |
|
,range)) |
683 |
|
(t ,range))) |
684 |
(,seq-hash-table (make-hash-table))) |
(,seq-hash-table (make-hash-table))) |
685 |
(dolist (msg ,msgs) |
(dolist (msg ,msgs) |
686 |
(setf (gethash msg ,seq-hash-table) t)) |
(setf (gethash msg ,seq-hash-table) t)) |
689 |
(let ,(if binding-needed-flag `((,var v)) ()) |
(let ,(if binding-needed-flag `((,var v)) ()) |
690 |
,@body)))))))) |
,@body)))))))) |
691 |
|
|
692 |
(put 'mh-iterate-on-msg-or-seq 'lisp-indent-hook 'defun) |
(put 'mh-iterate-on-range 'lisp-indent-hook 'defun) |
693 |
|
|
694 |
;;;###mh-autoload |
;;;###mh-autoload |
695 |
(defun mh-msg-or-seq-to-msg-list (msg-or-seq) |
(defun mh-range-to-msg-list (range) |
696 |
"Return a list of messages for MSG-OR-SEQ. |
"Return a list of messages for RANGE. |
697 |
MSG-OR-SEQ can be a message number, a list of message numbers, a sequence, or |
RANGE can be a message number, a list of message numbers, a sequence, or |
698 |
a region in a cons cell." |
a region in a cons cell." |
699 |
(let (msg-list) |
(let (msg-list) |
700 |
(mh-iterate-on-msg-or-seq msg msg-or-seq |
(mh-iterate-on-range msg range |
701 |
(push msg msg-list)) |
(push msg msg-list)) |
702 |
(nreverse msg-list))) |
(nreverse msg-list))) |
703 |
|
|
704 |
;;;###mh-autoload |
;;;###mh-autoload |
705 |
(defun mh-interactive-msg-or-seq (sequence-prompt) |
(defun mh-interactive-range (range-prompt) |
706 |
"Return interactive specification for message, sequence, or region. |
"Return interactive specification for message, sequence, range or region. |
707 |
By convention, the name of this argument is msg-or-seq. |
By convention, the name of this argument is RANGE. |
708 |
|
|
709 |
If variable `transient-mark-mode' is non-nil and the mark is active, then this |
If variable `transient-mark-mode' is non-nil and the mark is active, then this |
710 |
function returns a cons-cell of the region. |
function returns a cons-cell of the region. |
711 |
If optional prefix argument provided, then prompt for message sequence with |
|
712 |
SEQUENCE-PROMPT and return sequence. |
If optional prefix argument is provided, then prompt for message range with |
713 |
|
RANGE-PROMPT. A list of messages in that range is returned. |
714 |
|
|
715 |
|
If a MH range is given, say something like last:20, then a list containing |
716 |
|
the messages in that range is returned. |
717 |
|
|
718 |
Otherwise, the message number at point is returned. |
Otherwise, the message number at point is returned. |
719 |
|
|
720 |
This function is usually used with `mh-iterate-on-msg-or-seq' in order to |
This function is usually used with `mh-iterate-on-range' in order to provide |
721 |
provide a uniform interface to MH-E functions." |
a uniform interface to MH-E functions." |
722 |
(cond |
(cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) |
723 |
((mh-mark-active-p t) |
(current-prefix-arg (mh-read-range range-prompt nil nil t t)) |
724 |
(cons (region-beginning) (region-end))) |
(t (mh-get-msg-num t)))) |
|
(current-prefix-arg |
|
|
(mh-read-seq-default sequence-prompt t)) |
|
|
(t |
|
|
(mh-get-msg-num t)))) |
|
725 |
|
|
726 |
;;;###mh-autoload |
;;;###mh-autoload |
727 |
(defun mh-region-to-msg-list (begin end) |
(defun mh-region-to-msg-list (begin end) |
738 |
;;; Commands to handle new 'subject sequence. |
;;; Commands to handle new 'subject sequence. |
739 |
;;; Or "Poor man's threading" by psg. |
;;; Or "Poor man's threading" by psg. |
740 |
|
|
741 |
|
;;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number |
742 |
|
;;; 41 for the max size of the subject part. Avoiding this would be desirable. |
743 |
(defun mh-subject-to-sequence (all) |
(defun mh-subject-to-sequence (all) |
744 |
"Put all following messages with same subject in sequence 'subject. |
"Put all following messages with same subject in sequence 'subject. |
745 |
If arg ALL is t, move to beginning of folder buffer to collect all messages. |
If arg ALL is t, move to beginning of folder buffer to collect all messages. |
750 |
nil -> there was no subject line. |
nil -> there was no subject line. |
751 |
0 -> there were no later messages with the same subject (sequence not made) |
0 -> there were no later messages with the same subject (sequence not made) |
752 |
>1 -> the total number of messages including current one." |
>1 -> the total number of messages including current one." |
753 |
|
(if (memq 'unthread mh-view-ops) |
754 |
|
(mh-subject-to-sequence-threaded all) |
755 |
|
(mh-subject-to-sequence-unthreaded all))) |
756 |
|
|
757 |
|
(defun mh-subject-to-sequence-unthreaded (all) |
758 |
|
"Put all following messages with same subject in sequence 'subject. |
759 |
|
This function only works with an unthreaded folder. If arg ALL is t, move to |
760 |
|
beginning of folder buffer to collect all messages. If arg ALL is nil, collect |
761 |
|
only messages fron current one on forward. |
762 |
|
|
763 |
|
Return number of messages put in the sequence: |
764 |
|
|
765 |
|
nil -> there was no subject line. |
766 |
|
0 -> there were no later messages with the same subject (sequence not made) |
767 |
|
>1 -> the total number of messages including current one." |
768 |
(if (not (eq major-mode 'mh-folder-mode)) |
(if (not (eq major-mode 'mh-folder-mode)) |
769 |
(error "Not in a folder buffer")) |
(error "Not in a folder buffer")) |
770 |
(save-excursion |
(save-excursion |
792 |
;; If we created a new sequence, add the initial message to it too. |
;; If we created a new sequence, add the initial message to it too. |
793 |
(if (not (member (mh-get-msg-num t) list)) |
(if (not (member (mh-get-msg-num t) list)) |
794 |
(setq list (cons (mh-get-msg-num t) list))) |
(setq list (cons (mh-get-msg-num t) list))) |
795 |
(if (member '("subject") (mh-seq-names mh-seq-list)) |
(if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject)) |
|
(mh-delete-seq 'subject)) |
|
796 |
;; sort the result into a sequence |
;; sort the result into a sequence |
797 |
(let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) |
(let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) |
798 |
(while sorted-list |
(while sorted-list |
802 |
(t |
(t |
803 |
0)))))) |
0)))))) |
804 |
|
|
805 |
|
(defun mh-subject-to-sequence-threaded (all) |
806 |
|
"Put all messages with the same subject in the 'subject sequence. |
807 |
|
This function works when the folder is threaded. In this situation the subject |
808 |
|
could get truncated and so the normal matching doesn't work. |
809 |
|
|
810 |
|
The parameter ALL is non-nil then all the messages in the buffer are |
811 |
|
considered, otherwise only the messages after the current one are taken into |
812 |
|
account." |
813 |
|
(let* ((cur (mh-get-msg-num nil)) |
814 |
|
(subject (mh-thread-find-msg-subject cur)) |
815 |
|
region msgs) |
816 |
|
(if (null subject) |
817 |
|
(and (message "No subject line") nil) |
818 |
|
(setq region (cons (if all (point-min) (point)) (point-max))) |
819 |
|
(mh-iterate-on-range msg region |
820 |
|
(when (eq (mh-thread-find-msg-subject msg) subject) |
821 |
|
(push msg msgs))) |
822 |
|
(setq msgs (sort msgs #'mh-lessp)) |
823 |
|
(if (null msgs) |
824 |
|
0 |
825 |
|
(when (assoc 'subject mh-seq-list) |
826 |
|
(mh-delete-seq 'subject)) |
827 |
|
(mh-add-msgs-to-seq msgs 'subject) |
828 |
|
(length msgs))))) |
829 |
|
|
830 |
|
(defun mh-thread-find-msg-subject (msg) |
831 |
|
"Find canonicalized subject of MSG. |
832 |
|
This function can only be used the folder is threaded." |
833 |
|
(ignore-errors |
834 |
|
(mh-message-subject |
835 |
|
(mh-container-message (gethash (gethash msg mh-thread-index-id-map) |
836 |
|
mh-thread-id-table))))) |
837 |
|
|
838 |
;;;###mh-autoload |
;;;###mh-autoload |
839 |
(defun mh-narrow-to-subject () |
(defun mh-narrow-to-subject () |
840 |
"Narrow to a sequence containing all following messages with same subject." |
"Narrow to a sequence containing all following messages with same subject." |
853 |
(if (numberp num) |
(if (numberp num) |
854 |
(mh-goto-msg num t t)))))) |
(mh-goto-msg num t t)))))) |
855 |
|
|
856 |
|
(defun mh-read-pick-regexp (default) |
857 |
|
"With prefix arg read a pick regexp. |
858 |
|
If no prefix arg is given, then return DEFAULT." |
859 |
|
(let ((default-string (loop for x in default concat (format " %s" x)))) |
860 |
|
(if (or current-prefix-arg (equal default-string "")) |
861 |
|
(delete "" (split-string (read-string "Pick regexp: " default-string))) |
862 |
|
default))) |
863 |
|
|
864 |
|
;;;###mh-autoload |
865 |
|
(defun mh-narrow-to-from (&optional regexp) |
866 |
|
"Limit to messages with the same From header field as the message at point. |
867 |
|
With a prefix argument, prompt for the regular expression, REGEXP given to |
868 |
|
pick." |
869 |
|
(interactive |
870 |
|
(list (mh-read-pick-regexp (mh-current-message-header-field 'from)))) |
871 |
|
(mh-narrow-to-header-field 'from regexp)) |
872 |
|
|
873 |
|
;;;###mh-autoload |
874 |
|
(defun mh-narrow-to-cc (&optional regexp) |
875 |
|
"Limit to messages with the same Cc header field as the message at point. |
876 |
|
With a prefix argument, prompt for the regular expression, REGEXP given to |
877 |
|
pick." |
878 |
|
(interactive |
879 |
|
(list (mh-read-pick-regexp (mh-current-message-header-field 'cc)))) |
880 |
|
(mh-narrow-to-header-field 'cc regexp)) |
881 |
|
|
882 |
|
;;;###mh-autoload |
883 |
|
(defun mh-narrow-to-to (&optional regexp) |
884 |
|
"Limit to messages with the same To header field as the message at point. |
885 |
|
With a prefix argument, prompt for the regular expression, REGEXP given to |
886 |
|
pick." |
887 |
|
(interactive |
888 |
|
(list (mh-read-pick-regexp (mh-current-message-header-field 'to)))) |
889 |
|
(mh-narrow-to-header-field 'to regexp)) |
890 |
|
|
891 |
|
(defun mh-narrow-to-header-field (header-field regexp) |
892 |
|
"Limit to messages whose HEADER-FIELD match REGEXP. |
893 |
|
The MH command pick is used to do the match." |
894 |
|
(let ((folder mh-current-folder) |
895 |
|
(original (mh-coalesce-msg-list |
896 |
|
(mh-range-to-msg-list (cons (point-min) (point-max))))) |
897 |
|
(msg-list ())) |
898 |
|
(with-temp-buffer |
899 |
|
(apply #'mh-exec-cmd-output "pick" nil folder |
900 |
|
(append original (list "-list") regexp)) |
901 |
|
(goto-char (point-min)) |
902 |
|
(while (not (eobp)) |
903 |
|
(let ((num (read-from-string |
904 |
|
(buffer-substring (point) (line-end-position))))) |
905 |
|
(when (numberp (car num)) (push (car num) msg-list)) |
906 |
|
(forward-line)))) |
907 |
|
(if (null msg-list) |
908 |
|
(message "No matches") |
909 |
|
(when (assoc 'header mh-seq-list) (mh-delete-seq 'header)) |
910 |
|
(mh-add-msgs-to-seq msg-list 'header) |
911 |
|
(mh-narrow-to-seq 'header)))) |
912 |
|
|
913 |
|
(defun mh-current-message-header-field (header-field) |
914 |
|
"Return a pick regexp to match HEADER-FIELD of the message at point." |
915 |
|
(let ((num (mh-get-msg-num nil))) |
916 |
|
(when num |
917 |
|
(let ((folder mh-current-folder)) |
918 |
|
(with-temp-buffer |
919 |
|
(insert-file-contents-literally (mh-msg-filename num folder)) |
920 |
|
(goto-char (point-min)) |
921 |
|
(when (search-forward "\n\n" nil t) |
922 |
|
(narrow-to-region (point-min) (point))) |
923 |
|
(let* ((field (or (message-fetch-field (format "%s" header-field)) |
924 |
|
"")) |
925 |
|
(field-option (format "-%s" header-field)) |
926 |
|
(patterns (loop for x in (split-string field "[ ]*,[ ]*") |
927 |
|
unless (equal x "") |
928 |
|
collect (if (string-match "<\\(.*@.*\\)>" x) |
929 |
|
(match-string 1 x) |
930 |
|
x)))) |
931 |
|
(when patterns |
932 |
|
(loop with accum = `(,field-option ,(car patterns)) |
933 |
|
for e in (cdr patterns) |
934 |
|
do (setq accum `(,field-option ,e "-or" ,@accum)) |
935 |
|
finally return accum)))))))) |
936 |
|
|
937 |
|
;;;###mh-autoload |
938 |
|
(defun mh-narrow-to-range (range) |
939 |
|
"Limit to messages in RANGE. |
940 |
|
|
941 |
|
Check the documentation of `mh-interactive-range' to see how RANGE is read in |
942 |
|
interactive use." |
943 |
|
(interactive (list (mh-interactive-range "Narrow to"))) |
944 |
|
(when (assoc 'range mh-seq-list) (mh-delete-seq 'range)) |
945 |
|
(mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range) |
946 |
|
(mh-narrow-to-seq 'range)) |
947 |
|
|
948 |
|
|
949 |
;;;###mh-autoload |
;;;###mh-autoload |
950 |
(defun mh-delete-subject () |
(defun mh-delete-subject () |
951 |
"Mark all following messages with same subject to be deleted. |
"Mark all following messages with same subject to be deleted. |
978 |
|
|
979 |
;;; Message threading: |
;;; Message threading: |
980 |
|
|
981 |
|
(defmacro mh-thread-initialize-hash (var test) |
982 |
|
"Initialize the hash table in VAR. |
983 |
|
TEST is the test to use when creating a new hash table." |
984 |
|
(unless (symbolp var) (error "Expected a symbol: %s" var)) |
985 |
|
`(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) |
986 |
|
|
987 |
(defun mh-thread-initialize () |
(defun mh-thread-initialize () |
988 |
"Make hash tables, otherwise clear them." |
"Make new hash tables, or clear them if already present." |
989 |
(cond |
(mh-thread-initialize-hash mh-thread-id-hash #'equal) |
990 |
(mh-thread-id-hash |
(mh-thread-initialize-hash mh-thread-subject-hash #'equal) |
991 |
(clrhash mh-thread-id-hash) |
(mh-thread-initialize-hash mh-thread-id-table #'eq) |
992 |
(clrhash mh-thread-subject-hash) |
(mh-thread-initialize-hash mh-thread-id-index-map #'eq) |
993 |
(clrhash mh-thread-id-table) |
(mh-thread-initialize-hash mh-thread-index-id-map #'eql) |
994 |
(clrhash mh-thread-id-index-map) |
(mh-thread-initialize-hash mh-thread-scan-line-map #'eql) |
995 |
(clrhash mh-thread-index-id-map) |
(mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) |
996 |
(clrhash mh-thread-scan-line-map) |
(mh-thread-initialize-hash mh-thread-duplicates #'eq) |
997 |
(clrhash mh-thread-subject-container-hash) |
(setq mh-thread-history ())) |
|
(clrhash mh-thread-duplicates) |
|
|
(setq mh-thread-history ())) |
|
|
(t (setq mh-thread-id-hash (make-hash-table :test #'equal)) |
|
|
(setq mh-thread-subject-hash (make-hash-table :test #'equal)) |
|
|
(setq mh-thread-id-table (make-hash-table :test #'eq)) |
|
|
(setq mh-thread-id-index-map (make-hash-table :test #'eq)) |
|
|
(setq mh-thread-index-id-map (make-hash-table :test #'eql)) |
|
|
(setq mh-thread-scan-line-map (make-hash-table :test #'eql)) |
|
|
(setq mh-thread-subject-container-hash (make-hash-table :test #'eq)) |
|
|
(setq mh-thread-duplicates (make-hash-table :test #'eq)) |
|
|
(setq mh-thread-history ())))) |
|
998 |
|
|
999 |
(defsubst mh-thread-id-container (id) |
(defsubst mh-thread-id-container (id) |
1000 |
"Given ID, return the corresponding container in `mh-thread-id-table'. |
"Given ID, return the corresponding container in `mh-thread-id-table'. |
1243 |
(push root results))))) |
(push root results))))) |
1244 |
(nreverse results))) |
(nreverse results))) |
1245 |
|
|
1246 |
(defsubst mh-thread-process-in-reply-to (reply-to-header) |
(defun mh-thread-process-in-reply-to (reply-to-header) |
1247 |
"Extract message id's from REPLY-TO-HEADER. |
"Extract message id's from REPLY-TO-HEADER. |
1248 |
Ideally this should have some regexp which will try to guess if a string |
Ideally this should have some regexp which will try to guess if a string |
1249 |
between < and > is a message id and not an email address. For now it will |
between < and > is a message id and not an email address. For now it will |
1355 |
"Update thread tree for FOLDER. |
"Update thread tree for FOLDER. |
1356 |
All messages after START-POINT are added to the thread tree." |
All messages after START-POINT are added to the thread tree." |
1357 |
(mh-thread-rewind-pruning) |
(mh-thread-rewind-pruning) |
1358 |
|
(mh-remove-all-notation) |
1359 |
(goto-char start-point) |
(goto-char start-point) |
1360 |
(let ((msg-list ())) |
(let ((msg-list ())) |
1361 |
(while (not (eobp)) |
(while (not (eobp)) |
1370 |
(old-buffer-modified-flag (buffer-modified-p))) |
(old-buffer-modified-flag (buffer-modified-p))) |
1371 |
(delete-region (point-min) (point-max)) |
(delete-region (point-min) (point-max)) |
1372 |
(mh-thread-print-scan-lines thread-tree) |
(mh-thread-print-scan-lines thread-tree) |
|
(mh-notate-user-sequences) |
|
1373 |
(mh-notate-deleted-and-refiled) |
(mh-notate-deleted-and-refiled) |
1374 |
(mh-notate-cur) |
(mh-notate-cur) |
1375 |
(set-buffer-modified-p old-buffer-modified-flag)))) |
(set-buffer-modified-p old-buffer-modified-flag)))) |
1434 |
(let* ((string (or string |
(let* ((string (or string |
1435 |
(buffer-substring-no-properties (line-beginning-position) |
(buffer-substring-no-properties (line-beginning-position) |
1436 |
(line-end-position)))) |
(line-end-position)))) |
1437 |
(first-string (substring string 0 (+ mh-cmd-note 8)))) |
(address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) |
1438 |
(setf (elt first-string mh-cmd-note) ? ) |
(body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) |
1439 |
(when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0)) |
(first-string (substring string 0 address-start))) |
|
(setf (elt first-string (1+ mh-cmd-note)) ? )) |
|
1440 |
(list first-string |
(list first-string |
1441 |
(substring string |
(substring string address-start (- body-start 2)) |
1442 |
(+ mh-cmd-note mh-scan-field-from-start-offset) |
(substring string body-start) |
|
(+ mh-cmd-note mh-scan-field-from-end-offset -2)) |
|
|
(substring string (+ mh-cmd-note mh-scan-field-from-end-offset)) |
|
1443 |
string))) |
string))) |
1444 |
|
|
1445 |
;;;###mh-autoload |
;;;###mh-autoload |
1446 |
|
(defun mh-thread-update-scan-line-map (msg notation offset) |
1447 |
|
"In threaded view update `mh-thread-scan-line-map'. |
1448 |
|
MSG is the message being notated with NOTATION at OFFSET." |
1449 |
|
(let* ((msg (or msg (mh-get-msg-num nil))) |
1450 |
|
(cur-scan-line (and mh-thread-scan-line-map |
1451 |
|
(gethash msg mh-thread-scan-line-map))) |
1452 |
|
(old-scan-lines (loop for map in mh-thread-scan-line-map-stack |
1453 |
|
collect (and map (gethash msg map)))) |
1454 |
|
(notation (if (stringp notation) (aref notation 0) notation))) |
1455 |
|
(when cur-scan-line |
1456 |
|
(setf (aref (car cur-scan-line) offset) notation)) |
1457 |
|
(dolist (line old-scan-lines) |
1458 |
|
(when line (setf (aref (car line) offset) notation))))) |
1459 |
|
|
1460 |
|
;;;###mh-autoload |
1461 |
(defun mh-thread-add-spaces (count) |
(defun mh-thread-add-spaces (count) |
1462 |
"Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." |
"Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." |
1463 |
(let ((spaces (format (format "%%%ss" count) ""))) |
(let ((spaces (format (format "%%%ss" count) ""))) |
1493 |
(message "Threading %s..." (buffer-name)) |
(message "Threading %s..." (buffer-name)) |
1494 |
(mh-thread-initialize) |
(mh-thread-initialize) |
1495 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1496 |
|
(mh-remove-all-notation) |
1497 |
(let ((msg-list ())) |
(let ((msg-list ())) |
1498 |
(while (not (eobp)) |
(mh-iterate-on-range msg (cons (point-min) (point-max)) |
1499 |
(let ((index (mh-get-msg-num nil))) |
(setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) |
1500 |
(when (numberp index) |
(push msg msg-list)) |
|
(push index msg-list) |
|
|
(setf (gethash index mh-thread-scan-line-map) |
|
|
(mh-thread-parse-scan-line)))) |
|
|
(forward-line)) |
|
1501 |
(let* ((range (mh-coalesce-msg-list msg-list)) |
(let* ((range (mh-coalesce-msg-list msg-list)) |
1502 |
(thread-tree (mh-thread-generate (buffer-name) range))) |
(thread-tree (mh-thread-generate (buffer-name) range))) |
1503 |
(delete-region (point-min) (point-max)) |
(delete-region (point-min) (point-max)) |
1696 |
|
|
1697 |
;; Tick mark handling |
;; Tick mark handling |
1698 |
|
|
1699 |
;; Functions to highlight and unhighlight ticked messages. |
;;;###mh-autoload |
1700 |
(defun mh-tick-add-overlay () |
(defun mh-toggle-tick (range) |
1701 |
"Add tick overlay to current line." |
"Toggle tick mark of all messages in RANGE." |
1702 |
(with-mh-folder-updating (t) |
(interactive (list (mh-interactive-range "Tick"))) |
|
(let ((overlay |
|
|
(or (mh-funcall-if-exists make-overlay (point) (line-end-position)) |
|
|
(mh-funcall-if-exists make-extent (point) (line-end-position))))) |
|
|
(or (mh-funcall-if-exists overlay-put overlay 'face 'mh-folder-tick-face) |
|
|
(mh-funcall-if-exists set-extent-face overlay 'mh-folder-tick-face)) |
|
|
(mh-funcall-if-exists set-extent-priority overlay 10) |
|
|
(add-text-properties (point) (line-end-position) `(mh-tick ,overlay))))) |
|
|
|
|
|
(defun mh-tick-remove-overlay () |
|
|
"Remove tick overlay from current line." |
|
|
(let ((overlay (get-text-property (point) 'mh-tick))) |
|
|
(when overlay |
|
|
(with-mh-folder-updating (t) |
|
|
(or (mh-funcall-if-exists delete-overlay overlay) |
|
|
(mh-funcall-if-exists delete-extent overlay)) |
|
|
(remove-text-properties (point) (line-end-position) `(mh-tick nil)))))) |
|
|
|
|
|
;;;###mh-autoload |
|
|
(defun mh-notate-tick (msg ticked-msgs &optional ignore-narrowing) |
|
|
"Highlight current line if MSG is in TICKED-MSGS. |
|
|
If optional argument IGNORE-NARROWING is non-nil then highlighting is carried |
|
|
out even if folder is narrowed to `mh-tick-seq'." |
|
|
(when mh-tick-seq |
|
|
(let ((narrowed-to-tick (and (not ignore-narrowing) |
|
|
(eq mh-narrowed-to-seq mh-tick-seq))) |
|
|
(overlay (get-text-property (point) 'mh-tick)) |
|
|
(in-tick (member msg ticked-msgs))) |
|
|
(cond (narrowed-to-tick (mh-tick-remove-overlay)) |
|
|
((and (not overlay) in-tick) (mh-tick-add-overlay)) |
|
|
((and overlay (not in-tick)) (mh-tick-remove-overlay)))))) |
|
|
|
|
|
;; Interactive function to toggle tick. |
|
|
;;;###mh-autoload |
|
|
(defun mh-toggle-tick (begin end) |
|
|
"Toggle tick mark of all messages in region BEGIN to END." |
|
|
(interactive (cond ((mh-mark-active-p t) |
|
|
(list (region-beginning) (region-end))) |
|
|
(t (list (line-beginning-position) (line-end-position))))) |
|
1703 |
(unless mh-tick-seq |
(unless mh-tick-seq |
1704 |
(error "Enable ticking by customizing `mh-tick-seq'")) |
(error "Enable ticking by customizing `mh-tick-seq'")) |
1705 |
(let* ((tick-seq (mh-find-seq mh-tick-seq)) |
(let* ((tick-seq (mh-find-seq mh-tick-seq)) |
1706 |
(tick-seq-msgs (mh-seq-msgs tick-seq))) |
(tick-seq-msgs (mh-seq-msgs tick-seq)) |
1707 |
(mh-iterate-on-messages-in-region msg begin end |
(ticked ()) |
1708 |
|
(unticked ())) |
1709 |
|
(mh-iterate-on-range msg range |
1710 |
(cond ((member msg tick-seq-msgs) |
(cond ((member msg tick-seq-msgs) |
1711 |
(mh-undefine-sequence mh-tick-seq (list msg)) |
(push msg unticked) |
1712 |
(setcdr tick-seq (delq msg (cdr tick-seq))) |
(setcdr tick-seq (delq msg (cdr tick-seq))) |
1713 |
(when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) |
(when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) |
1714 |
(mh-tick-remove-overlay)) |
(mh-remove-sequence-notation msg t)) |
1715 |
(t |
(t |
1716 |
(mh-add-msgs-to-seq (list msg) mh-tick-seq nil t) |
(push msg ticked) |
1717 |
(setq mh-last-seq-used mh-tick-seq) |
(setq mh-last-seq-used mh-tick-seq) |
1718 |
(mh-tick-add-overlay)))) |
(mh-add-sequence-notation msg t)))) |
1719 |
(when (and (eq mh-tick-seq mh-narrowed-to-seq) |
(mh-add-msgs-to-seq ticked mh-tick-seq nil t) |
1720 |
(not mh-tick-seq-changed-when-narrowed-flag)) |
(mh-undefine-sequence mh-tick-seq unticked) |
1721 |
(setq mh-tick-seq-changed-when-narrowed-flag t) |
(when mh-index-data |
1722 |
(let ((ticked-msgs (mh-seq-msgs (mh-find-seq mh-tick-seq)))) |
(mh-index-add-to-sequence mh-tick-seq ticked) |
1723 |
(mh-iterate-on-messages-in-region msg (point-min) (point-max) |
(mh-index-delete-from-sequence mh-tick-seq unticked)))) |
|
(mh-notate-tick msg ticked-msgs t)))))) |
|
1724 |
|
|
1725 |
;;;###mh-autoload |
;;;###mh-autoload |
1726 |
(defun mh-narrow-to-tick () |
(defun mh-narrow-to-tick () |