annotate lisp/mail/pmailsort.el @ 97528:184bb2071e3f

mail/: Add new (temporary) libaries for which to test Rmail/mbox such that Rmail/babyl is not affected. This creates a facility/feature called "pmail" (analagous to "rmail") that can be used independently from Rmail for testing purposes. The plan is to replace the "rmail" files eventually and remove "pmail" entirely at that point. In the interim, interested developers can use either Rmail or Pmail or both (which is not recommended for the casual User or the faint of heart).

;;; 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 <[e-mail]>
;; 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")

;; 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
	    (pmail-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))))))

;; Basic functions

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

(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-marker-start msgnum)
			    (pmail-desc-get-marker-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)

;; arch-tag: 0d90896b-0c35-46ac-b240-38be5ada2360
;;; pmailsort.el ends here