home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-thread.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  8.5 KB  |  237 lines
  1. ;;; Thread support for VM
  2. ;;; Copyright (C) 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-thread)
  19.  
  20. (defun vm-toggle-threads-display ()
  21.   "Toggle the threads display on and off.
  22. When the threads display is on, the folder will be sorted by
  23. thread and thread indentation (via the %I summary format specifier)
  24. will be visible."
  25.   (interactive)
  26.   (vm-select-folder-buffer)
  27.   (vm-check-for-killed-summary)
  28.   (vm-set-summary-redo-start-point t)
  29.   (setq vm-summary-show-threads (not vm-summary-show-threads))
  30.   (if vm-summary-show-threads
  31.       (vm-sort-messages "thread")
  32.     (vm-sort-messages "physical-order")))
  33.  
  34. (defun vm-build-threads (message-list)
  35.   (if (null vm-thread-obarray)
  36.       (setq vm-thread-obarray (make-vector 641 0)
  37.         vm-thread-subject-obarray (make-vector 641 0)))
  38.   (let ((mp (or message-list vm-message-list))
  39.     (n 0)
  40.     ;; Just for laughs, make the update interval vary.
  41.     (modulus (+ (% (vm-abs (random)) 11) 40))
  42.     ;; no need to schedule reindents of reparented messages
  43.     ;; unless there were already messages present.
  44.     (schedule-reindents message-list)
  45.     parent parent-sym id id-sym date)
  46.     (while mp
  47.       (setq parent (vm-th-parent (car mp))
  48.         id (vm-su-message-id (car mp))
  49.         id-sym (intern id vm-thread-obarray)
  50.         date (vm-so-sortable-datestring (car mp)))
  51.       (put id-sym 'messages (cons (car mp) (get id-sym 'messages)))
  52.       (if (and (null (cdr (get id-sym 'messages)))
  53.            schedule-reindents)
  54.       (vm-thread-mark-for-summary-update (get id-sym 'children)))
  55.       (if parent
  56.       (progn
  57.         (setq parent-sym (intern parent vm-thread-obarray))
  58.         (if (not (boundp id-sym))
  59.         (set id-sym parent-sym))
  60.         (put parent-sym 'children
  61.          (cons (car mp) (get parent-sym 'children))))
  62.     (set id-sym nil))
  63.       ;; we need to make sure the asets below are an atomic group.
  64.       (if vm-thread-using-subject
  65.       (let* ((inhibit-quit t)
  66.          (subject (vm-so-sortable-subject (car mp)))
  67.          (subject-sym (intern subject vm-thread-subject-obarray)))
  68.         (if (not (boundp subject-sym))
  69.         (set subject-sym
  70.              (vector id-sym (vm-so-sortable-datestring (car mp))
  71.                  nil (list (car mp))))
  72.           (aset (symbol-value subject-sym) 3
  73.             (cons (car mp) (aref (symbol-value subject-sym) 3)))
  74.           (if (string< date (aref (symbol-value subject-sym) 1))
  75.           (let* ((vect (symbol-value subject-sym))
  76.              (i-sym (aref vect 0)))
  77.             (if (or (not (boundp i-sym))
  78.                 (null (symbol-value i-sym)))
  79.             (aset vect 2 (append (get i-sym 'messages)
  80.                          (aref vect 2))))
  81.             (aset vect 0 id-sym)
  82.             (aset vect 1 date)
  83.             ;; this loops _and_ recurses and I'm worried
  84.             ;; about it going into a spin someday.  So I
  85.             ;; unblock interrupts here.  It's not critical
  86.             ;; that it finish... the summary will just be out
  87.             ;; of sync.
  88.             (if schedule-reindents
  89.             (let ((inhibit-quit nil))
  90.               (vm-thread-mark-for-summary-update (aref vect 2)))))
  91.         (if (null parent)
  92.             (aset (symbol-value subject-sym) 2
  93.               (cons (car mp)
  94.                 (aref (symbol-value subject-sym) 2))))))))
  95.       (setq mp (cdr mp) n (1+ n))
  96.       (if (zerop (% n modulus))
  97.       (vm-unsaved-message "Building threads... %d" n)))
  98.     (if (> n modulus)
  99.     (vm-unsaved-message "Building threads... done"))))
  100.  
  101. (defun vm-thread-mark-for-summary-update (message-list)
  102.   (while message-list
  103.     (vm-mark-for-summary-update (car message-list) t)
  104.     (vm-set-thread-list-of (car message-list) nil)
  105.     (vm-set-thread-indentation-of (car message-list) nil)
  106.     (vm-thread-mark-for-summary-update
  107.      (get (intern (vm-su-message-id (car message-list))
  108.           vm-thread-obarray)
  109.       'children))
  110.     (setq message-list (cdr message-list))))
  111.  
  112. (defun vm-thread-list (message)
  113.   (let ((done nil)
  114.     (m message)
  115.     thread-list id-sym subject-sym loop-sym root-date)
  116.     (save-excursion
  117.       (set-buffer (vm-buffer-of m))
  118.       (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
  119.         thread-list (list id-sym))
  120.       (fillarray vm-thread-loop-obarray 0)
  121.       (while (not done)
  122.     (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
  123.     (if (boundp loop-sym)
  124.         ;; loop detected, bail...
  125.         (setq done t
  126.           thread-list (cdr thread-list))
  127.       (set loop-sym t)
  128.       (if (and (boundp id-sym) (symbol-value id-sym))
  129.           (progn
  130.         (setq id-sym (symbol-value id-sym)
  131.               thread-list (cons id-sym thread-list)
  132.               m (car (get id-sym 'messages))))
  133.         (if (null m)
  134.         (setq done t)
  135.           (if (null vm-thread-using-subject)
  136.           nil
  137.         (setq subject-sym
  138.               (intern (vm-so-sortable-subject m)
  139.                   vm-thread-subject-obarray))
  140.         (if (or (not (boundp subject-sym))
  141.             (eq (aref (symbol-value subject-sym) 0) id-sym))
  142.             (setq done t)
  143.           (setq id-sym (aref (symbol-value subject-sym) 0)
  144.             thread-list (cons id-sym thread-list)
  145.             m (car (get id-sym 'messages)))))))))
  146.       ;; save the date of the oldest message in this thread
  147.       (setq root-date (get id-sym 'oldest-date))
  148.       (if (or (null root-date)
  149.           (string< (vm-so-sortable-datestring message) root-date))
  150.       (put id-sym 'oldest-date (vm-so-sortable-datestring message)))
  151.       thread-list )))
  152.  
  153. ;; remove message struct from thread data.
  154. ;;
  155. ;; optional second arg non-nil means forget information that
  156. ;; might be different if the mesage contents changed.
  157. ;;
  158. ;; message must be a real message
  159. (defun vm-unthread-message (message &optional message-changing)
  160.   (save-excursion
  161.     (let ((mp (cons message (vm-virtual-messages-of message)))
  162.       id-sym subject-sym vect p-sym)
  163.       (while mp
  164.     (let ((inhibit-quit t))
  165.       (vm-set-thread-list-of (car mp) nil)
  166.       (vm-set-thread-indentation-of (car mp) nil)
  167.       (set-buffer (vm-buffer-of (car mp)))
  168.       (setq id-sym (intern (vm-su-message-id (car mp)) vm-thread-obarray)
  169.         subject-sym (intern (vm-so-sortable-subject (car mp))
  170.                     vm-thread-subject-obarray))
  171.       (if (boundp id-sym)
  172.           (progn
  173.         (put id-sym 'messages (delq (car mp) (get id-sym 'messages)))
  174.         (vm-thread-mark-for-summary-update (get id-sym 'children))
  175.         (setq p-sym (symbol-value id-sym))
  176.         (and p-sym (put p-sym 'children
  177.                 (delq (car mp) (get p-sym 'children))))
  178.         (if message-changing
  179.             (set id-sym nil))))
  180.       (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
  181.           (if (not (eq id-sym (aref vect 0)))
  182.           (aset vect 2 (delq (car mp) (aref vect 2)))
  183.         (if message-changing
  184.             (if (null (cdr (aref vect 3)))
  185.             (makunbound subject-sym)
  186.               (let ((p (aref vect 3))
  187.                 oldest-msg oldest-date children)
  188.             (setq oldest-msg (car p)
  189.                   oldest-date (vm-so-sortable-datestring (car p))
  190.                   p (cdr p))
  191.             (while p
  192.               (if (and (string-lessp (vm-so-sortable-datestring (car p))
  193.                          oldest-date)
  194.                    (not (eq (car mp) (car p))))
  195.                   (setq oldest-msg (car p)
  196.                     oldest-date (vm-so-sortable-datestring (car p))))
  197.               (setq p (cdr p)))
  198.             (aset vect 0 (intern (vm-su-message-id oldest-msg)
  199.                          vm-thread-obarray))
  200.             (aset vect 1 oldest-date)
  201.             (setq children (delq oldest-msg (aref vect 2)))
  202.             (aset vect 2 children)
  203.             (aset vect 3 (delq (car mp) (aref vect 3)))
  204.             ;; I'm not sure there aren't situations
  205.             ;; where this might loop forever.
  206.             (let ((inhibit-quit nil))
  207.               (vm-thread-mark-for-summary-update children))))))))
  208.       (setq mp (cdr mp))))))
  209.  
  210. (defun vm-th-parent (m)
  211.   (or (vm-parent-of m)
  212.       (vm-set-parent-of
  213.        m
  214.        (or (let (references)
  215.          (setq references (vm-get-header-contents m "References:"))
  216.          (and references
  217.           (car (vm-last
  218.             (vm-parse references "[^<]*\\(<[^>]+>\\)")))))
  219.        (let (in-reply-to)
  220.          (setq in-reply-to (vm-get-header-contents m "In-Reply-To:"))
  221.          (and in-reply-to
  222.           (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
  223.  
  224. (defun vm-th-thread-indentation (m)
  225.   (or (vm-thread-indentation-of m)
  226.       (let ((p (vm-th-thread-list m)))
  227.     (while (and p (null (get (car p) 'messages)))
  228.       (setq p (cdr p)))
  229.     (vm-set-thread-indentation-of m (1- (length p)))
  230.     (vm-thread-indentation-of m))))
  231.  
  232. (defun vm-th-thread-list (m)
  233.   (or (vm-thread-list-of m)
  234.       (progn
  235.     (vm-set-thread-list-of m (vm-thread-list m))
  236.     (vm-thread-list-of m))))
  237.