[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 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 'sort)

;; For rmail-select-summary
(require 'rmail)

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

;; 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-fetch-field msg "Date"))))))

;;;###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-fetch-field msg "Subject") ""))
				(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-fetch-field msg "From")
				(rmail-fetch-field msg "Sender") "")))))))

;;;###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-fetch-field msg "To")
				(rmail-fetch-field msg "Apparently-To") "")
			    ))))))

;;;###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
	    (rmail-dont-reply-to
	     (mail-strip-quoted-names
	      (or (rmail-fetch-field msg (car fields)) ""))))
      (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."
  (save-current-buffer
    ;; 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)
	  (point-offset (- (point) (point-min)))
	  (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.
	(buffer-disable-undo (current-buffer))
	(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)
	(rmail-show-message current-message)
	(goto-char (+ point-offset (point-min)))
	(if (rmail-summary-exists)
	    (rmail-select-summary
	     (rmail-update-summary)))))))

(defun rmail-fetch-field (msg field)
  "Return the value of the header FIELD of MSG.
Arguments are MSG and FIELD."
  (save-restriction
    (widen)
    (let ((next (rmail-msgend msg)))
      (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))))

(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: 0d90896b-0c35-46ac-b240-38be5ada2360
;;; rmailsort.el ends here
Commit	Line	Data
55535639	1	;;; rmailsort.el --- Rmail: sort messages
c88ab9ce	2
e84b4b86	3	;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004,
2f043267	4	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
9750e079	5
f00de7c3	6	;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
1884e325	7	;; Maintainer: FSF
d7b4d18f	8	;; Keywords: mail
e5167999	9
8fc3fee1 RS	10	;; This file is part of GNU Emacs.
8fc3fee1 RS	11
b1fc2b50	12	;; GNU Emacs is free software: you can redistribute it and/or modify
70e1dad8	13	;; it under the terms of the GNU General Public License as published by
b1fc2b50 GM	14	;; the Free Software Foundation, either version 3 of the License, or
b1fc2b50 GM	15	;; (at your option) any later version.
70e1dad8	16
8fc3fee1	17	;; GNU Emacs is distributed in the hope that it will be useful,
70e1dad8 RS	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
b1fc2b50	23	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
70e1dad8	24
55535639 PJ	25	;;; Commentary:
55535639 PJ	26
e5167999	27	;;; Code:
8fc3fee1	28
8fc3fee1 RS	29	(require 'sort)
8fc3fee1 RS	30
7999547d KH	31	;; For rmail-select-summary
	32	(require 'rmail)
	33
f00de7c3 RS	34	(autoload 'timezone-make-date-sortable "timezone")
f00de7c3 RS	35
f00de7c3	36	;; Sorting messages in Rmail buffer
8fc3fee1	37
372a91d7	38	;;;###autoload
8fc3fee1 RS	39	(defun rmail-sort-by-date (reverse)
	40	"Sort messages of current Rmail file by date.
	41	If prefix argument REVERSE is non-nil, sort them in reverse order."
	42	(interactive "P")
	43	(rmail-sort-messages reverse
	44	(function
	45	(lambda (msg)
f00de7c3	46	(rmail-make-date-sortable
8fc3fee1 RS	47	(rmail-fetch-field msg "Date"))))))
8fc3fee1 RS	48
372a91d7	49	;;;###autoload
8fc3fee1 RS	50	(defun rmail-sort-by-subject (reverse)
	51	"Sort messages of current Rmail file by subject.
	52	If prefix argument REVERSE is non-nil, sort them in reverse order."
	53	(interactive "P")
	54	(rmail-sort-messages reverse
	55	(function
	56	(lambda (msg)
	57	(let ((key (or (rmail-fetch-field msg "Subject") ""))
	58	(case-fold-search t))
	59	;; Remove `Re:'
b0304aef KH	60	(if (string-match "^\\(re:[ \t]\\)" key)
	61	(substring key (match-end 0))
	62	key))))))
8fc3fee1	63
372a91d7	64	;;;###autoload
8fc3fee1 RS	65	(defun rmail-sort-by-author (reverse)
	66	"Sort messages of current Rmail file by author.
	67	If prefix argument REVERSE is non-nil, sort them in reverse order."
	68	(interactive "P")
	69	(rmail-sort-messages reverse
	70	(function
	71	(lambda (msg)
f00de7c3 RS	72	(downcase ;Canonical name
	73	(mail-strip-quoted-names
	74	(or (rmail-fetch-field msg "From")
	75	(rmail-fetch-field msg "Sender") "")))))))
8fc3fee1	76
372a91d7	77	;;;###autoload
8fc3fee1 RS	78	(defun rmail-sort-by-recipient (reverse)
	79	"Sort messages of current Rmail file by recipient.
	80	If prefix argument REVERSE is non-nil, sort them in reverse order."
	81	(interactive "P")
	82	(rmail-sort-messages reverse
	83	(function
	84	(lambda (msg)
f00de7c3 RS	85	(downcase ;Canonical name
	86	(mail-strip-quoted-names
	87	(or (rmail-fetch-field msg "To")
	88	(rmail-fetch-field msg "Apparently-To") "")
	89	))))))
8fc3fee1	90
372a91d7	91	;;;###autoload
22a72f53 RS	92	(defun rmail-sort-by-correspondent (reverse)
	93	"Sort messages of current Rmail file by other correspondent.
	94	If prefix argument REVERSE is non-nil, sort them in reverse order."
	95	(interactive "P")
	96	(rmail-sort-messages reverse
	97	(function
	98	(lambda (msg)
	99	(rmail-select-correspondent
	100	msg
	101	'("From" "Sender" "To" "Apparently-To"))))))
	102
	103	(defun rmail-select-correspondent (msg fields)
	104	(let ((ans ""))
f00de7c3 RS	105	(while (and fields (string= ans ""))
	106	(setq ans
	107	(rmail-dont-reply-to
	108	(mail-strip-quoted-names
	109	(or (rmail-fetch-field msg (car fields)) ""))))
	110	(setq fields (cdr fields)))
	111	ans))
	112
372a91d7	113	;;;###autoload
f00de7c3	114	(defun rmail-sort-by-lines (reverse)
8b1d5b31	115	"Sort messages of current Rmail file by number of lines.
51693c8c RS	116	If prefix argument REVERSE is non-nil, sort them in reverse order."
	117	(interactive "P")
	118	(rmail-sort-messages reverse
	119	(function
	120	(lambda (msg)
be4e7157 KH	121	(count-lines (rmail-msgbeg msg)
be4e7157 KH	122	(rmail-msgend msg))))))
15589977	123
372a91d7	124	;;;###autoload
27d42947	125	(defun rmail-sort-by-labels (reverse labels)
15589977 KH	126	"Sort messages of current Rmail file by labels.
	127	If prefix argument REVERSE is non-nil, sort them in reverse order.
	128	KEYWORDS is a comma-separated list of labels."
	129	(interactive "P\nsSort by labels: ")
	130	(or (string-match "[^ \t]" labels)
	131	(error "No labels specified"))
	132	(setq labels (concat (substring labels (match-beginning 0)) ","))
	133	(let (labelvec)
	134	(while (string-match "[ \t],[ \t]" labels)
a1506d29	135	(setq labelvec (cons
15589977 KH	136	(concat ", ?\\("
	137	(substring labels 0 (match-beginning 0))
	138	"\\),")
	139	labelvec))
	140	(setq labels (substring labels (match-end 0))))
	141	(setq labelvec (apply 'vector (nreverse labelvec)))
	142	(rmail-sort-messages reverse
	143	(function
	144	(lambda (msg)
	145	(let ((n 0))
	146	(while (and (< n (length labelvec))
	147	(not (rmail-message-labels-p
	148	msg (aref labelvec n))))
	149	(setq n (1+ n)))
	150	n))))))
8fc3fee1	151	\f
f00de7c3	152	;; Basic functions
2b54af74	153	(declare-function rmail-update-summary "rmailsum" (&rest ignore))
f00de7c3 RS	154
f00de7c3 RS	155	(defun rmail-sort-messages (reverse keyfun)
8fc3fee1	156	"Sort messages of current Rmail file.
f00de7c3 RS	157	If 1st argument REVERSE is non-nil, sort them in reverse order.
f00de7c3 RS	158	2nd argument KEYFUN is called with a message number, and should return a key."
1884e325	159	(save-current-buffer
36bedc4f RS	160	;; If we are in a summary buffer, operate on the Rmail buffer.
	161	(if (eq major-mode 'rmail-summary-mode)
	162	(set-buffer rmail-buffer))
	163	(let ((buffer-read-only nil)
1884e325	164	(point-offset (- (point) (point-min)))
36bedc4f RS	165	(predicate nil) ;< or string-lessp
	166	(sort-lists nil))
	167	(message "Finding sort keys...")
	168	(widen)
	169	(let ((msgnum 1))
	170	(while (>= rmail-total-messages msgnum)
	171	(setq sort-lists
	172	(cons (list (funcall keyfun msgnum) ;Make sorting key
	173	(eq rmail-current-message msgnum) ;True if current
	174	(aref rmail-message-vector msgnum)
	175	(aref rmail-message-vector (1+ msgnum)))
	176	sort-lists))
	177	(if (zerop (% msgnum 10))
	178	(message "Finding sort keys...%d" msgnum))
	179	(setq msgnum (1+ msgnum))))
	180	(or reverse (setq sort-lists (nreverse sort-lists)))
	181	;; Decide predicate: < or string-lessp
	182	(if (numberp (car (car sort-lists))) ;Is a key numeric?
	183	(setq predicate (function <))
	184	(setq predicate (function string-lessp)))
	185	(setq sort-lists
	186	(sort sort-lists
	187	(function
	188	(lambda (a b)
	189	(funcall predicate (car a) (car b))))))
	190	(if reverse (setq sort-lists (nreverse sort-lists)))
	191	;; Now we enter critical region. So, keyboard quit is disabled.
	192	(message "Reordering messages...")
	193	(let ((inhibit-quit t) ;Inhibit quit
	194	(current-message nil)
	195	(msgnum 1)
	196	(msginfo nil))
	197	;; There's little hope that we can easily undo after that.
9baf79c7	198	(buffer-disable-undo (current-buffer))
36bedc4f RS	199	(goto-char (rmail-msgbeg 1))
	200	;; To force update of all markers.
	201	(insert-before-markers ?Z)
	202	(backward-char 1)
	203	;; Now reorder messages.
	204	(while sort-lists
	205	(setq msginfo (car sort-lists))
	206	;; Swap two messages.
	207	(insert-buffer-substring
	208	(current-buffer) (nth 2 msginfo) (nth 3 msginfo))
	209	(delete-region (nth 2 msginfo) (nth 3 msginfo))
	210	;; Is current message?
	211	(if (nth 1 msginfo)
	212	(setq current-message msgnum))
	213	(setq sort-lists (cdr sort-lists))
	214	(if (zerop (% msgnum 10))
	215	(message "Reordering messages...%d" msgnum))
	216	(setq msgnum (1+ msgnum)))
	217	;; Delete the garbage inserted before.
	218	(delete-char 1)
	219	(setq quit-flag nil)
	220	(buffer-enable-undo)
	221	(rmail-set-message-counters)
030ecb3c	222	(rmail-show-message current-message)
1884e325	223	(goto-char (+ point-offset (point-min)))
030ecb3c KH	224	(if (rmail-summary-exists)
	225	(rmail-select-summary
	226	(rmail-update-summary)))))))
f00de7c3	227
8fc3fee1	228	(defun rmail-fetch-field (msg field)
f00de7c3	229	"Return the value of the header FIELD of MSG.
8fc3fee1	230	Arguments are MSG and FIELD."
f00de7c3 RS	231	(save-restriction
	232	(widen)
	233	(let ((next (rmail-msgend msg)))
8fc3fee1 RS	234	(goto-char (rmail-msgbeg msg))
	235	(narrow-to-region (if (search-forward "\n* EOOH *\n" next t)
	236	(point)
	237	(forward-line 1)
	238	(point))
	239	(progn (search-forward "\n\n" nil t) (point)))
	240	(mail-fetch-field field))))
	241
f00de7c3 RS	242	(defun rmail-make-date-sortable (date)
	243	"Make DATE sortable using the function string-lessp."
	244	;; Assume the default time zone is GMT.
	245	(timezone-make-date-sortable date "GMT" "GMT"))
	246
49116ac0	247	(provide 'rmailsort)
c88ab9ce	248
cbee283d	249	;; arch-tag: 0d90896b-0c35-46ac-b240-38be5ada2360
c88ab9ce	250	;;; rmailsort.el ends here