view lisp/mail/rmailsort.el @ 47641:172cf7391545

(calc-bug-address, calc-scan-for-dels, calc-stack) (calc-stack-top, calc-always-load-extensions) (calc-line-numbering, calc-line-breaking, calc-display-just) (calc-display-origin, calc-number-radix, calc-leading-zeros) (calc-group-digits, calc-group-char, calc-point-char) (calc-frac-format, calc-prefer-frac, calc-hms-format) (calc-date-format, calc-float-format, calc-complex-format) (calc-full-float-format, calc-complex-mode, calc-infinite-mode) (calc-display-strings, calc-matrix-just, calc-break-vectors) (calc-full-vectors, calc-full-trail-vectors, calc-vector-commas) (calc-vector-brackets, calc-matrix-brackets, calc-language) (calc-language-option, calc-function-open, calc-function-open) (calc-function-close, calc-language-output-filter) (calc-language-input-filter, calc-radix-formatter) (calc-left-label, calc-right-label, calc-word-size) (calc-previous-modulo, calc-simplify-mode, calc-auto-recompute) (calc-display-raw, calc-internal-prec, calc-inverse-flag) (calc-hyperbolic-flag, calc-keep-args-flag, calc-angle-mode) (calc-algebraic-mode, calc-incomplete-algebraic-mode) (calc-symbolic-mode, calc-matrix-mode, calc-shift-prefix) (calc-window-height, calc-display-trail, calc-show-selections) (calc-use-selections, calc-assoc-selections) (calc-display-working-message, calc-auto-why, calc-timing) (calc-display-sci-high, calc-display-sci-low, calc-other-modes) (calc-other-modes, calc-Y-help-msgs, calc-loaded-settings-file): Make into real defvars. (calc-mode-var-list): Delete. (calc-mode-save-mode, calc-standard-date-formats) (calc-autorange-units, calc-was-keypad-mode, calc-full-mode) (calc-user-parse-tables, calc-gnuplot-default-device) (calc-gnuplot-default-output, calc-gnuplot-print-device) (calc-gnuplot-print-output, calc-gnuplot-geometry) (calc-graph-default-resolution, calc-graph-default-resolution-3d) (calc-invocation-macro, calc-show-banner): Make into defvars, taken from `calc-mode-var-list'. (calc-emacs-type-epoch, calc-emacs-type-19) (calc-emacs-type-lucid, calc-emacs-type-gnu19): Make into defvars. (calc-version, calc-version-date, calc-trail-pointer) (calc-trail-overlay, calc-undo-list, calc-redo-list) (calc-main-buffer, calc-trail-buffer, calc-why, calc-next-why) (calc-inverse-flag, calc-hyperbolic-flag, calc-keep-args-flag) (calc-last-kill, calc-previous-alg-entry, calc-dollar-values) (calc-dollar-used, calc-hashes-used, calc-quick-prev-results) (calc-said-hello, calc-executing-macro, calc-any-selections) (calc-help-phase, calc-full-help-flag, calc-refresh-count) (calc-display-dirty, calc-prepared-composition) (calc-selection-cache-default-entry, calc-embedded-info) (calc-embedded-active, calc-standalone-flag, var-EvalRules) (math-eval-rules-cache-tag, math-radix-explicit-format) (math-expr-function-mapping, math-expr-variable-mapping) (math-read-expr-quotes, math-working-step, math-working-step-2) (var-i, var-pi, var-e, var-phi, var-gamma, var-Modes): Make into defvars, from toplevel setq. (calc-mode-map): Set up keymap in more modern fashion. (calc-dispatch-map): Ditto. (calc-command-flags, calc-final-point-line) (calc-final-point-column): Defvar. (calc-do): Use `save-current-buffer' instead of `save-excursion'. (sel-mode): Defvar. (calc-any-evaltos): Ditto. (calc-buffer, calc-prev-char, calc-prev-prev-char) (calc-digit-value): Ditto. (math-eval-rules-cache, math-eval-rules-cache-other): Ditto. (math-sub-bignum): Bind `diff'. (calc-selection-cache-entry): Defvar. (calc-count-lines): Reference `pos' instead of `newpos'.

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

;; Copyright (C) 1990, 1993, 1994, 2001 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 2, 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

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

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

;;; rmailsort.el ends here