rmailsort.el 7.83 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>
6
;; Maintainer: FSF
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)

Karl Heuer's avatar
Karl Heuer committed
30 31 32
;; For rmail-select-summary
(require 'rmail)

33 34 35
(autoload 'timezone-make-date-sortable "timezone")

;; Sorting messages in Rmail buffer
Richard M. Stallman's avatar
Richard M. Stallman committed
36

37
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
38 39 40 41 42 43 44
(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)
45
			  (rmail-make-date-sortable
Richard M. Stallman's avatar
Richard M. Stallman committed
46 47
			   (rmail-fetch-field msg "Date"))))))

48
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
49 50 51 52 53 54 55 56 57 58
(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:'
59 60 61
			    (if (string-match "^\\(re:[ \t]*\\)*" key)
				(substring key (match-end 0))
			      key))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
62

63
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
64 65 66 67 68 69 70
(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)
71 72 73 74
			  (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
75

76
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
77 78 79 80 81 82 83
(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)
84 85 86 87 88
			  (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
89

90
;;;###autoload
91 92 93 94 95 96 97 98 99 100 101 102 103
(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 ""))
104 105 106 107 108 109 110 111
    (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))

112
;;;###autoload
113
(defun rmail-sort-by-lines (reverse)
114
  "Sort messages of current Rmail file by number of lines.
115 116 117 118 119
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
120 121
			  (count-lines (rmail-msgbeg msg)
				       (rmail-msgend msg))))))
122

123
;;;###autoload
124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
(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
150

151 152 153
;; Basic functions

(defun rmail-sort-messages (reverse keyfun)
Richard M. Stallman's avatar
Richard M. Stallman committed
154
  "Sort messages of current Rmail file.
155 156
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."
157
  (save-current-buffer
158 159 160 161
    ;; 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)
162
	  (point-offset (- (point) (point-min)))
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
	  (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.
196
	(buffer-disable-undo (current-buffer))
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
	(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)
220
	(rmail-show-message current-message)
221
	(goto-char (+ point-offset (point-min)))
222 223 224
	(if (rmail-summary-exists)
	    (rmail-select-summary
	     (rmail-update-summary)))))))
225

Richard M. Stallman's avatar
Richard M. Stallman committed
226
(defun rmail-fetch-field (msg field)
227
  "Return the value of the header FIELD of MSG.
Richard M. Stallman's avatar
Richard M. Stallman committed
228
Arguments are MSG and FIELD."
229 230 231
  (save-restriction
    (widen)
    (let ((next (rmail-msgend msg)))
Richard M. Stallman's avatar
Richard M. Stallman committed
232 233 234 235 236 237 238 239
      (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))))

240 241 242 243 244
(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
245
(provide 'rmailsort)
Eric S. Raymond's avatar
Eric S. Raymond committed
246 247

;;; rmailsort.el ends here