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

;;; pmailsort.el --- Pmail: 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:

(eval-when-compile
  (require 'mail-utils)
  (require 'sort)
  (require 'pmail))

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

(declare-function pmail-update-summary "pmailsum" (&rest ignore))

;; Sorting messages in Pmail buffer

;;;###autoload
(defun pmail-sort-by-date (reverse)
  "Sort messages of current Pmail file by date.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (pmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (pmail-make-date-sortable
			   (pmail-fetch-field msg "Date"))))))

;;;###autoload
(defun pmail-sort-by-subject (reverse)
  "Sort messages of current Pmail file by subject.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (pmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (let ((key (or (pmail-fetch-field msg "Subject") ""))
				(case-fold-search t))
			    ;; Remove `Re:'
			    (if (string-match "^\\(re:[ \t]*\\)*" key)
				(substring key (match-end 0))
			      key))))))

;;;###autoload
(defun pmail-sort-by-author (reverse)
  "Sort messages of current Pmail file by author.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (pmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (downcase	;Canonical name
			   (mail-strip-quoted-names
			    (or (pmail-fetch-field msg "From")
				(pmail-fetch-field msg "Sender") "")))))))

;;;###autoload
(defun pmail-sort-by-recipient (reverse)
  "Sort messages of current Pmail file by recipient.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (pmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (downcase	;Canonical name
			   (mail-strip-quoted-names
			    (or (pmail-fetch-field msg "To")
				(pmail-fetch-field msg "Apparently-To") "")
			    ))))))

;;;###autoload
(defun pmail-sort-by-correspondent (reverse)
  "Sort messages of current Pmail file by other correspondent.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (pmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (pmail-select-correspondent
			   msg
			   '("From" "Sender" "To" "Apparently-To"))))))

(defun pmail-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 (pmail-fetch-field msg (car fields)) ""))))
      (setq fields (cdr fields)))
    ans))

;;;###autoload
(defun pmail-sort-by-lines (reverse)
  "Sort messages of current Pmail file by number of lines.
If prefix argument REVERSE is non-nil, sort them in reverse order."
  (interactive "P")
  (pmail-sort-messages reverse
		       (function
			(lambda (msg)
			  (count-lines (pmail-desc-get-start msg)
				       (pmail-desc-get-end msg))))))

;;;###autoload
(defun pmail-sort-by-labels (reverse labels)
  "Sort messages of current Pmail 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)))
    (pmail-sort-messages reverse
			 (function
			  (lambda (msg)
			    (let ((n 0))
			      (while (and (< n (length labelvec))
					  (not (pmail-message-labels-p
						msg (aref labelvec n))))
				(setq n (1+ n)))
			      n))))))
\f
;; Basic functions

(defun pmail-sort-messages (reverse keyfun)
  "Sort messages of current Pmail 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 Pmail buffer.
    (if (eq major-mode 'pmail-summary-mode)
	(set-buffer pmail-buffer))
    (let ((buffer-read-only nil)
	  (point-offset (- (point) (point-min)))
	  (predicate nil)			;< or string-lessp
	  (sort-lists nil))
      (message "Finding sort keys...")
      (pmail-header-show-headers)
      (widen)
      (let ((msgnum 1))
	(while (>= pmail-total-messages msgnum)
	  (setq sort-lists
		(cons (list (funcall keyfun msgnum) ;Make sorting key
			    (eq pmail-current-message msgnum) ;True if current
			    (pmail-desc-get-start msgnum)
			    (pmail-desc-get-end 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 (pmail-desc-get-start 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)
        (goto-char (point-min))
	(pmail-initialize-messages)
	(pmail-show-message current-message)
	(if (pmail-summary-exists)
	    (pmail-select-summary
	     (pmail-update-summary)))))))

;; mbox: ready
(defun pmail-fetch-field (msg field)
  "Return the value of the header FIELD of MSG.
Arguments are MSG and FIELD."
  (save-restriction
    (widen)
    (narrow-to-region
     (pmail-desc-get-start msg)
     (pmail-desc-get-end msg))
    (pmail-header-get-header field)))

(defun pmail-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 'pmailsort)

;; Local Variables:
;; change-log-default-name: "ChangeLog.pmail"
;; End:

;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
;;; pmailsort.el ends here
Commit	Line	Data
e131541f PR	1	;;; pmailsort.el --- Pmail: sort messages
	2
	3	;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004,
	4	;; 2005, 2006, 2007, 2008 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
	29	(eval-when-compile
	30	(require 'mail-utils)
	31	(require 'sort)
	32	(require 'pmail))
	33
	34	(autoload 'timezone-make-date-sortable "timezone")
	35
acdc2006 PR	36	(declare-function pmail-update-summary "pmailsum" (&rest ignore))
acdc2006 PR	37
e131541f PR	38	;; Sorting messages in Pmail buffer
	39
	40	;;;###autoload
	41	(defun pmail-sort-by-date (reverse)
	42	"Sort messages of current Pmail file by date.
	43	If prefix argument REVERSE is non-nil, sort them in reverse order."
	44	(interactive "P")
	45	(pmail-sort-messages reverse
	46	(function
	47	(lambda (msg)
	48	(pmail-make-date-sortable
	49	(pmail-fetch-field msg "Date"))))))
	50
	51	;;;###autoload
	52	(defun pmail-sort-by-subject (reverse)
	53	"Sort messages of current Pmail file by subject.
	54	If prefix argument REVERSE is non-nil, sort them in reverse order."
	55	(interactive "P")
	56	(pmail-sort-messages reverse
	57	(function
	58	(lambda (msg)
	59	(let ((key (or (pmail-fetch-field msg "Subject") ""))
	60	(case-fold-search t))
	61	;; Remove `Re:'
	62	(if (string-match "^\\(re:[ \t]\\)" key)
	63	(substring key (match-end 0))
	64	key))))))
	65
	66	;;;###autoload
	67	(defun pmail-sort-by-author (reverse)
	68	"Sort messages of current Pmail file by author.
	69	If prefix argument REVERSE is non-nil, sort them in reverse order."
	70	(interactive "P")
	71	(pmail-sort-messages reverse
	72	(function
	73	(lambda (msg)
	74	(downcase ;Canonical name
	75	(mail-strip-quoted-names
	76	(or (pmail-fetch-field msg "From")
	77	(pmail-fetch-field msg "Sender") "")))))))
	78
	79	;;;###autoload
	80	(defun pmail-sort-by-recipient (reverse)
	81	"Sort messages of current Pmail file by recipient.
	82	If prefix argument REVERSE is non-nil, sort them in reverse order."
	83	(interactive "P")
	84	(pmail-sort-messages reverse
	85	(function
	86	(lambda (msg)
	87	(downcase ;Canonical name
	88	(mail-strip-quoted-names
	89	(or (pmail-fetch-field msg "To")
	90	(pmail-fetch-field msg "Apparently-To") "")
	91	))))))
	92
	93	;;;###autoload
	94	(defun pmail-sort-by-correspondent (reverse)
	95	"Sort messages of current Pmail file by other correspondent.
	96	If prefix argument REVERSE is non-nil, sort them in reverse order."
	97	(interactive "P")
	98	(pmail-sort-messages reverse
	99	(function
	100	(lambda (msg)
	101	(pmail-select-correspondent
102	msg
103	'("From" "Sender" "To" "Apparently-To"))))))
104
105	(defun pmail-select-correspondent (msg fields)
106	(let ((ans ""))
107	(while (and fields (string= ans ""))
108	(setq ans
59988cef GM	109	;; NB despite the name, this lives in mail-utils.el.
59988cef GM	110	(rmail-dont-reply-to
e131541f PR	111	(mail-strip-quoted-names
	112	(or (pmail-fetch-field msg (car fields)) ""))))
	113	(setq fields (cdr fields)))
	114	ans))
	115
	116	;;;###autoload
	117	(defun pmail-sort-by-lines (reverse)
	118	"Sort messages of current Pmail file by number of lines.
	119	If prefix argument REVERSE is non-nil, sort them in reverse order."
	120	(interactive "P")
	121	(pmail-sort-messages reverse
	122	(function
	123	(lambda (msg)
	124	(count-lines (pmail-desc-get-start msg)
	125	(pmail-desc-get-end msg))))))
	126
	127	;;;###autoload
	128	(defun pmail-sort-by-labels (reverse labels)
	129	"Sort messages of current Pmail file by labels.
	130	If prefix argument REVERSE is non-nil, sort them in reverse order.
	131	KEYWORDS is a comma-separated list of labels."
	132	(interactive "P\nsSort by labels: ")
	133	(or (string-match "[^ \t]" labels)
	134	(error "No labels specified"))
	135	(setq labels (concat (substring labels (match-beginning 0)) ","))
	136	(let (labelvec)
	137	(while (string-match "[ \t],[ \t]" labels)
	138	(setq labelvec (cons
	139	(concat ", ?\\("
	140	(substring labels 0 (match-beginning 0))
	141	"\\),")
	142	labelvec))
	143	(setq labels (substring labels (match-end 0))))
	144	(setq labelvec (apply 'vector (nreverse labelvec)))
	145	(pmail-sort-messages reverse
	146	(function
	147	(lambda (msg)
	148	(let ((n 0))
	149	(while (and (< n (length labelvec))
	150	(not (pmail-message-labels-p
	151	msg (aref labelvec n))))
	152	(setq n (1+ n)))
	153	n))))))
	154	\f
	155	;; Basic functions
	156
e131541f PR	157	(defun pmail-sort-messages (reverse keyfun)
	158	"Sort messages of current Pmail file.
	159	If 1st argument REVERSE is non-nil, sort them in reverse order.
	160	2nd argument KEYFUN is called with a message number, and should return a key."
	161	(save-current-buffer
	162	;; If we are in a summary buffer, operate on the Pmail buffer.
	163	(if (eq major-mode 'pmail-summary-mode)
	164	(set-buffer pmail-buffer))
	165	(let ((buffer-read-only nil)
	166	(point-offset (- (point) (point-min)))
	167	(predicate nil) ;< or string-lessp
	168	(sort-lists nil))
	169	(message "Finding sort keys...")
	170	(pmail-header-show-headers)
	171	(widen)
	172	(let ((msgnum 1))
	173	(while (>= pmail-total-messages msgnum)
	174	(setq sort-lists
	175	(cons (list (funcall keyfun msgnum) ;Make sorting key
	176	(eq pmail-current-message msgnum) ;True if current
8ac8cb14 GM	177	(pmail-desc-get-start msgnum)
8ac8cb14 GM	178	(pmail-desc-get-end msgnum))
e131541f PR	179	sort-lists))
	180	(if (zerop (% msgnum 10))
	181	(message "Finding sort keys...%d" msgnum))
	182	(setq msgnum (1+ msgnum))))
	183	(or reverse (setq sort-lists (nreverse sort-lists)))
	184	;; Decide predicate: < or string-lessp
	185	(if (numberp (car (car sort-lists))) ;Is a key numeric?
	186	(setq predicate (function <))
	187	(setq predicate (function string-lessp)))
	188	(setq sort-lists
	189	(sort sort-lists
	190	(function
	191	(lambda (a b)
	192	(funcall predicate (car a) (car b))))))
	193	(if reverse (setq sort-lists (nreverse sort-lists)))
	194	;; Now we enter critical region. So, keyboard quit is disabled.
	195	(message "Reordering messages...")
	196	(let ((inhibit-quit t) ;Inhibit quit
	197	(current-message nil)
	198	(msgnum 1)
	199	(msginfo nil))
	200	;; There's little hope that we can easily undo after that.
	201	(buffer-disable-undo (current-buffer))
	202	(goto-char (pmail-desc-get-start 1))
	203	;; To force update of all markers.
	204	(insert-before-markers ?Z)
	205	(backward-char 1)
	206	;; Now reorder messages.
	207	(while sort-lists
	208	(setq msginfo (car sort-lists))
	209	;; Swap two messages.
	210	(insert-buffer-substring
	211	(current-buffer) (nth 2 msginfo) (nth 3 msginfo))
	212	(delete-region (nth 2 msginfo) (nth 3 msginfo))
	213	;; Is current message?
	214	(if (nth 1 msginfo)
	215	(setq current-message msgnum))
	216	(setq sort-lists (cdr sort-lists))
	217	(if (zerop (% msgnum 10))
	218	(message "Reordering messages...%d" msgnum))
	219	(setq msgnum (1+ msgnum)))
	220	;; Delete the garbage inserted before.
	221	(delete-char 1)
	222	(setq quit-flag nil)
	223	(buffer-enable-undo)
	224	(goto-char (point-min))
	225	(pmail-initialize-messages)
	226	(pmail-show-message current-message)
	227	(if (pmail-summary-exists)
	228	(pmail-select-summary
	229	(pmail-update-summary)))))))
	230
	231	;; mbox: ready
	232	(defun pmail-fetch-field (msg field)
	233	"Return the value of the header FIELD of MSG.
	234	Arguments are MSG and FIELD."
	235	(save-restriction
	236	(widen)
	237	(narrow-to-region
	238	(pmail-desc-get-start msg)
	239	(pmail-desc-get-end msg))
	240	(pmail-header-get-header field)))
	241
	242	(defun pmail-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
247	(provide 'pmailsort)
248
51a5d095 GM	249	;; Local Variables:
	250	;; change-log-default-name: "ChangeLog.pmail"
	251	;; End:
	252
0faeefbb	253	;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
e131541f	254	;;; pmailsort.el ends here