-If optional prefix argument is provided, then prompt for message range
-with RANGE-PROMPT. A list of messages in that range is returned.
-
-If a MH range is given, say something like last:20, then a list
-containing the messages in that range is returned.
-
-If DEFAULT non-nil then it is returned.
-
-Otherwise, the message number at point is returned.
-
-This function is usually used with `mh-iterate-on-range' in order to
-provide a uniform interface to MH-E functions."
- (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
- (current-prefix-arg (mh-read-range range-prompt nil nil t t))
- (default default)
- (t (mh-get-msg-num t))))
-
-\f
-
-;;; Commands to handle new 'subject sequence ("Poor man's threading" by psg)
-
-;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number
-;; 41 for the max size of the subject part. Avoiding this would be desirable.
-(defun mh-subject-to-sequence (all)
- "Put all following messages with same subject in sequence 'subject.
-If arg ALL is t, move to beginning of folder buffer to collect all
-messages.
-If arg ALL is nil, collect only messages fron current one on forward.
-
-Return number of messages put in the sequence:
-
- nil -> there was no subject line.
-
- 0 -> there were no later messages with the same
- subject (sequence not made)
-
- >1 -> the total number of messages including current one."
- (if (memq 'unthread mh-view-ops)
- (mh-subject-to-sequence-threaded all)
- (mh-subject-to-sequence-unthreaded all)))
-
-(defun mh-subject-to-sequence-unthreaded (all)
- "Put all following messages with same subject in sequence 'subject.
-
-This function only works with an unthreaded folder. If arg ALL is
-t, move to beginning of folder buffer to collect all messages. If
-arg ALL is nil, collect only messages fron current one on
-forward.
-
-Return number of messages put in the sequence:
-
- nil -> there was no subject line.
- 0 -> there were no later messages with the same
- subject (sequence not made)
- >1 -> the total number of messages including current one."
- (if (not (eq major-mode 'mh-folder-mode))
- (error "Not in a folder buffer"))
- (save-excursion
- (beginning-of-line)
- (if (or (not (looking-at mh-scan-subject-regexp))
- (not (match-string 3))
- (string-equal "" (match-string 3)))
- (progn (message "No subject line")
- nil)
- (let ((subject (match-string-no-properties 3))
- (list))
- (if (> (length subject) 41)
- (setq subject (substring subject 0 41)))
- (save-excursion
- (if all
- (goto-char (point-min)))
- (while (re-search-forward mh-scan-subject-regexp nil t)
- (let ((this-subject (match-string-no-properties 3)))
- (if (> (length this-subject) 41)
- (setq this-subject (substring this-subject 0 41)))
- (if (string-equal this-subject subject)
- (setq list (cons (mh-get-msg-num t) list))))))
- (cond
- (list
- ;; If we created a new sequence, add the initial message to it too.
- (if (not (member (mh-get-msg-num t) list))
- (setq list (cons (mh-get-msg-num t) list)))
- (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject))
- ;; sort the result into a sequence
- (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))
- (while sorted-list
- (mh-add-msgs-to-seq (car sorted-list) 'subject nil)
- (setq sorted-list (cdr sorted-list)))
- (safe-length list)))
- (t
- 0))))))
-
-(defun mh-subject-to-sequence-threaded (all)
- "Put all messages with the same subject in the 'subject sequence.
-
-This function works when the folder is threaded. In this
-situation the subject could get truncated and so the normal
-matching doesn't work.
-
-The parameter ALL is non-nil then all the messages in the buffer
-are considered, otherwise only the messages after the current one
-are taken into account."
- (let* ((cur (mh-get-msg-num nil))
- (subject (mh-thread-find-msg-subject cur))
- region msgs)
- (if (null subject)
- (and (message "No subject line") nil)
- (setq region (cons (if all (point-min) (point)) (point-max)))
- (mh-iterate-on-range msg region
- (when (eq (mh-thread-find-msg-subject msg) subject)
- (push msg msgs)))
- (setq msgs (sort msgs #'mh-lessp))
- (if (null msgs)
- 0
- (when (assoc 'subject mh-seq-list)
- (mh-delete-seq 'subject))
- (mh-add-msgs-to-seq msgs 'subject)
- (length msgs)))))
-
-(defun mh-thread-find-msg-subject (msg)
- "Find canonicalized subject of MSG.
-This function can only be used the folder is threaded."
- (ignore-errors
- (mh-message-subject
- (mh-container-message (gethash (gethash msg mh-thread-index-id-map)
- mh-thread-id-table)))))
-
-(defun mh-edit-pick-expr (default)
- "With prefix arg edit a pick expression.
-If no prefix arg is given, then return DEFAULT."
- (let ((default-string (loop for x in default concat (format " %s" x))))
- (if (or current-prefix-arg (equal default-string ""))
- (mh-pick-args-list (read-string "Pick expression: "
- default-string))
- default)))
-
-(defun mh-pick-args-list (s)
- "Form list by grouping elements in string S suitable for pick arguments.
-For example, the string \"-subject a b c -from Joe User
-<user@domain.com>\" is converted to (\"-subject\" \"a b c\"
-\"-from\" \"Joe User <user@domain.com>\""
- (let ((full-list (split-string s))
- current-arg collection arg-list)
- (while full-list
- (setq current-arg (car full-list))
- (if (null (string-match "^-" current-arg))
- (setq collection
- (if (null collection)
- current-arg
- (format "%s %s" collection current-arg)))
- (when collection
- (setq arg-list (append arg-list (list collection)))
- (setq collection nil))
- (setq arg-list (append arg-list (list current-arg))))
- (setq full-list (cdr full-list)))
- (when collection
- (setq arg-list (append arg-list (list collection))))
- arg-list))
-
-;;;###mh-autoload
-(defun mh-narrow-to-subject (&optional pick-expr)
- "Limit to messages with same subject.
-With a prefix argument, edit PICK-EXPR.
-
-Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
- (interactive
- (list (mh-edit-pick-expr (mh-current-message-header-field 'subject))))
- (mh-narrow-to-header-field 'subject pick-expr))
-
-;;;###mh-autoload
-(defun mh-narrow-to-from (&optional pick-expr)
- "Limit to messages with the same \"From:\" field.
-With a prefix argument, edit PICK-EXPR.
-
-Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
- (interactive
- (list (mh-edit-pick-expr (mh-current-message-header-field 'from))))
- (mh-narrow-to-header-field 'from pick-expr))
-
-;;;###mh-autoload
-(defun mh-narrow-to-cc (&optional pick-expr)
- "Limit to messages with the same \"Cc:\" field.
-With a prefix argument, edit PICK-EXPR.
-
-Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
- (interactive
- (list (mh-edit-pick-expr (mh-current-message-header-field 'cc))))
- (mh-narrow-to-header-field 'cc pick-expr))
-
-;;;###mh-autoload
-(defun mh-narrow-to-to (&optional pick-expr)
- "Limit to messages with the same \"To:\" field.
-With a prefix argument, edit PICK-EXPR.
-
-Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
- (interactive
- (list (mh-edit-pick-expr (mh-current-message-header-field 'to))))
- (mh-narrow-to-header-field 'to pick-expr))
-
-(defun mh-narrow-to-header-field (header-field pick-expr)
- "Limit to messages whose HEADER-FIELD match PICK-EXPR.
-The MH command pick is used to do the match."
- (let ((folder mh-current-folder)
- (original (mh-coalesce-msg-list
- (mh-range-to-msg-list (cons (point-min) (point-max)))))
- (msg-list ()))
- (with-temp-buffer
- (apply #'mh-exec-cmd-output "pick" nil folder
- (append original (list "-list") pick-expr))
- (goto-char (point-min))
- (while (not (eobp))
- (let ((num (read-from-string
- (buffer-substring (point) (line-end-position)))))
- (when (numberp (car num)) (push (car num) msg-list))
- (forward-line))))
- (if (null msg-list)
- (message "No matches")
- (when (assoc 'header mh-seq-list) (mh-delete-seq 'header))
- (mh-add-msgs-to-seq msg-list 'header)
- (mh-narrow-to-seq 'header))))
-
-(defun mh-current-message-header-field (header-field)
- "Return a pick regexp to match HEADER-FIELD of the message at point."
- (let ((num (mh-get-msg-num nil)))
- (when num
- (let ((folder mh-current-folder))
- (with-temp-buffer
- (insert-file-contents-literally (mh-msg-filename num folder))
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (narrow-to-region (point-min) (point)))
- (let* ((field (or (message-fetch-field (format "%s" header-field))
- ""))
- (field-option (format "-%s" header-field))
- (patterns (loop for x in (split-string field "[ ]*,[ ]*")
- unless (equal x "")
- collect (if (string-match "<\\(.*@.*\\)>" x)
- (match-string 1 x)
- x))))
- (when patterns
- (loop with accum = `(,field-option ,(car patterns))
- for e in (cdr patterns)
- do (setq accum `(,field-option ,e "-or" ,@accum))
- finally return accum))))))))
-
-;;;###mh-autoload
-(defun mh-narrow-to-range (range)
- "Limit to RANGE.
-
-Check the documentation of `mh-interactive-range' to see how
-RANGE is read in interactive use.
-
-Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
- (interactive (list (mh-interactive-range "Narrow to")))
- (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))
- (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)
- (mh-narrow-to-seq 'range))
-
-
-;;;###mh-autoload
-(defun mh-delete-subject ()
- "Delete messages with same subject\\<mh-folder-mode-map>.
-
-To delete messages faster, you can use this command to delete all
-the messages with the same subject as the current message. This
-command puts these messages in a sequence named \"subject\". You
-can undo this action by using \\[mh-undo] with a prefix argument
-and then specifying the \"subject\" sequence."
- (interactive)
- (let ((count (mh-subject-to-sequence nil)))
- (cond
- ((not count) ; No subject line, delete msg anyway
- (mh-delete-msg (mh-get-msg-num t)))
- ((= 0 count) ; No other msgs, delete msg anyway.
- (message "No other messages with same Subject following this one")
- (mh-delete-msg (mh-get-msg-num t)))
- (t ; We have a subject sequence.
- (message "Marked %d messages for deletion" count)
- (mh-delete-msg 'subject)))))
-
-;;;###mh-autoload
-(defun mh-delete-subject-or-thread ()
- "Delete messages with same subject or thread\\<mh-folder-mode-map>.
-
-To delete messages faster, you can use this command to delete all
-the messages with the same subject as the current message. This
-command puts these messages in a sequence named \"subject\". You
-can undo this action by using \\[mh-undo] with a prefix argument
-and then specifying the \"subject\" sequence.
-
-However, if the buffer is displaying a threaded view of the
-folder then this command behaves like \\[mh-thread-delete]."
- (interactive)
- (if (memq 'unthread mh-view-ops)
- (mh-thread-delete)
- (mh-delete-subject)))
-
-\f
-
-;;; Message threading:
-
-(defmacro mh-thread-initialize-hash (var test)
- "Initialize the hash table in VAR.
-TEST is the test to use when creating a new hash table."
- (unless (symbolp var) (error "Expected a symbol: %s" var))
- `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test))))
-
-(defun mh-thread-initialize ()
- "Make new hash tables, or clear them if already present."
- (mh-thread-initialize-hash mh-thread-id-hash #'equal)
- (mh-thread-initialize-hash mh-thread-subject-hash #'equal)
- (mh-thread-initialize-hash mh-thread-id-table #'eq)
- (mh-thread-initialize-hash mh-thread-id-index-map #'eq)
- (mh-thread-initialize-hash mh-thread-index-id-map #'eql)
- (mh-thread-initialize-hash mh-thread-scan-line-map #'eql)
- (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq)
- (mh-thread-initialize-hash mh-thread-duplicates #'eq)
- (setq mh-thread-history ()))
-
-(defsubst mh-thread-id-container (id)
- "Given ID, return the corresponding container in `mh-thread-id-table'.
-If no container exists then a suitable container is created and
-the id-table is updated."
- (when (not id)
- (error "1"))
- (or (gethash id mh-thread-id-table)
- (setf (gethash id mh-thread-id-table)
- (let ((message (mh-thread-make-message :id id)))
- (mh-thread-make-container :message message)))))
-
-(defsubst mh-thread-remove-parent-link (child)
- "Remove parent link of CHILD if it exists."
- (let* ((child-container (if (mh-thread-container-p child)
- child (mh-thread-id-container child)))
- (parent-container (mh-container-parent child-container)))
- (when parent-container
- (setf (mh-container-children parent-container)
- (loop for elem in (mh-container-children parent-container)
- unless (eq child-container elem) collect elem))
- (setf (mh-container-parent child-container) nil))))
-
-(defsubst mh-thread-add-link (parent child &optional at-end-p)
- "Add links so that PARENT becomes a parent of CHILD.
-Doesn't make any changes if CHILD is already an ancestor of
-PARENT. If optional argument AT-END-P is non-nil, the CHILD is
-added to the end of the children list of PARENT."
- (let ((parent-container (cond ((null parent) nil)
- ((mh-thread-container-p parent) parent)
- (t (mh-thread-id-container parent))))
- (child-container (if (mh-thread-container-p child)
- child (mh-thread-id-container child))))
- (when (and parent-container
- (not (mh-thread-ancestor-p child-container parent-container))
- (not (mh-thread-ancestor-p parent-container child-container)))
- (mh-thread-remove-parent-link child-container)
- (cond ((not at-end-p)
- (push child-container (mh-container-children parent-container)))
- ((null (mh-container-children parent-container))
- (push child-container (mh-container-children parent-container)))
- (t (let ((last-child (mh-container-children parent-container)))
- (while (cdr last-child)
- (setq last-child (cdr last-child)))
- (setcdr last-child (cons child-container nil)))))
- (setf (mh-container-parent child-container) parent-container))
- (unless parent-container
- (mh-thread-remove-parent-link child-container))))
-
-(defun mh-thread-ancestor-p (ancestor successor)
- "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise.
-In the limit, the function returns t if ANCESTOR and SUCCESSOR
-are the same containers."
- (block nil
- (while successor
- (when (eq ancestor successor) (return t))
- (setq successor (mh-container-parent successor)))
- nil))
-
-(defsubst mh-thread-get-message-container (message)
- "Return container which has MESSAGE in it.
-If there is no container present then a new container is
-allocated."
- (let* ((id (mh-message-id message))
- (container (gethash id mh-thread-id-table)))
- (cond (container (setf (mh-container-message container) message)
- container)
- (t (setf (gethash id mh-thread-id-table)
- (mh-thread-make-container :message message))))))
-
-(defsubst mh-thread-get-message (id subject-re-p subject refs)
- "Return appropriate message.
-Otherwise update message already present to have the proper ID,
-SUBJECT-RE-P, SUBJECT and REFS fields."
- (let* ((container (gethash id mh-thread-id-table))
- (message (if container (mh-container-message container) nil)))
- (cond (message
- (setf (mh-message-subject-re-p message) subject-re-p)
- (setf (mh-message-subject message) subject)
- (setf (mh-message-id message) id)
- (setf (mh-message-references message) refs)
- message)
- (container
- (setf (mh-container-message container)
- (mh-thread-make-message :id id :references refs
- :subject subject
- :subject-re-p subject-re-p)))
- (t (let ((message (mh-thread-make-message :id id :references refs
- :subject-re-p subject-re-p
- :subject subject)))
- (prog1 message
- (mh-thread-get-message-container message)))))))
-
-(defsubst mh-thread-canonicalize-id (id)
- "Produce canonical string representation for ID.
-This allows cheap string comparison with EQ."
- (or (and (equal id "") (copy-sequence ""))
- (gethash id mh-thread-id-hash)
- (setf (gethash id mh-thread-id-hash) id)))
-
-(defsubst mh-thread-prune-subject (subject)
- "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT.
-If the result after pruning is not the empty string then it is
-canonicalized so that subjects can be tested for equality with
-eq. This is done so that all the messages without a subject are
-not put into a single thread."
- (let ((case-fold-search t)
- (subject-pruned-flag nil))
- ;; Prune subject leader
- (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*"
- subject)
- (string-match "^[ \t]*\\[[^\\]][ \t]*" subject))
- (setq subject-pruned-flag t)
- (setq subject (substring subject (match-end 0))))
- ;; Prune subject trailer
- (while (or (string-match "(fwd)$" subject)
- (string-match "[ \t]+$" subject))
- (setq subject-pruned-flag t)
- (setq subject (substring subject 0 (match-beginning 0))))
- ;; Canonicalize subject only if it is non-empty
- (cond ((equal subject "") (values subject subject-pruned-flag))
- (t (values
- (or (gethash subject mh-thread-subject-hash)
- (setf (gethash subject mh-thread-subject-hash) subject))
- subject-pruned-flag)))))
-
-(defun mh-thread-container-subject (container)
- "Return the subject of CONTAINER.
-If CONTAINER is empty return the subject info of one of its
-children."
- (cond ((and (mh-container-message container)
- (mh-message-id (mh-container-message container)))
- (mh-message-subject (mh-container-message container)))
- (t (block nil
- (dolist (kid (mh-container-children container))
- (when (and (mh-container-message kid)
- (mh-message-id (mh-container-message kid)))
- (let ((kid-message (mh-container-message kid)))
- (return (mh-message-subject kid-message)))))
- (error "This can't happen!")))))
-
-(defun mh-thread-rewind-pruning ()
- "Restore the thread tree to its state before pruning."
- (while mh-thread-history
- (let ((action (pop mh-thread-history)))
- (cond ((eq (car action) 'DROP)
- (mh-thread-remove-parent-link (cadr action))
- (mh-thread-add-link (caddr action) (cadr action)))
- ((eq (car action) 'PROMOTE)
- (let ((node (cadr action))
- (parent (caddr action))
- (children (cdddr action)))
- (dolist (child children)
- (mh-thread-remove-parent-link child)
- (mh-thread-add-link node child))
- (mh-thread-add-link parent node)))
- ((eq (car action) 'SUBJECT)
- (let ((node (cadr action)))
- (mh-thread-remove-parent-link node)
- (setf (mh-container-real-child-p node) t)))))))
-
-(defun mh-thread-prune-containers (roots)
- "Prune empty containers in the containers ROOTS."
- (let ((dfs-ordered-nodes ())
- (work-list roots))
- (while work-list
- (let ((node (pop work-list)))
- (dolist (child (mh-container-children node))
- (push child work-list))
- (push node dfs-ordered-nodes)))
- (while dfs-ordered-nodes
- (let ((node (pop dfs-ordered-nodes)))
- (cond ((gethash (mh-message-id (mh-container-message node))
- mh-thread-id-index-map)
- ;; Keep it
- (setf (mh-container-children node)
- (mh-thread-sort-containers (mh-container-children node))))
- ((and (mh-container-children node)
- (or (null (cdr (mh-container-children node)))
- (mh-container-parent node)))
- ;; Promote kids
- (let ((children ()))
- (dolist (kid (mh-container-children node))
- (mh-thread-remove-parent-link kid)
- (mh-thread-add-link (mh-container-parent node) kid)
- (push kid children))
- (push `(PROMOTE ,node ,(mh-container-parent node) ,@children)
- mh-thread-history)
- (mh-thread-remove-parent-link node)))
- ((mh-container-children node)
- ;; Promote the first orphan to parent and add the other kids as
- ;; his children
- (setf (mh-container-children node)
- (mh-thread-sort-containers (mh-container-children node)))
- (let ((new-parent (car (mh-container-children node)))
- (other-kids (cdr (mh-container-children node))))
- (mh-thread-remove-parent-link new-parent)
- (dolist (kid other-kids)
- (mh-thread-remove-parent-link kid)
- (setf (mh-container-real-child-p kid) nil)
- (mh-thread-add-link new-parent kid t))
- (push `(PROMOTE ,node ,(mh-container-parent node)
- ,new-parent ,@other-kids)
- mh-thread-history)
- (mh-thread-remove-parent-link node)))
- (t
- ;; Drop it
- (push `(DROP ,node ,(mh-container-parent node))
- mh-thread-history)
- (mh-thread-remove-parent-link node)))))
- (let ((results ()))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (when (and (null (mh-container-parent v))
- (gethash (mh-message-id (mh-container-message v))
- mh-thread-id-index-map))
- (push v results)))
- mh-thread-id-table)
- (mh-thread-sort-containers results))))
-
-(defun mh-thread-sort-containers (containers)
- "Sort a list of message CONTAINERS to be in ascending order wrt index."
- (sort containers
- #'(lambda (x y)
- (when (and (mh-container-message x) (mh-container-message y))
- (let* ((id-x (mh-message-id (mh-container-message x)))
- (id-y (mh-message-id (mh-container-message y)))
- (index-x (gethash id-x mh-thread-id-index-map))
- (index-y (gethash id-y mh-thread-id-index-map)))
- (and (integerp index-x) (integerp index-y)
- (< index-x index-y)))))))
-
-(defsubst mh-thread-group-by-subject (roots)
- "Group the set of message containers, ROOTS based on subject.
-Bug: Check for and make sure that something without Re: is made
-the parent in preference to something that has it."
- (clrhash mh-thread-subject-container-hash)
- (let ((results ()))
- (dolist (root roots)
- (let* ((subject (mh-thread-container-subject root))
- (parent (gethash subject mh-thread-subject-container-hash)))
- (cond (parent (mh-thread-remove-parent-link root)
- (mh-thread-add-link parent root t)
- (setf (mh-container-real-child-p root) nil)
- (push `(SUBJECT ,root) mh-thread-history))
- (t
- (setf (gethash subject mh-thread-subject-container-hash) root)
- (push root results)))))
- (nreverse results)))
-
-(defun mh-thread-process-in-reply-to (reply-to-header)
- "Extract message id's from REPLY-TO-HEADER.
-Ideally this should have some regexp which will try to guess if a
-string between < and > is a message id and not an email address.
-For now it will take the last string inside angles."
- (let ((end (mh-search-from-end ?> reply-to-header)))
- (when (numberp end)
- (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end))))
- (when (numberp begin)
- (list (substring reply-to-header begin (1+ end))))))))
-
-(defun mh-thread-set-tables (folder)
- "Use the tables of FOLDER in current buffer."
- (flet ((mh-get-table (symbol)
- (save-excursion
- (set-buffer folder)
- (symbol-value symbol))))
- (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash))
- (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash))
- (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table))
- (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map))
- (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map))
- (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map))
- (setq mh-thread-subject-container-hash
- (mh-get-table 'mh-thread-subject-container-hash))
- (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates))
- (setq mh-thread-history (mh-get-table 'mh-thread-history))))
-
-(defsubst mh-thread-update-id-index-maps (id index)
- "Message with id, ID is the message in INDEX.
-The function also checks for duplicate messages (that is multiple
-messages with the same ID). These messages are put in the
-`mh-thread-duplicates' hash table."
- (let ((old-index (gethash id mh-thread-id-index-map)))
- (when old-index (push old-index (gethash id mh-thread-duplicates)))
- (setf (gethash id mh-thread-id-index-map) index)
- (setf (gethash index mh-thread-index-id-map) id)))
-
-\f
-
-;;; Generate Threads...
-
-(defvar mh-message-id-regexp "^<.*@.*>$"
- "Regexp to recognize whether a string is a message identifier.")
-
-(defun mh-thread-generate (folder msg-list)
- "Scan FOLDER to get info for threading.
-Only information about messages in MSG-LIST are added to the tree."
- (with-temp-buffer
- (mh-thread-set-tables folder)
- (when msg-list
- (apply
- #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
- "-width" "10000" "-format"
- "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n"
- folder (mapcar #'(lambda (x) (format "%s" x)) msg-list)))
- (goto-char (point-min))
- (let ((roots ())
- (case-fold-search t))
- (block nil
- (while (not (eobp))
- (block process-message
- (let* ((index-line
- (prog1 (buffer-substring (point) (line-end-position))
- (forward-line)))
- (index (car (read-from-string index-line)))
- (id (prog1 (buffer-substring (point) (line-end-position))
- (forward-line)))
- (refs (prog1 (buffer-substring (point) (line-end-position))
- (forward-line)))
- (in-reply-to (prog1 (buffer-substring (point)
- (line-end-position))
- (forward-line)))
- (subject (prog1
- (buffer-substring (point) (line-end-position))
- (forward-line)))
- (subject-re-p nil))
- (unless (gethash index mh-thread-scan-line-map)
- (return-from process-message))
- (unless (integerp index) (return)) ;Error message here
- (multiple-value-setq (subject subject-re-p)
- (mh-thread-prune-subject subject))
- (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to))
- (setq refs (loop for x in (append (split-string refs) in-reply-to)
- when (string-match mh-message-id-regexp x)
- collect x))
- (setq id (mh-thread-canonicalize-id id))
- (mh-thread-update-id-index-maps id index)
- (setq refs (mapcar #'mh-thread-canonicalize-id refs))
- (mh-thread-get-message id subject-re-p subject refs)
- (do ((ancestors refs (cdr ancestors)))
- ((null (cdr ancestors))
- (when (car ancestors)
- (mh-thread-remove-parent-link id)
- (mh-thread-add-link (car ancestors) id)))
- (mh-thread-add-link (car ancestors) (cadr ancestors)))))))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (when (null (mh-container-parent v))
- (push v roots)))
- mh-thread-id-table)
- (setq roots (mh-thread-prune-containers roots))
- (prog1 (setq roots (mh-thread-group-by-subject roots))
- (let ((history mh-thread-history))
- (set-buffer folder)
- (setq mh-thread-history history))))))
-
-;;;###mh-autoload
-(defun mh-thread-inc (folder start-point)
- "Update thread tree for FOLDER.
-All messages after START-POINT are added to the thread tree."
- (mh-thread-rewind-pruning)
- (mh-remove-all-notation)
- (goto-char start-point)
- (let ((msg-list ()))
- (while (not (eobp))
- (let ((index (mh-get-msg-num nil)))
- (when (numberp index)
- (push index msg-list)
- (setf (gethash index mh-thread-scan-line-map)
- (mh-thread-parse-scan-line)))
- (forward-line)))
- (let ((thread-tree (mh-thread-generate folder msg-list))
- (buffer-read-only nil)
- (old-buffer-modified-flag (buffer-modified-p)))
- (delete-region (point-min) (point-max))
- (mh-thread-print-scan-lines thread-tree)
- (mh-notate-user-sequences)
- (mh-notate-deleted-and-refiled)
- (mh-notate-cur)
- (set-buffer-modified-p old-buffer-modified-flag))))
-
-(defun mh-thread-generate-scan-lines (tree level)
- "Generate scan lines.
-TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps
-message indices to the corresponding scan lines and LEVEL used to
-determine indentation of the message."
- (cond ((null tree) nil)
- ((mh-thread-container-p tree)
- (let* ((message (mh-container-message tree))
- (id (mh-message-id message))
- (index (gethash id mh-thread-id-index-map))
- (duplicates (gethash id mh-thread-duplicates))
- (new-level (+ level 2))
- (dupl-flag t)
- (force-angle-flag nil)
- (increment-level-flag nil))
- (dolist (scan-line (mapcar (lambda (x)
- (gethash x mh-thread-scan-line-map))
- (reverse (cons index duplicates))))
- (when scan-line
- (when (and dupl-flag (equal level 0)
- (mh-thread-ancestor-p mh-thread-last-ancestor tree))
- (setq level (+ level 2)
- new-level (+ new-level 2)
- force-angle-flag t))
- (when (equal level 0)
- (setq mh-thread-last-ancestor tree)
- (while (mh-container-parent mh-thread-last-ancestor)
- (setq mh-thread-last-ancestor
- (mh-container-parent mh-thread-last-ancestor))))
- (let* ((lev (if dupl-flag level new-level))
- (square-flag (or (and (mh-container-real-child-p tree)
- (not force-angle-flag)
- dupl-flag)
- (equal lev 0))))
- (insert (car scan-line)
- (format (format "%%%ss" lev) "")
- (if square-flag "[" "<")
- (cadr scan-line)
- (if square-flag "]" ">")
- (truncate-string-to-width
- (caddr scan-line) (- mh-thread-body-width lev))
- "\n"))
- (setq increment-level-flag t)
- (setq dupl-flag nil)))
- (unless increment-level-flag (setq new-level level))
- (dolist (child (mh-container-children tree))
- (mh-thread-generate-scan-lines child new-level))))
- (t (let ((nlevel (+ level 2)))
- (dolist (ch tree)
- (mh-thread-generate-scan-lines ch nlevel))))))
-
-;; Another and may be better approach would be to generate all the info from
-;; the scan which generates the threading info. For now this will have to do.
-(defun mh-thread-parse-scan-line (&optional string)
- "Parse a scan line.
-If optional argument STRING is given then that is assumed to be
-the scan line. Otherwise uses the line at point as the scan line
-to parse."
- (let* ((string (or string
- (buffer-substring-no-properties (line-beginning-position)
- (line-end-position))))
- (address-start (+ mh-cmd-note mh-scan-field-from-start-offset))
- (body-start (+ mh-cmd-note mh-scan-field-from-end-offset))
- (first-string (substring string 0 address-start)))
- (list first-string
- (substring string address-start (- body-start 2))
- (substring string body-start)
- string)))
-
-;;;###mh-autoload
-(defun mh-thread-update-scan-line-map (msg notation offset)
- "In threaded view update `mh-thread-scan-line-map'.
-MSG is the message being notated with NOTATION at OFFSET."
- (let* ((msg (or msg (mh-get-msg-num nil)))
- (cur-scan-line (and mh-thread-scan-line-map
- (gethash msg mh-thread-scan-line-map)))
- (old-scan-lines (loop for map in mh-thread-scan-line-map-stack
- collect (and map (gethash msg map)))))
- (when cur-scan-line
- (setf (aref (car cur-scan-line) offset) notation))
- (dolist (line old-scan-lines)
- (when line (setf (aref (car line) offset) notation)))))
-
-;;;###mh-autoload
-(defun mh-thread-add-spaces (count)
- "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'."
- (let ((spaces (format (format "%%%ss" count) "")))
- (while (not (eobp))
- (let* ((msg-num (mh-get-msg-num nil))
- (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map))))
- (when (numberp msg-num)
- (setf (gethash msg-num mh-thread-scan-line-map)
- (mh-thread-parse-scan-line (format "%s%s" spaces old-line)))))
- (forward-line 1))))
-
-(defun mh-thread-print-scan-lines (thread-tree)
- "Print scan lines in THREAD-TREE in threaded mode."
- (let ((mh-thread-body-width (- (window-width) mh-cmd-note
- (1- mh-scan-field-subject-start-offset)))
- (mh-thread-last-ancestor nil))
- (if (null mh-index-data)
- (mh-thread-generate-scan-lines thread-tree -2)
- (loop for x in (mh-index-group-by-folder)
- do (let* ((old-map mh-thread-scan-line-map)
- (mh-thread-scan-line-map (make-hash-table)))
- (setq mh-thread-last-ancestor nil)
- (loop for msg in (cdr x)
- do (let ((v (gethash msg old-map)))
- (when v
- (setf (gethash msg mh-thread-scan-line-map) v))))
- (when (> (hash-table-count mh-thread-scan-line-map) 0)
- (insert (if (bobp) "" "\n") (car x) "\n")
- (mh-thread-generate-scan-lines thread-tree -2))))
- (mh-index-create-imenu-index))))
-
-(defun mh-thread-folder ()
- "Generate thread view of folder."
- (message "Threading %s..." (buffer-name))
- (mh-thread-initialize)
- (goto-char (point-min))
- (mh-remove-all-notation)
- (let ((msg-list ()))
- (mh-iterate-on-range msg (cons (point-min) (point-max))
- (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line))
- (push msg msg-list))
- (let* ((range (mh-coalesce-msg-list msg-list))
- (thread-tree (mh-thread-generate (buffer-name) range)))
- (delete-region (point-min) (point-max))
- (mh-thread-print-scan-lines thread-tree)
- (mh-notate-user-sequences)
- (mh-notate-deleted-and-refiled)
- (mh-notate-cur)
- (message "Threading %s...done" (buffer-name)))))
-
-;;;###mh-autoload
-(defun mh-toggle-threads ()
- "Toggle threaded view of folder."
- (interactive)
- (let ((msg-at-point (mh-get-msg-num nil))
- (old-buffer-modified-flag (buffer-modified-p))
- (buffer-read-only nil))
- (cond ((memq 'unthread mh-view-ops)
- (unless (mh-valid-view-change-operation-p 'unthread)
- (error "Can't unthread folder"))
- (let ((msg-list ()))
- (goto-char (point-min))
- (while (not (eobp))
- (let ((index (mh-get-msg-num nil)))
- (when index
- (push index msg-list)))
- (forward-line))
- (mh-scan-folder mh-current-folder
- (mapcar #'(lambda (x) (format "%s" x))
- (mh-coalesce-msg-list msg-list))
- t))
- (when mh-index-data
- (mh-index-insert-folder-headers)
- (mh-notate-cur)))
- (t (mh-thread-folder)
- (push 'unthread mh-view-ops)))
- (when msg-at-point (mh-goto-msg msg-at-point t t))
- (set-buffer-modified-p old-buffer-modified-flag)
- (mh-recenter nil)))
-
-;;;###mh-autoload
-(defun mh-thread-forget-message (index)
- "Forget the message INDEX from the threading tables."
- (let* ((id (gethash index mh-thread-index-id-map))
- (id-index (gethash id mh-thread-id-index-map))
- (duplicates (gethash id mh-thread-duplicates)))
- (remhash index mh-thread-index-id-map)
- (remhash index mh-thread-scan-line-map)
- (cond ((and (eql index id-index) (null duplicates))
- (remhash id mh-thread-id-index-map))
- ((eql index id-index)
- (setf (gethash id mh-thread-id-index-map) (car duplicates))
- (setf (gethash (car duplicates) mh-thread-index-id-map) id)
- (setf (gethash id mh-thread-duplicates) (cdr duplicates)))
- (t
- (setf (gethash id mh-thread-duplicates)
- (remove index duplicates))))))
-
-\f
-
-;;; Operations on threads
-
-(defun mh-thread-current-indentation-level ()
- "Find the number of spaces by which current message is indented."
- (save-excursion
- (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
- mh-scan-date-width 1))
- (level 0))