home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / vm / vm-group.el < prev    next >
Encoding:
Text File  |  1989-09-11  |  4.1 KB  |  119 lines
  1. ;;; Commands to rearrange (group) message presentation
  2. ;;; Copyright (C) 1989 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. (require 'vm)
  19.  
  20. (defun vm-group-by (group-function)
  21.   (let (start end end-prev mp mp-prev)
  22.     (setq start vm-message-list)
  23.     (while start
  24.       (setq end (cdr start)
  25.         end-prev start
  26.         mp end
  27.         mp-prev start)
  28.       (while mp
  29.     (if (funcall group-function (car start) (car mp))
  30.         (if (eq end mp)
  31.         (setq end-prev end end (cdr end)
  32.               mp-prev mp mp (cdr mp))
  33.           (setcdr mp-prev (cdr mp))
  34.           (setcdr end-prev mp)
  35.           (setcdr mp end)
  36.           (setq end-prev (cdr end-prev)
  37.             mp (cdr mp)))
  38.       (setq mp-prev mp mp (cdr mp))))
  39.       (setq start end))))
  40.  
  41. (defconst vm-group-by-subject-closure (cons t t))
  42.  
  43. (defun vm-group-by-subject (m1 m2)
  44.   (let ((subject (vm-su-subject m1)))
  45.     (if (eq subject (car vm-group-by-subject-closure))
  46.     (setq subject (cdr vm-group-by-subject-closure))
  47.       (setcar vm-group-by-subject-closure subject)
  48.       (if (string-match "^\\(re: *\\)+" subject)
  49.       (setq subject (substring subject (match-end 0))))
  50.       (setq subject (concat "^\\(re: *\\)*"
  51.                 (regexp-quote subject)
  52.                 " *$"))
  53.       (setcdr vm-group-by-subject-closure subject))
  54.     (string-match subject (vm-su-subject m2))))
  55.  
  56. (defun vm-group-by-author (m1 m2)
  57.   (string= (vm-full-name-of m1) (vm-full-name-of m2)))
  58.  
  59. (defun vm-group-by-date-sent (m1 m2)
  60.   (and (string= (vm-monthday-of m1) (vm-monthday-of m2))
  61.        (string= (vm-month-of m1) (vm-month-of m2))
  62.        (string= (vm-year-of m1) (vm-year-of m2))))
  63.  
  64. (defun vm-revert-to-arrival-time-grouping ()
  65.   (let ((curr (car vm-message-pointer))
  66.     (last (car vm-last-message-pointer)))
  67.     (setq vm-message-list
  68.       (sort vm-message-list
  69.         (function
  70.          (lambda (p q) (< (vm-start-of p) (vm-start-of q))))))
  71.     (cond (curr
  72.        (setq vm-message-pointer vm-message-list)
  73.        (while (not (eq (car vm-message-pointer) curr))
  74.          (setq vm-message-pointer (cdr vm-message-pointer)))))
  75.     (cond (last
  76.        (setq vm-last-message-pointer vm-message-list)
  77.        (while (not (eq (car vm-last-message-pointer) last))
  78.          (setq vm-last-message-pointer (cdr vm-last-message-pointer)))))))
  79.  
  80. (defun vm-group-messages (grouping)
  81.   "Group messages by the argument GROUPING.
  82. Interactively this argument is prompted for in the minibuffer,
  83. with completion."
  84.   (interactive
  85.    (list 
  86.     (completing-read
  87.      (format "Group messages by (default %s): "
  88.          (or vm-group-by "arrival-time"))
  89.      vm-supported-groupings-alist 'identity t)))
  90.   (if vm-mail-buffer
  91.       (set-buffer vm-mail-buffer))
  92.   (if (equal grouping "")
  93.       (setq grouping vm-group-by))
  94.   (cond ((and grouping (not (stringp grouping)))
  95.      (error "Unsupported grouping: %s" grouping))
  96.     ((equal grouping "arrival-time")
  97.      (setq grouping nil)))
  98.   (if grouping
  99.       (let ((group-function (intern (concat "vm-group-by-" grouping))))
  100.     (if (not (fboundp group-function))
  101.         (error "Unsupported grouping: %s" grouping))
  102.     (vm-revert-to-arrival-time-grouping)
  103.     (message "Grouping messages by %s..." grouping)
  104.     (vm-group-by group-function)
  105.     (message "Grouping messages by %s... done" grouping)
  106.     (setq vm-current-grouping grouping)
  107.     (vm-number-messages))
  108.     (vm-revert-to-arrival-time-grouping)
  109.     (setq vm-current-grouping grouping)
  110.     (vm-number-messages)
  111.     (if (interactive-p)
  112.     (message "Reverted to arrival time grouping")))
  113.   (if vm-summary-buffer
  114.       (vm-do-summary))
  115.   (if vm-message-pointer
  116.       (progn
  117.     (vm-update-summary-and-mode-line)
  118.     (vm-set-summary-pointer (car vm-message-pointer)))))
  119.