rmailsort.el 7.69 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1 2
;;; rmailsort.el --- Rmail: sort messages.

Karl Heuer's avatar
Karl Heuer committed
3
;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

5
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
Karl Heuer's avatar
Karl Heuer committed
6
;; Version: $Header: /home/gd/gnu/emacs/19.0/lisp/RCS/rmailsort.el,v 1.22 1994/05/03 22:46:37 kwzh Exp kwzh $
Eric S. Raymond's avatar
Eric S. Raymond committed
7
;; Keywords: mail
Eric S. Raymond's avatar
Eric S. Raymond committed
8

Richard M. Stallman's avatar
Richard M. Stallman committed
9 10
;; This file is part of GNU Emacs.

11 12
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
Eric S. Raymond's avatar
Eric S. Raymond committed
13
;; the Free Software Foundation; either version 2, or (at your option)
14 15
;; any later version.

Richard M. Stallman's avatar
Richard M. Stallman committed
16
;; GNU Emacs is distributed in the hope that it will be useful,
17 18 19 20 21
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
Karl Heuer's avatar
Karl Heuer committed
22 23 24
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
25

Eric S. Raymond's avatar
Eric S. Raymond committed
26
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
27 28 29

(require 'sort)

30 31 32
(autoload 'timezone-make-date-sortable "timezone")

;; Sorting messages in Rmail buffer
Richard M. Stallman's avatar
Richard M. Stallman committed
33 34 35 36 37 38 39 40

(defun rmail-sort-by-date (reverse)
  "Sort messages of current Rmail file by date.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
41
			  (rmail-make-date-sortable
Richard M. Stallman's avatar
Richard M. Stallman committed
42 43 44 45 46 47 48 49 50 51 52 53
			   (rmail-fetch-field msg "Date"))))))

(defun rmail-sort-by-subject (reverse)
  "Sort messages of current Rmail file by subject.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (let ((key (or (rmail-fetch-field msg "Subject") ""))
				(case-fold-search t))
			    ;; Remove `Re:'
54 55 56
			    (if (string-match "^\\(re:[ \t]*\\)*" key)
				(substring key (match-end 0))
			      key))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
57 58 59 60 61 62 63 64

(defun rmail-sort-by-author (reverse)
  "Sort messages of current Rmail file by author.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
65 66 67 68
			  (downcase	;Canonical name
			   (mail-strip-quoted-names
			    (or (rmail-fetch-field msg "From")
				(rmail-fetch-field msg "Sender") "")))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
69 70 71 72 73 74 75 76

(defun rmail-sort-by-recipient (reverse)
  "Sort messages of current Rmail file by recipient.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
77 78 79 80 81
			  (downcase	;Canonical name
			   (mail-strip-quoted-names
			    (or (rmail-fetch-field msg "To")
				(rmail-fetch-field msg "Apparently-To") "")
			    ))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
82

83 84 85 86 87 88 89 90 91 92 93 94 95
(defun rmail-sort-by-correspondent (reverse)
  "Sort messages of current Rmail file by other correspondent.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (rmail-select-correspondent
			   msg
			   '("From" "Sender" "To" "Apparently-To"))))))

(defun rmail-select-correspondent (msg fields)
  (let ((ans ""))
96 97 98 99 100 101 102 103 104
    (while (and fields (string= ans ""))
      (setq ans
	    (rmail-dont-reply-to
	     (mail-strip-quoted-names
	      (or (rmail-fetch-field msg (car fields)) ""))))
      (setq fields (cdr fields)))
    ans))

(defun rmail-sort-by-lines (reverse)
105
  "Sort messages of current Rmail file by number of lines.
106 107 108 109 110
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
111 112
			  (count-lines (rmail-msgbeg msg)
				       (rmail-msgend msg))))))
113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139

(defun rmail-sort-by-keywords (reverse labels)
  "Sort messages of current Rmail file by labels.
If prefix argument REVERSE is non-nil, sort them in reverse order.
KEYWORDS is a comma-separated list of labels."
  (interactive "P\nsSort by labels: ")
  (or (string-match "[^ \t]" labels)
      (error "No labels specified"))
  (setq labels (concat (substring labels (match-beginning 0)) ","))
  (let (labelvec)
    (while (string-match "[ \t]*,[ \t]*" labels)
      (setq labelvec (cons 
		      (concat ", ?\\("
			      (substring labels 0 (match-beginning 0))
			      "\\),")
		      labelvec))
      (setq labels (substring labels (match-end 0))))
    (setq labelvec (apply 'vector (nreverse labelvec)))
    (rmail-sort-messages reverse
			 (function
			  (lambda (msg)
			    (let ((n 0))
			      (while (and (< n (length labelvec))
					  (not (rmail-message-labels-p
						msg (aref labelvec n))))
				(setq n (1+ n)))
			      n))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
140

141 142 143
;; Basic functions

(defun rmail-sort-messages (reverse keyfun)
Richard M. Stallman's avatar
Richard M. Stallman committed
144
  "Sort messages of current Rmail file.
145 146
If 1st argument REVERSE is non-nil, sort them in reverse order.
2nd argument KEYFUN is called with a message number, and should return a key."
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
  (save-excursion
    ;; If we are in a summary buffer, operate on the Rmail buffer.
    (if (eq major-mode 'rmail-summary-mode)
	(set-buffer rmail-buffer))
    (let ((buffer-read-only nil)
	  (predicate nil)			;< or string-lessp
	  (sort-lists nil))
      (message "Finding sort keys...")
      (widen)
      (let ((msgnum 1))
	(while (>= rmail-total-messages msgnum)
	  (setq sort-lists
		(cons (list (funcall keyfun msgnum) ;Make sorting key
			    (eq rmail-current-message msgnum) ;True if current
			    (aref rmail-message-vector msgnum)
			    (aref rmail-message-vector (1+ msgnum)))
		      sort-lists))
	  (if (zerop (% msgnum 10))
	      (message "Finding sort keys...%d" msgnum))
	  (setq msgnum (1+ msgnum))))
      (or reverse (setq sort-lists (nreverse sort-lists)))
      ;; Decide predicate: < or string-lessp
      (if (numberp (car (car sort-lists))) ;Is a key numeric?
	  (setq predicate (function <))
	(setq predicate (function string-lessp)))
      (setq sort-lists
	    (sort sort-lists
		  (function
		   (lambda (a b)
		     (funcall predicate (car a) (car b))))))
      (if reverse (setq sort-lists (nreverse sort-lists)))
      ;; Now we enter critical region.  So, keyboard quit is disabled.
      (message "Reordering messages...")
      (let ((inhibit-quit t)		;Inhibit quit
	    (current-message nil)
	    (msgnum 1)
	    (msginfo nil))
	;; There's little hope that we can easily undo after that.
185
	(buffer-disable-undo (current-buffer))
186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
	(goto-char (rmail-msgbeg 1))
	;; To force update of all markers.
	(insert-before-markers ?Z)
	(backward-char 1)
	;; Now reorder messages.
	(while sort-lists
	  (setq msginfo (car sort-lists))
	  ;; Swap two messages.
	  (insert-buffer-substring
	   (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
	  (delete-region  (nth 2 msginfo) (nth 3 msginfo))
	  ;; Is current message?
	  (if (nth 1 msginfo)
	      (setq current-message msgnum))
	  (setq sort-lists (cdr sort-lists))
	  (if (zerop (% msgnum 10))
	      (message "Reordering messages...%d" msgnum))
	  (setq msgnum (1+ msgnum)))
	;; Delete the garbage inserted before.
	(delete-char 1)
	(setq quit-flag nil)
	(buffer-enable-undo)
	(rmail-set-message-counters)
209 210 211 212
	(rmail-show-message current-message)
	(if (rmail-summary-exists)
	    (rmail-select-summary
	     (rmail-update-summary)))))))
213

Richard M. Stallman's avatar
Richard M. Stallman committed
214
(defun rmail-fetch-field (msg field)
215
  "Return the value of the header FIELD of MSG.
Richard M. Stallman's avatar
Richard M. Stallman committed
216
Arguments are MSG and FIELD."
217 218 219
  (save-restriction
    (widen)
    (let ((next (rmail-msgend msg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
220 221 222 223 224 225 226 227
      (goto-char (rmail-msgbeg msg))
      (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
			    (point)
			  (forward-line 1)
			  (point))
			(progn (search-forward "\n\n" nil t) (point)))
      (mail-fetch-field field))))

228 229 230 231 232
(defun rmail-make-date-sortable (date)
  "Make DATE sortable using the function string-lessp."
  ;; Assume the default time zone is GMT.
  (timezone-make-date-sortable date "GMT" "GMT"))

Jim Blandy's avatar
Jim Blandy committed
233
(provide 'rmailsort)
Eric S. Raymond's avatar
Eric S. Raymond committed
234 235

;;; rmailsort.el ends here