[bpt/emacs.git] / lisp / mail / rmailsort.el

;;; rmailsort.el --- Rmail: sort messages

;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Maintainer: FSF
;; Keywords: mail

;; This file is part of GNU Emacs.

;; 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
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; 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
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'rmail)

;; Sorting messages in Rmail buffer

;;;###autoload
(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)
			  (rmail-make-date-sortable
			   (rmail-get-header "Date" msg))))))

;;;###autoload
(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-get-header "Subject" msg) ""))
				(case-fold-search t))
			    ;; Remove `Re:'
			    (if (string-match "^\\(re:[ \t]*\\)*" key)
				(substring key (match-end 0))
			      key))))))

;;;###autoload
(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)
			  (downcase	;Canonical name
			   (mail-strip-quoted-names
			    (or (rmail-get-header "From" msg)
				(rmail-get-header "Sender" msg) "")))))))

;;;###autoload
(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)
			  (downcase	;Canonical name
			   (mail-strip-quoted-names
			    (or (rmail-get-header "To" msg)
				(rmail-get-header "Apparently-To" msg) "")
			    ))))))

;;;###autoload
(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 ""))
    (while (and fields (string= ans ""))
      (setq ans
	    ;; NB despite the name, this lives in mail-utils.el.
	    (rmail-dont-reply-to
	     (mail-strip-quoted-names
	      (or (rmail-get-header (car fields) msg) ""))))
      (setq fields (cdr fields)))
    ans))

;;;###autoload
(defun rmail-sort-by-lines (reverse)
  "Sort messages of current Rmail file by number of lines.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (rmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (count-lines (rmail-msgbeg msg)
				       (rmail-msgend msg))))))

;;;###autoload
(defun rmail-sort-by-labels (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))))))
\f
;; Basic functions
(declare-function rmail-update-summary "rmailsum" (&rest ignore))

(defun rmail-sort-messages (reverse keyfun)
  "Sort messages of current Rmail file.
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."
  (with-current-buffer rmail-buffer
    (let ((return-to-point
	   (if (rmail-buffers-swapped-p)
	       (point)))
	  (sort-lists nil))
      (rmail-swap-buffers-maybe)
      (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)))
      (setq sort-lists
	    (sort sort-lists
                  ;; Decide predicate: < or string-lessp
                  (if (numberp (car (car sort-lists))) ;Is a key numeric?
                      'car-less-than-car
                    (function
                     (lambda (a b)
                       (string-lessp (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
	    (inhibit-read-only t)
	    (current-message nil)
	    (msgnum 1)
	    (msginfo nil))
	;; There's little hope that we can easily undo after that.
	(buffer-disable-undo (current-buffer))
	(goto-char (rmail-msgbeg 1))
	;; To force update of all markers,
	;; keep the new copies separated from the remaining old messages.
	(insert-before-markers ?Z)
	(backward-char 1)
	;; Now reorder messages.
	(dolist (msginfo sort-lists)
	  ;; Swap two messages.
	  (insert-buffer-substring
	   (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
	  ;; The last message may not have \n\n after it.
	  (unless (bobp)
	    (insert "\n"))
	  (unless (looking-back "\n\n")
	    (insert "\n"))
	  (delete-region (nth 2 msginfo) (nth 3 msginfo))
	  ;; Is current message?
	  (if (nth 1 msginfo)
	      (setq current-message msgnum))
	  (if (zerop (% msgnum 10))
	      (message "Reordering messages...%d" msgnum))
	  (setq msgnum (1+ msgnum)))
	;; Delete the dummy separator Z inserted before.
	(delete-char 1)
	(setq quit-flag nil)
	(rmail-set-message-counters)
	(rmail-show-message-1 current-message)
	(if return-to-point
	    (goto-char return-to-point))
	(if (rmail-summary-exists)
	    (rmail-select-summary (rmail-update-summary)))))))

(autoload 'timezone-make-date-sortable "timezone")

(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"))

(provide 'rmailsort)

;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
;;; rmailsort.el ends here
Commit	Line	Data
537ab246 BG	1	;;; rmailsort.el --- Rmail: sort messages
	2
	3	;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004,
	4	;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
	5
	6	;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
	7	;; Maintainer: FSF
	8	;; Keywords: mail
	9
	10	;; This file is part of GNU Emacs.
	11
	12	;; GNU Emacs is free software: you can redistribute it and/or modify
	13	;; it under the terms of the GNU General Public License as published by
	14	;; the Free Software Foundation, either version 3 of the License, or
	15	;; (at your option) any later version.
	16
	17	;; GNU Emacs is distributed in the hope that it will be useful,
	18	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;; GNU General Public License for more details.
	21
	22	;; You should have received a copy of the GNU General Public License
	23	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
	24
	25	;;; Commentary:
	26
	27	;;; Code:
	28
efb656fd	29	(require 'rmail)
537ab246 BG	30
	31	;; Sorting messages in Rmail buffer
	32
	33	;;;###autoload
	34	(defun rmail-sort-by-date (reverse)
	35	"Sort messages of current Rmail file by date.
	36	If prefix argument REVERSE is non-nil, sort them in reverse order."
	37	(interactive "P")
	38	(rmail-sort-messages reverse
	39	(function
	40	(lambda (msg)
	41	(rmail-make-date-sortable
	42	(rmail-get-header "Date" msg))))))
	43
	44	;;;###autoload
	45	(defun rmail-sort-by-subject (reverse)
	46	"Sort messages of current Rmail file by subject.
	47	If prefix argument REVERSE is non-nil, sort them in reverse order."
	48	(interactive "P")
	49	(rmail-sort-messages reverse
	50	(function
	51	(lambda (msg)
	52	(let ((key (or (rmail-get-header "Subject" msg) ""))
	53	(case-fold-search t))
	54	;; Remove `Re:'
	55	(if (string-match "^\\(re:[ \t]\\)" key)
	56	(substring key (match-end 0))
	57	key))))))
	58
	59	;;;###autoload
	60	(defun rmail-sort-by-author (reverse)
	61	"Sort messages of current Rmail file by author.
	62	If prefix argument REVERSE is non-nil, sort them in reverse order."
	63	(interactive "P")
	64	(rmail-sort-messages reverse
	65	(function
	66	(lambda (msg)
	67	(downcase ;Canonical name
	68	(mail-strip-quoted-names
	69	(or (rmail-get-header "From" msg)
	70	(rmail-get-header "Sender" msg) "")))))))
	71
	72	;;;###autoload
	73	(defun rmail-sort-by-recipient (reverse)
	74	"Sort messages of current Rmail file by recipient.
	75	If prefix argument REVERSE is non-nil, sort them in reverse order."
	76	(interactive "P")
	77	(rmail-sort-messages reverse
	78	(function
	79	(lambda (msg)
	80	(downcase ;Canonical name
	81	(mail-strip-quoted-names
	82	(or (rmail-get-header "To" msg)
	83	(rmail-get-header "Apparently-To" msg) "")
	84	))))))
	85
	86	;;;###autoload
	87	(defun rmail-sort-by-correspondent (reverse)
	88	"Sort messages of current Rmail file by other correspondent.
	89	If prefix argument REVERSE is non-nil, sort them in reverse order."
	90	(interactive "P")
	91	(rmail-sort-messages reverse
	92	(function
	93	(lambda (msg)
94	(rmail-select-correspondent
95	msg
96	'("From" "Sender" "To" "Apparently-To"))))))
97
98	(defun rmail-select-correspondent (msg fields)
99	(let ((ans ""))
100	(while (and fields (string= ans ""))
101	(setq ans
102	;; NB despite the name, this lives in mail-utils.el.
103	(rmail-dont-reply-to
104	(mail-strip-quoted-names
105	(or (rmail-get-header (car fields) msg) ""))))
106	(setq fields (cdr fields)))
107	ans))
108
109	;;;###autoload
110	(defun rmail-sort-by-lines (reverse)
111	"Sort messages of current Rmail file by number of lines.
112	If prefix argument REVERSE is non-nil, sort them in reverse order."
113	(interactive "P")
114	(rmail-sort-messages reverse
115	(function
116	(lambda (msg)
117	(count-lines (rmail-msgbeg msg)
118	(rmail-msgend msg))))))
119
120	;;;###autoload
121	(defun rmail-sort-by-labels (reverse labels)
122	"Sort messages of current Rmail file by labels.
123	If prefix argument REVERSE is non-nil, sort them in reverse order.
124	KEYWORDS is a comma-separated list of labels."
125	(interactive "P\nsSort by labels: ")
126	(or (string-match "[^ \t]" labels)
127	(error "No labels specified"))
128	(setq labels (concat (substring labels (match-beginning 0)) ","))
129	(let (labelvec)
130	(while (string-match "[ \t],[ \t]" labels)
131	(setq labelvec (cons
132	(concat ", ?\\("
133	(substring labels 0 (match-beginning 0))
134	"\\),")
135	labelvec))
136	(setq labels (substring labels (match-end 0))))
137	(setq labelvec (apply 'vector (nreverse labelvec)))
138	(rmail-sort-messages reverse
139	(function
140	(lambda (msg)
141	(let ((n 0))
142	(while (and (< n (length labelvec))
143	(not (rmail-message-labels-p
144	msg (aref labelvec n))))
145	(setq n (1+ n)))
146	n))))))
147	\f
148	;; Basic functions
efb656fd	149	(declare-function rmail-update-summary "rmailsum" (&rest ignore))
537ab246 BG	150
	151	(defun rmail-sort-messages (reverse keyfun)
	152	"Sort messages of current Rmail file.
	153	If 1st argument REVERSE is non-nil, sort them in reverse order.
	154	2nd argument KEYFUN is called with a message number, and should return a key."
	155	(with-current-buffer rmail-buffer
	156	(let ((return-to-point
	157	(if (rmail-buffers-swapped-p)
	158	(point)))
537ab246 BG	159	(sort-lists nil))
	160	(rmail-swap-buffers-maybe)
	161	(message "Finding sort keys...")
	162	(widen)
	163	(let ((msgnum 1))
	164	(while (>= rmail-total-messages msgnum)
	165	(setq sort-lists
	166	(cons (list (funcall keyfun msgnum) ;Make sorting key
	167	(eq rmail-current-message msgnum) ;True if current
	168	(aref rmail-message-vector msgnum)
	169	(aref rmail-message-vector (1+ msgnum)))
	170	sort-lists))
	171	(if (zerop (% msgnum 10))
	172	(message "Finding sort keys...%d" msgnum))
	173	(setq msgnum (1+ msgnum))))
	174	(or reverse (setq sort-lists (nreverse sort-lists)))
537ab246 BG	175	(setq sort-lists
537ab246 BG	176	(sort sort-lists
73d7bcb9 SM	177	;; Decide predicate: < or string-lessp
	178	(if (numberp (car (car sort-lists))) ;Is a key numeric?
	179	'car-less-than-car
	180	(function
	181	(lambda (a b)
	182	(string-lessp (car a) (car b)))))))
537ab246 BG	183	(if reverse (setq sort-lists (nreverse sort-lists)))
	184	;; Now we enter critical region. So, keyboard quit is disabled.
	185	(message "Reordering messages...")
	186	(let ((inhibit-quit t) ;Inhibit quit
	187	(inhibit-read-only t)
	188	(current-message nil)
	189	(msgnum 1)
	190	(msginfo nil))
	191	;; There's little hope that we can easily undo after that.
	192	(buffer-disable-undo (current-buffer))
	193	(goto-char (rmail-msgbeg 1))
	194	;; To force update of all markers,
	195	;; keep the new copies separated from the remaining old messages.
	196	(insert-before-markers ?Z)
	197	(backward-char 1)
	198	;; Now reorder messages.
	199	(dolist (msginfo sort-lists)
	200	;; Swap two messages.
	201	(insert-buffer-substring
	202	(current-buffer) (nth 2 msginfo) (nth 3 msginfo))
	203	;; The last message may not have \n\n after it.
	204	(unless (bobp)
	205	(insert "\n"))
	206	(unless (looking-back "\n\n")
	207	(insert "\n"))
	208	(delete-region (nth 2 msginfo) (nth 3 msginfo))
	209	;; Is current message?
	210	(if (nth 1 msginfo)
	211	(setq current-message msgnum))
	212	(if (zerop (% msgnum 10))
	213	(message "Reordering messages...%d" msgnum))
	214	(setq msgnum (1+ msgnum)))
	215	;; Delete the dummy separator Z inserted before.
	216	(delete-char 1)
	217	(setq quit-flag nil)
	218	(rmail-set-message-counters)
a1a29341	219	(rmail-show-message-1 current-message)
537ab246 BG	220	(if return-to-point
	221	(goto-char return-to-point))
	222	(if (rmail-summary-exists)
	223	(rmail-select-summary (rmail-update-summary)))))))
	224
efb656fd GM	225	(autoload 'timezone-make-date-sortable "timezone")
efb656fd GM	226
537ab246 BG	227	(defun rmail-make-date-sortable (date)
	228	"Make DATE sortable using the function string-lessp."
	229	;; Assume the default time zone is GMT.
	230	(timezone-make-date-sortable date "GMT" "GMT"))
	231
	232	(provide 'rmailsort)
	233
537ab246 BG	234	;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
537ab246 BG	235	;;; rmailsort.el ends here