X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/2846c6e3607995ce250435e5998ea6a08f60dd89..bd78fa1d5442e6e023a16d407741ec899d57d3cd:/lisp/mail/rmailsort.el diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el index a4de5a6c86..f4fd52c10c 100644 --- a/lisp/mail/rmailsort.el +++ b/lisp/mail/rmailsort.el @@ -1,11 +1,12 @@ ;;; rmailsort.el --- Rmail: sort messages -;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Maintainer: FSF ;; Keywords: mail +;; Package: rmail ;; This file is part of GNU Emacs. @@ -24,146 +25,159 @@ ;;; Commentary: -;;; Code: +;; Functions for sorting messages in an Rmail buffer. -(require 'sort) +;;; Code: -;; 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." + "Sort messages of current Rmail buffer by \"Date\" header. +If prefix argument REVERSE is non-nil, sorts in reverse order." (interactive "P") (rmail-sort-messages reverse - (function - (lambda (msg) - (rmail-make-date-sortable - (rmail-fetch-field msg "Date")))))) + (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." + "Sort messages of current Rmail buffer by \"Subject\" header. +Ignores any \"Re: \" prefix. If prefix argument REVERSE is +non-nil, sorts in reverse order." + ;; Note this is a case-sensitive sort. (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)))))) + (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." + "Sort messages of current Rmail buffer by author. +This uses either the \"From\" or \"Sender\" header, downcased. +If prefix argument REVERSE is non-nil, sorts 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") ""))))))) + (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." + "Sort messages of current Rmail buffer by recipient. +This uses either the \"To\" or \"Apparently-To\" header, downcased. +If prefix argument REVERSE is non-nil, sorts 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") "") - )))))) + (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." + "Sort messages of current Rmail buffer by other correspondent. +This uses either the \"From\", \"Sender\", \"To\", or +\"Apparently-To\" header, downcased. Uses the first header not +excluded by `rmail-dont-reply-to-names'. If prefix argument +REVERSE is non-nil, sorts in reverse order." (interactive "P") (rmail-sort-messages reverse - (function - (lambda (msg) + (lambda (msg) + (downcase (rmail-select-correspondent msg '("From" "Sender" "To" "Apparently-To")))))) (defun rmail-select-correspondent (msg fields) + "Find the first header not excluded by `rmail-dont-reply-to-names'. +MSG is a message number. FIELDS is a list of header names." (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-fetch-field msg (car fields)) "")))) + (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." + "Sort messages of current Rmail buffer by the number of lines. +If prefix argument REVERSE is non-nil, sorts in reverse order." (interactive "P") (rmail-sort-messages reverse - (function - (lambda (msg) - (count-lines (rmail-msgbeg msg) - (rmail-msgend msg)))))) + (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." + "Sort messages of current Rmail buffer by labels. +LABELS is a comma-separated list of labels. The order of these +labels specifies the order of messages: messages with the first +label come first, messages with the second label come second, and +so on. Messages that have none of these labels come last. +If prefix argument REVERSE is non-nil, sorts in reverse order." (interactive "P\nsSort by labels: ") - (or (string-match "[^ \t]" labels) + (or (string-match "[^ \t]" labels) ; need some non-whitespace (error "No labels specified")) + ;; Remove leading whitespace, add trailing comma. (setq labels (concat (substring labels (match-beginning 0)) ",")) - (let (labelvec) + (let (labelvec nmax) + ;; Convert "l1,..." into "\\(, \\|\\`\\)l1\\(,\\|\\'\\)" "..." ... (while (string-match "[ \t]*,[ \t]*" labels) (setq labelvec (cons - (concat ", ?\\(" + (concat "\\(, \\|\\`\\)" (substring labels 0 (match-beginning 0)) - "\\),") + "\\(,\\|\\'\\)") labelvec)) (setq labels (substring labels (match-end 0)))) - (setq labelvec (apply 'vector (nreverse labelvec))) + (setq labelvec (apply 'vector (nreverse labelvec)) + nmax (length 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)))))) + ;; If no labels match, returns nmax; if they + ;; match the first specified in LABELS, + ;; returns 0; if they match the second, returns 1; etc. + ;; Hence sorts as described in the doc-string. + (lambda (msg) + (let ((n 0) + (str (concat (rmail-get-attr-names msg) + ", " + (rmail-get-keywords msg)))) + ;; No labels: can't match anything. + (if (string-equal ", " str) + nmax + (while (and (< n nmax) + (not (string-match (aref labelvec n) + str))) + (setq n (1+ n))) + n)))))) ;; 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 messages of current Rmail buffer. +If REVERSE is non-nil, sorts in reverse order. Calls the +function KEYFUN with a message number (it should return a sort key). +Numeric keys are sorted numerically, all others as strings." + (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)) @@ -178,73 +192,68 @@ If 1st argument REVERSE is non-nil, sort them in reverse order. (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)))))) + ;; Decide predicate: < or string-lessp + (if (numberp (car (car sort-lists))) ;Is a key numeric? + 'car-less-than-car + (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)) + (msginfo nil) + (undo (not (eq buffer-undo-list t)))) ;; 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. + ;; 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. - (while sort-lists - (setq msginfo (car sort-lists)) + (dolist (msginfo sort-lists) ;; Swap two messages. (insert-buffer-substring (current-buffer) (nth 2 msginfo) (nth 3 msginfo)) - (delete-region (nth 2 msginfo) (nth 3 msginfo)) + ;; The last message may not have \n\n after it. + (rmail-ensure-blank-line) + (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 the dummy separator Z inserted before. (delete-char 1) (setq quit-flag nil) - (buffer-enable-undo) + ;; If undo was on before, re-enable it. But note that it is + ;; disabled in mbox Rmail, so this is kind of pointless. + (if undo (buffer-enable-undo)) (rmail-set-message-counters) - (rmail-show-message current-message) - (goto-char (+ point-offset (point-min))) + (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))))))) - -(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)))) + (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." + "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 +;; Local Variables: +;; generated-autoload-file: "rmail.el" +;; End: + +;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5 ;;; rmailsort.el ends here