Lines Matching +defs:mh +defs:scan
0 ;;; mh-thread.el --- MH-E threading support
8 ;; See: mh-e.el
51 ;; to avoid this? My scan command is as follows:
52 ;; scan +folder -width 10000 \
66 ;; based mh-goto-msg doesn't work. I have a simpler replacement
76 (require 'mh-e)
77 (require 'mh-scan)
79 (mh-defstruct (mh-thread-message (:conc-name mh-message-)
80 (:constructor mh-thread-make-message))
86 (mh-defstruct (mh-thread-container (:conc-name mh-container-)
87 (:constructor mh-thread-make-container))
91 (defvar mh-thread-id-hash nil
93 (make-variable-buffer-local 'mh-thread-id-hash)
95 (defvar mh-thread-subject-hash nil
97 (make-variable-buffer-local 'mh-thread-subject-hash)
99 (defvar mh-thread-id-table nil
101 (make-variable-buffer-local 'mh-thread-id-table)
103 (defvar mh-thread-index-id-map nil
105 (make-variable-buffer-local 'mh-thread-index-id-map)
107 (defvar mh-thread-id-index-map nil
109 (make-variable-buffer-local 'mh-thread-id-index-map)
111 (defvar mh-thread-subject-container-hash nil
113 (make-variable-buffer-local 'mh-thread-subject-container-hash)
115 (defvar mh-thread-duplicates nil
117 (make-variable-buffer-local 'mh-thread-duplicates)
119 (defvar mh-thread-history ()
125 (make-variable-buffer-local 'mh-thread-history)
127 (defvar mh-thread-body-width nil
128 "Width of scan substring that contains subject and body of message.")
135 ;;;###mh-autoload
136 (defun mh-thread-ancestor (&optional thread-root-flag)
145 (cond ((not (memq 'unthread mh-view-ops))
149 (let ((current-level (mh-thread-current-indentation-level)))
151 (while (mh-thread-immediate-ancestor))
152 (mh-maybe-show))
155 (t (mh-thread-immediate-ancestor)
156 (mh-maybe-show)))))
158 ;;;###mh-autoload
159 (defun mh-thread-delete ()
162 (cond ((not (memq 'unthread mh-view-ops))
166 (t (let ((region (mh-thread-find-children)))
167 (mh-iterate-on-messages-in-region () (car region) (cadr region)
168 (mh-delete-a-msg nil))
169 (mh-next-msg)))))
171 ;;;###mh-autoload
172 (defun mh-thread-next-sibling (&optional previous-flag)
178 (cond ((not (memq 'unthread mh-view-ops))
185 (my-level (mh-thread-current-indentation-level)))
189 (let ((level (mh-thread-current-indentation-level)))
195 (cond ((eq done 'success) (mh-maybe-show))
200 ;;;###mh-autoload
201 (defun mh-thread-previous-sibling ()
204 (mh-thread-next-sibling t))
206 ;;;###mh-autoload
207 (defun mh-thread-refile (folder)
209 (interactive (list (intern (mh-prompt-for-refile-folder))))
210 (cond ((not (memq 'unthread mh-view-ops))
214 (t (let ((region (mh-thread-find-children)))
215 (mh-iterate-on-messages-in-region () (car region) (cadr region)
216 (mh-refile-a-msg nil folder))
217 (mh-next-msg)))))
219 ;;;###mh-autoload
220 (defun mh-toggle-threads ()
223 (let ((msg-at-point (mh-get-msg-num nil))
226 (cond ((memq 'unthread mh-view-ops)
227 (unless (mh-valid-view-change-operation-p 'unthread)
232 (let ((index (mh-get-msg-num nil)))
236 (mh-scan-folder mh-current-folder
238 (mh-coalesce-msg-list msg-list))
240 (when mh-index-data
241 (mh-index-insert-folder-headers)
242 (mh-notate-cur)))
243 (t (mh-thread-folder)
244 (push 'unthread mh-view-ops)))
245 (when msg-at-point (mh-goto-msg msg-at-point t t))
247 (mh-recenter nil)))
254 (defun mh-thread-current-indentation-level ()
257 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
258 mh-scan-date-width 1))
267 (defun mh-thread-immediate-ancestor ()
271 (ancestor-level (- (mh-thread-current-indentation-level) 2))
276 (when (equal ancestor-level (mh-thread-current-indentation-level))
282 (defun mh-thread-find-children ()
290 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
291 mh-scan-date-width 1))
292 (level (mh-thread-current-indentation-level))
301 (point) (mh-line-end-position)))
314 (defun mh-thread-folder ()
317 (mh-thread-initialize)
319 (mh-remove-all-notation)
321 (mh-iterate-on-range msg (cons (point-min) (point-max))
322 (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line))
324 (let* ((range (mh-coalesce-msg-list msg-list))
325 (thread-tree (mh-thread-generate (buffer-name) range)))
327 (mh-thread-print-scan-lines thread-tree)
328 (mh-notate-user-sequences)
329 (mh-notate-deleted-and-refiled)
330 (mh-notate-cur)
333 ;;;###mh-autoload
334 (defun mh-thread-inc (folder start-point)
337 (mh-thread-rewind-pruning)
338 (mh-remove-all-notation)
342 (let ((index (mh-get-msg-num nil)))
345 (setf (gethash index mh-thread-scan-line-map)
346 (mh-thread-parse-scan-line)))
348 (let ((thread-tree (mh-thread-generate folder msg-list))
352 (mh-thread-print-scan-lines thread-tree)
353 (mh-notate-user-sequences)
354 (mh-notate-deleted-and-refiled)
355 (mh-notate-cur)
358 (defmacro mh-thread-initialize-hash (var test)
364 (defun mh-thread-initialize ()
366 (mh-thread-initialize-hash mh-thread-id-hash #'equal)
367 (mh-thread-initialize-hash mh-thread-subject-hash #'equal)
368 (mh-thread-initialize-hash mh-thread-id-table #'eq)
369 (mh-thread-initialize-hash mh-thread-id-index-map #'eq)
370 (mh-thread-initialize-hash mh-thread-index-id-map #'eql)
371 (mh-thread-initialize-hash mh-thread-scan-line-map #'eql)
372 (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq)
373 (mh-thread-initialize-hash mh-thread-duplicates #'eq)
374 (setq mh-thread-history ()))
376 (defsubst mh-thread-id-container (id)
377 "Given ID, return the corresponding container in `mh-thread-id-table'.
382 (or (gethash id mh-thread-id-table)
383 (setf (gethash id mh-thread-id-table)
384 (let ((message (mh-thread-make-message :id id)))
385 (mh-thread-make-container :message message)))))
387 (defsubst mh-thread-remove-parent-link (child)
389 (let* ((child-container (if (mh-thread-container-p child)
390 child (mh-thread-id-container child)))
391 (parent-container (mh-container-parent child-container)))
393 (setf (mh-container-children parent-container)
394 (loop for elem in (mh-container-children parent-container)
396 (setf (mh-container-parent child-container) nil))))
398 (defsubst mh-thread-add-link (parent child &optional at-end-p)
404 ((mh-thread-container-p parent) parent)
405 (t (mh-thread-id-container parent))))
406 (child-container (if (mh-thread-container-p child)
407 child (mh-thread-id-container child))))
409 (not (mh-thread-ancestor-p child-container parent-container))
410 (not (mh-thread-ancestor-p parent-container child-container)))
411 (mh-thread-remove-parent-link child-container)
413 (push child-container (mh-container-children parent-container)))
414 ((null (mh-container-children parent-container))
415 (push child-container (mh-container-children parent-container)))
416 (t (let ((last-child (mh-container-children parent-container)))
420 (setf (mh-container-parent child-container) parent-container))
422 (mh-thread-remove-parent-link child-container))))
424 (defun mh-thread-rewind-pruning ()
426 (while mh-thread-history
427 (let ((action (pop mh-thread-history)))
429 (mh-thread-remove-parent-link (cadr action))
430 (mh-thread-add-link (caddr action) (cadr action)))
436 (mh-thread-remove-parent-link child)
437 (mh-thread-add-link node child))
438 (mh-thread-add-link parent node)))
441 (mh-thread-remove-parent-link node)
442 (setf (mh-container-real-child-p node) t)))))))
444 (defun mh-thread-ancestor-p (ancestor successor)
451 (setq successor (mh-container-parent successor)))
455 ;; the scan which generates the threading info. For now this will have to do.
456 ;;;###mh-autoload
457 (defun mh-thread-parse-scan-line (&optional string)
458 "Parse a scan line.
460 the scan line. Otherwise uses the line at point as the scan line
463 (mh-line-beginning-position)
464 (mh-line-end-position))))
465 (address-start (+ mh-cmd-note mh-scan-field-from-start-offset))
466 (body-start (+ mh-cmd-note mh-scan-field-from-end-offset))
473 (defsubst mh-thread-canonicalize-id (id)
477 (gethash id mh-thread-id-hash)
478 (setf (gethash id mh-thread-id-hash) id)))
480 (defsubst mh-thread-prune-subject (subject)
502 (or (gethash subject mh-thread-subject-hash)
503 (setf (gethash subject mh-thread-subject-hash) subject))
506 (defsubst mh-thread-group-by-subject (roots)
510 (clrhash mh-thread-subject-container-hash)
513 (let* ((subject (mh-thread-container-subject root))
514 (parent (gethash subject mh-thread-subject-container-hash)))
515 (cond (parent (mh-thread-remove-parent-link root)
516 (mh-thread-add-link parent root t)
517 (setf (mh-container-real-child-p root) nil)
518 (push `(SUBJECT ,root) mh-thread-history))
520 (setf (gethash subject mh-thread-subject-container-hash) root)
524 (defun mh-thread-container-subject (container)
528 (cond ((and (mh-container-message container)
529 (mh-message-id (mh-container-message container)))
530 (mh-message-subject (mh-container-message container)))
532 (dolist (kid (mh-container-children container))
533 (when (and (mh-container-message kid)
534 (mh-message-id (mh-container-message kid)))
535 (let ((kid-message (mh-container-message kid)))
536 (return (mh-message-subject kid-message)))))
539 (defsubst mh-thread-update-id-index-maps (id index)
543 `mh-thread-duplicates' hash table."
544 (let ((old-index (gethash id mh-thread-id-index-map)))
545 (when old-index (push old-index (gethash id mh-thread-duplicates)))
546 (setf (gethash id mh-thread-id-index-map) index)
547 (setf (gethash index mh-thread-index-id-map) id)))
549 (defsubst mh-thread-get-message-container (message)
553 (let* ((id (mh-message-id message))
554 (container (gethash id mh-thread-id-table)))
555 (cond (container (setf (mh-container-message container) message)
557 (t (setf (gethash id mh-thread-id-table)
558 (mh-thread-make-container :message message))))))
560 (defsubst mh-thread-get-message (id subject-re-p subject refs)
564 (let* ((container (gethash id mh-thread-id-table))
565 (message (if container (mh-container-message container) nil)))
567 (setf (mh-message-subject-re-p message) subject-re-p)
568 (setf (mh-message-subject message) subject)
569 (setf (mh-message-id message) id)
570 (setf (mh-message-references message) refs)
573 (setf (mh-container-message container)
574 (mh-thread-make-message :id id :references refs
577 (t (let ((message (mh-thread-make-message :id id :references refs
581 (mh-thread-get-message-container message)))))))
583 (defvar mh-message-id-regexp "^<.*@.*>$"
586 ;;;###mh-autoload
587 (defun mh-thread-generate (folder msg-list)
591 (mh-thread-set-tables folder)
594 #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
605 (prog1 (buffer-substring (point) (mh-line-end-position))
608 (id (prog1 (buffer-substring (point) (mh-line-end-position))
611 (buffer-substring (point) (mh-line-end-position))
614 (mh-line-end-position))
618 (point) (mh-line-end-position))
621 (unless (gethash index mh-thread-scan-line-map)
625 (mh-thread-prune-subject subject))
626 (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to))
628 when (string-match mh-message-id-regexp x)
630 (setq id (mh-thread-canonicalize-id id))
631 (mh-thread-update-id-index-maps id index)
632 (setq refs (mapcar #'mh-thread-canonicalize-id refs))
633 (mh-thread-get-message id subject-re-p subject refs)
637 (mh-thread-remove-parent-link id)
638 (mh-thread-add-link (car ancestors) id)))
639 (mh-thread-add-link (car ancestors) (cadr ancestors)))))))
642 (when (null (mh-container-parent v))
644 mh-thread-id-table)
645 (setq roots (mh-thread-prune-containers roots))
646 (prog1 (setq roots (mh-thread-group-by-subject roots))
647 (let ((history mh-thread-history))
649 (setq mh-thread-history history))))))
651 (defun mh-thread-set-tables (folder)
653 (flet ((mh-get-table (symbol)
657 (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash))
658 (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash))
659 (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table))
660 (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map))
661 (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map))
662 (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map))
663 (setq mh-thread-subject-container-hash
664 (mh-get-table 'mh-thread-subject-container-hash))
665 (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates))
666 (setq mh-thread-history (mh-get-table 'mh-thread-history))))
668 (defun mh-thread-process-in-reply-to (reply-to-header)
673 (let ((end (mh-search-from-end ?> reply-to-header)))
675 (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end))))
679 (defun mh-thread-prune-containers (roots)
685 (dolist (child (mh-container-children node))
690 (cond ((gethash (mh-message-id (mh-container-message node))
691 mh-thread-id-index-map)
693 (setf (mh-container-children node)
694 (mh-thread-sort-containers (mh-container-children node))))
695 ((and (mh-container-children node)
696 (or (null (cdr (mh-container-children node)))
697 (mh-container-parent node)))
700 (dolist (kid (mh-container-children node))
701 (mh-thread-remove-parent-link kid)
702 (mh-thread-add-link (mh-container-parent node) kid)
704 (push `(PROMOTE ,node ,(mh-container-parent node) ,@children)
705 mh-thread-history)
706 (mh-thread-remove-parent-link node)))
707 ((mh-container-children node)
710 (setf (mh-container-children node)
711 (mh-thread-sort-containers (mh-container-children node)))
712 (let ((new-parent (car (mh-container-children node)))
713 (other-kids (cdr (mh-container-children node))))
714 (mh-thread-remove-parent-link new-parent)
716 (mh-thread-remove-parent-link kid)
717 (setf (mh-container-real-child-p kid) nil)
718 (mh-thread-add-link new-parent kid t))
719 (push `(PROMOTE ,node ,(mh-container-parent node)
721 mh-thread-history)
722 (mh-thread-remove-parent-link node)))
725 (push `(DROP ,node ,(mh-container-parent node))
726 mh-thread-history)
727 (mh-thread-remove-parent-link node)))))
731 (when (and (null (mh-container-parent v))
732 (gethash (mh-message-id (mh-container-message v))
733 mh-thread-id-index-map))
735 mh-thread-id-table)
736 (mh-thread-sort-containers results))))
738 (defun mh-thread-sort-containers (containers)
742 (when (and (mh-container-message x) (mh-container-message y))
743 (let* ((id-x (mh-message-id (mh-container-message x)))
744 (id-y (mh-message-id (mh-container-message y)))
745 (index-x (gethash id-x mh-thread-id-index-map))
746 (index-y (gethash id-y mh-thread-id-index-map)))
750 (defvar mh-thread-last-ancestor)
752 ;;;###mh-autoload
753 (defun mh-thread-print-scan-lines (thread-tree)
754 "Print scan lines in THREAD-TREE in threaded mode."
755 (let ((mh-thread-body-width (- (window-width) mh-cmd-note
756 (1- mh-scan-field-subject-start-offset)))
757 (mh-thread-last-ancestor nil))
758 (if (null mh-index-data)
759 (mh-thread-generate-scan-lines thread-tree -2)
760 (loop for x in (mh-index-group-by-folder)
761 do (let* ((old-map mh-thread-scan-line-map)
762 (mh-thread-scan-line-map (make-hash-table)))
763 (setq mh-thread-last-ancestor nil)
767 (setf (gethash msg mh-thread-scan-line-map) v))))
768 (when (> (hash-table-count mh-thread-scan-line-map) 0)
770 (mh-thread-generate-scan-lines thread-tree -2))))
771 (mh-index-create-imenu-index))))
773 (defun mh-thread-generate-scan-lines (tree level)
774 "Generate scan lines.
776 message indices to the corresponding scan lines and LEVEL used to
779 ((mh-thread-container-p tree)
780 (let* ((message (mh-container-message tree))
781 (id (mh-message-id message))
782 (index (gethash id mh-thread-id-index-map))
783 (duplicates (gethash id mh-thread-duplicates))
788 (dolist (scan-line (mapcar (lambda (x)
789 (gethash x mh-thread-scan-line-map))
791 (when scan-line
793 (mh-thread-ancestor-p mh-thread-last-ancestor tree))
798 (setq mh-thread-last-ancestor tree)
799 (while (mh-container-parent mh-thread-last-ancestor)
800 (setq mh-thread-last-ancestor
801 (mh-container-parent mh-thread-last-ancestor))))
803 (square-flag (or (and (mh-container-real-child-p tree)
807 (insert (car scan-line)
810 (cadr scan-line)
813 (caddr scan-line) (- mh-thread-body-width lev))
818 (dolist (child (mh-container-children tree))
819 (mh-thread-generate-scan-lines child new-level))))
822 (mh-thread-generate-scan-lines ch nlevel))))))
829 ;;;###mh-autoload
830 (defun mh-thread-update-scan-line-map (msg notation offset)
831 "In threaded view update `mh-thread-scan-line-map'.
833 (let* ((msg (or msg (mh-get-msg-num nil)))
834 (cur-scan-line (and mh-thread-scan-line-map
835 (gethash msg mh-thread-scan-line-map)))
836 (old-scan-lines (loop for map in mh-thread-scan-line-map-stack
838 (when cur-scan-line
839 (setf (aref (car cur-scan-line) offset) notation))
840 (dolist (line old-scan-lines)
843 ;;;###mh-autoload
844 (defun mh-thread-find-msg-subject (msg)
848 (mh-message-subject
849 (mh-container-message (gethash (gethash msg mh-thread-index-id-map)
850 mh-thread-id-table)))))
852 ;;;###mh-autoload
853 (defun mh-thread-add-spaces (count)
854 "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'."
857 (let* ((msg-num (mh-get-msg-num nil))
858 (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map))))
860 (setf (gethash msg-num mh-thread-scan-line-map)
861 (mh-thread-parse-scan-line (format "%s%s" spaces old-line)))))
864 ;;;###mh-autoload
865 (defun mh-thread-forget-message (index)
867 (let* ((id (gethash index mh-thread-index-id-map))
868 (id-index (gethash id mh-thread-id-index-map))
869 (duplicates (gethash id mh-thread-duplicates)))
870 (remhash index mh-thread-index-id-map)
871 (remhash index mh-thread-scan-line-map)
873 (remhash id mh-thread-id-index-map))
875 (setf (gethash id mh-thread-id-index-map) (car duplicates))
876 (setf (gethash (car duplicates) mh-thread-index-id-map) id)
877 (setf (gethash id mh-thread-duplicates) (cdr duplicates)))
879 (setf (gethash id mh-thread-duplicates)
882 (provide 'mh-thread)
890 ;;; mh-thread.el ends here