Mercurial > emacs
view lisp/mail/mbox-trunk-annotations/rmailsort.el.annotation @ 98050:edd21e1628da
*** empty log message ***
| author | Glenn Morris <rgm@gnu.org> |
|---|---|
| date | Sat, 06 Sep 2008 18:44:46 +0000 |
| parents | 513ae63d6175 |
| children |
line wrap: on
line source
1.28 (pj 15-Jul-01): ;;; rmailsort.el --- Rmail: sort messages 1.7 (eric 30-May-92): 1.32 (ttn 06-Aug-05): ;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004, 1.37 (miles 08-Jan-08): ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. 1.11 (eric 22-Jul-92): 1.14 (rms 26-May-93): ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> 1.26 (rms 10-Feb-97): ;; Maintainer: FSF 1.10 (eric 17-Jul-92): ;; Keywords: mail 1.9 (eric 16-Jul-92): 1.8 (rms 14-Jul-92): ;; This file is part of GNU Emacs. 1.1 (rms 10-Sep-90): 1.39 (gm 06-May-08): ;; GNU Emacs is free software: you can redistribute it and/or modify 1.8 (rms 14-Jul-92): ;; it under the terms of the GNU General Public License as published by 1.39 (gm 06-May-08): ;; the Free Software Foundation, either version 3 of the License, or 1.39 (gm 06-May-08): ;; (at your option) any later version. 1.1 (rms 10-Sep-90): 1.1 (rms 10-Sep-90): ;; GNU Emacs is distributed in the hope that it will be useful, 1.8 (rms 14-Jul-92): ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 1.8 (rms 14-Jul-92): ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1.8 (rms 14-Jul-92): ;; GNU General Public License for more details. 1.8 (rms 14-Jul-92): 1.8 (rms 14-Jul-92): ;; You should have received a copy of the GNU General Public License 1.39 (gm 06-May-08): ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. 1.28 (pj 15-Jul-01): 1.28 (pj 15-Jul-01): ;;; Commentary: 1.1 (rms 10-Sep-90): 1.9 (eric 16-Jul-92): ;;; Code: 1.1 (rms 10-Sep-90): 1.1 (rms 10-Sep-90): (require 'sort) 1.24 (kwzh 20-Jan-96): 1.24 (kwzh 20-Jan-96): ;; For rmail-select-summary 1.24 (kwzh 20-Jan-96): (require 'rmail) 1.1 (rms 10-Sep-90): 1.14 (rms 26-May-93): (autoload 'timezone-make-date-sortable "timezone") 1.14 (rms 26-May-93): 1.14 (rms 26-May-93): ;; Sorting messages in Rmail buffer 1.14 (rms 26-May-93): 1.25 (rms 27-Sep-96): ;;;###autoload 1.1 (rms 10-Sep-90): (defun rmail-sort-by-date (reverse) 1.1 (rms 10-Sep-90): "Sort messages of current Rmail file by date. 1.1 (rms 10-Sep-90): If prefix argument REVERSE is non-nil, sort them in reverse order." 1.1 (rms 10-Sep-90): (interactive "P") 1.1 (rms 10-Sep-90): (rmail-sort-messages reverse 1.1 (rms 10-Sep-90): (function 1.1 (rms 10-Sep-90): (lambda (msg) 1.14 (rms 26-May-93): (rmail-make-date-sortable 1.1 (rms 10-Sep-90): (rmail-fetch-field msg "Date")))))) 1.1 (rms 10-Sep-90): 1.25 (rms 27-Sep-96): ;;;###autoload 1.1 (rms 10-Sep-90): (defun rmail-sort-by-subject (reverse) 1.1 (rms 10-Sep-90): "Sort messages of current Rmail file by subject. 1.1 (rms 10-Sep-90): If prefix argument REVERSE is non-nil, sort them in reverse order." 1.1 (rms 10-Sep-90): (interactive "P") 1.1 (rms 10-Sep-90): (rmail-sort-messages reverse 1.1 (rms 10-Sep-90): (function 1.1 (rms 10-Sep-90): (lambda (msg) 1.1 (rms 10-Sep-90): (let ((key (or (rmail-fetch-field msg "Subject") "")) 1.1 (rms 10-Sep-90): (case-fold-search t)) 1.1 (rms 10-Sep-90): ;; Remove `Re:' 1.18 (kwzh 23-Mar-94): (if (string-match "^\\(re:[ \t]*\\)*" key) 1.18 (kwzh 23-Mar-94): (substring key (match-end 0)) 1.18 (kwzh 23-Mar-94): key)))))) 1.1 (rms 10-Sep-90): 1.25 (rms 27-Sep-96): ;;;###autoload 1.1 (rms 10-Sep-90): (defun rmail-sort-by-author (reverse) 1.1 (rms 10-Sep-90): "Sort messages of current Rmail file by author. 1.1 (rms 10-Sep-90): If prefix argument REVERSE is non-nil, sort them in reverse order." 1.1 (rms 10-Sep-90): (interactive "P") 1.1 (rms 10-Sep-90): (rmail-sort-messages reverse 1.1 (rms 10-Sep-90): (function 1.1 (rms 10-Sep-90): (lambda (msg) 1.14 (rms 26-May-93): (downcase ;Canonical name 1.14 (rms 26-May-93): (mail-strip-quoted-names 1.14 (rms 26-May-93): (or (rmail-fetch-field msg "From") 1.14 (rms 26-May-93): (rmail-fetch-field msg "Sender") ""))))))) 1.1 (rms 10-Sep-90): 1.25 (rms 27-Sep-96): ;;;###autoload 1.1 (rms 10-Sep-90): (defun rmail-sort-by-recipient (reverse) 1.1 (rms 10-Sep-90): "Sort messages of current Rmail file by recipient. 1.1 (rms 10-Sep-90): If prefix argument REVERSE is non-nil, sort them in reverse order." 1.1 (rms 10-Sep-90): (interactive "P") 1.1 (rms 10-Sep-90): (rmail-sort-messages reverse 1.1 (rms 10-Sep-90): (function 1.1 (rms 10-Sep-90): (lambda (msg) 1.14 (rms 26-May-93): (downcase ;Canonical name 1.14 (rms 26-May-93): (mail-strip-quoted-names 1.14 (rms 26-May-93): (or (rmail-fetch-field msg "To") 1.14 (rms 26-May-93): (rmail-fetch-field msg "Apparently-To") "") 1.14 (rms 26-May-93): )))))) 1.1 (rms 10-Sep-90): 1.25 (rms 27-Sep-96): ;;;###autoload 1.3 (rms 03-Dec-90): (defun rmail-sort-by-correspondent (reverse) 1.3 (rms 03-Dec-90): "Sort messages of current Rmail file by other correspondent. 1.3 (rms 03-Dec-90): If prefix argument REVERSE is non-nil, sort them in reverse order." 1.3 (rms 03-Dec-90): (interactive "P") 1.3 (rms 03-Dec-90): (rmail-sort-messages reverse 1.3 (rms 03-Dec-90): (function 1.3 (rms 03-Dec-90): (lambda (msg) 1.3 (rms 03-Dec-90): (rmail-select-correspondent 1.3 (rms 03-Dec-90): msg 1.3 (rms 03-Dec-90): '("From" "Sender" "To" "Apparently-To")))))) 1.3 (rms 03-Dec-90): 1.3 (rms 03-Dec-90): (defun rmail-select-correspondent (msg fields) 1.3 (rms 03-Dec-90): (let ((ans "")) 1.14 (rms 26-May-93): (while (and fields (string= ans "")) 1.14 (rms 26-May-93): (setq ans 1.14 (rms 26-May-93): (rmail-dont-reply-to 1.14 (rms 26-May-93): (mail-strip-quoted-names 1.14 (rms 26-May-93): (or (rmail-fetch-field msg (car fields)) "")))) 1.14 (rms 26-May-93): (setq fields (cdr fields))) 1.14 (rms 26-May-93): ans)) 1.4 (rms 27-Dec-90): 1.25 (rms 27-Sep-96): ;;;###autoload 1.14 (rms 26-May-93): (defun rmail-sort-by-lines (reverse) 1.15 (rms 22-Jun-93): "Sort messages of current Rmail file by number of lines. 1.4 (rms 27-Dec-90): If prefix argument REVERSE is non-nil, sort them in reverse order." 1.4 (rms 27-Dec-90): (interactive "P") 1.4 (rms 27-Dec-90): (rmail-sort-messages reverse 1.4 (rms 27-Dec-90): (function 1.4 (rms 27-Dec-90): (lambda (msg) 1.17 (kwzh 12-Mar-94): (count-lines (rmail-msgbeg msg) 1.17 (kwzh 12-Mar-94): (rmail-msgend msg)))))) 1.21 (kwzh 07-Apr-94): 1.25 (rms 27-Sep-96): ;;;###autoload 1.27 (gerd 07-May-01): (defun rmail-sort-by-labels (reverse labels) 1.21 (kwzh 07-Apr-94): "Sort messages of current Rmail file by labels. 1.21 (kwzh 07-Apr-94): If prefix argument REVERSE is non-nil, sort them in reverse order. 1.21 (kwzh 07-Apr-94): KEYWORDS is a comma-separated list of labels." 1.21 (kwzh 07-Apr-94): (interactive "P\nsSort by labels: ") 1.21 (kwzh 07-Apr-94): (or (string-match "[^ \t]" labels) 1.21 (kwzh 07-Apr-94): (error "No labels specified")) 1.21 (kwzh 07-Apr-94): (setq labels (concat (substring labels (match-beginning 0)) ",")) 1.21 (kwzh 07-Apr-94): (let (labelvec) 1.21 (kwzh 07-Apr-94): (while (string-match "[ \t]*,[ \t]*" labels) 1.29 (lektu 04-Feb-03): (setq labelvec (cons 1.21 (kwzh 07-Apr-94): (concat ", ?\\(" 1.21 (kwzh 07-Apr-94): (substring labels 0 (match-beginning 0)) 1.21 (kwzh 07-Apr-94): "\\),") 1.21 (kwzh 07-Apr-94): labelvec)) 1.21 (kwzh 07-Apr-94): (setq labels (substring labels (match-end 0)))) 1.21 (kwzh 07-Apr-94): (setq labelvec (apply 'vector (nreverse labelvec))) 1.21 (kwzh 07-Apr-94): (rmail-sort-messages reverse 1.21 (kwzh 07-Apr-94): (function 1.21 (kwzh 07-Apr-94): (lambda (msg) 1.21 (kwzh 07-Apr-94): (let ((n 0)) 1.21 (kwzh 07-Apr-94): (while (and (< n (length labelvec)) 1.21 (kwzh 07-Apr-94): (not (rmail-message-labels-p 1.21 (kwzh 07-Apr-94): msg (aref labelvec n)))) 1.21 (kwzh 07-Apr-94): (setq n (1+ n))) 1.21 (kwzh 07-Apr-94): n)))))) 1.14 (rms 26-May-93): 1.14 (rms 26-May-93): ;; Basic functions 1.36 (dann 25-Nov-07): (declare-function rmail-update-summary "rmailsum" (&rest ignore)) 1.1 (rms 10-Sep-90): 1.14 (rms 26-May-93): (defun rmail-sort-messages (reverse keyfun) 1.1 (rms 10-Sep-90): "Sort messages of current Rmail file. 1.14 (rms 26-May-93): If 1st argument REVERSE is non-nil, sort them in reverse order. 1.14 (rms 26-May-93): 2nd argument KEYFUN is called with a message number, and should return a key." 1.26 (rms 10-Feb-97): (save-current-buffer 1.16 (rms 24-Nov-93): ;; If we are in a summary buffer, operate on the Rmail buffer. 1.16 (rms 24-Nov-93): (if (eq major-mode 'rmail-summary-mode) 1.16 (rms 24-Nov-93): (set-buffer rmail-buffer)) 1.16 (rms 24-Nov-93): (let ((buffer-read-only nil) 1.26 (rms 10-Feb-97): (point-offset (- (point) (point-min))) 1.16 (rms 24-Nov-93): (predicate nil) ;< or string-lessp 1.16 (rms 24-Nov-93): (sort-lists nil)) 1.16 (rms 24-Nov-93): (message "Finding sort keys...") 1.16 (rms 24-Nov-93): (widen) 1.16 (rms 24-Nov-93): (let ((msgnum 1)) 1.16 (rms 24-Nov-93): (while (>= rmail-total-messages msgnum) 1.16 (rms 24-Nov-93): (setq sort-lists 1.16 (rms 24-Nov-93): (cons (list (funcall keyfun msgnum) ;Make sorting key 1.16 (rms 24-Nov-93): (eq rmail-current-message msgnum) ;True if current 1.16 (rms 24-Nov-93): (aref rmail-message-vector msgnum) 1.16 (rms 24-Nov-93): (aref rmail-message-vector (1+ msgnum))) 1.16 (rms 24-Nov-93): sort-lists)) 1.16 (rms 24-Nov-93): (if (zerop (% msgnum 10)) 1.16 (rms 24-Nov-93): (message "Finding sort keys...%d" msgnum)) 1.16 (rms 24-Nov-93): (setq msgnum (1+ msgnum)))) 1.16 (rms 24-Nov-93): (or reverse (setq sort-lists (nreverse sort-lists))) 1.16 (rms 24-Nov-93): ;; Decide predicate: < or string-lessp 1.16 (rms 24-Nov-93): (if (numberp (car (car sort-lists))) ;Is a key numeric? 1.16 (rms 24-Nov-93): (setq predicate (function <)) 1.16 (rms 24-Nov-93): (setq predicate (function string-lessp))) 1.16 (rms 24-Nov-93): (setq sort-lists 1.16 (rms 24-Nov-93): (sort sort-lists 1.16 (rms 24-Nov-93): (function 1.16 (rms 24-Nov-93): (lambda (a b) 1.16 (rms 24-Nov-93): (funcall predicate (car a) (car b)))))) 1.16 (rms 24-Nov-93): (if reverse (setq sort-lists (nreverse sort-lists))) 1.16 (rms 24-Nov-93): ;; Now we enter critical region. So, keyboard quit is disabled. 1.16 (rms 24-Nov-93): (message "Reordering messages...") 1.16 (rms 24-Nov-93): (let ((inhibit-quit t) ;Inhibit quit 1.16 (rms 24-Nov-93): (current-message nil) 1.16 (rms 24-Nov-93): (msgnum 1) 1.16 (rms 24-Nov-93): (msginfo nil)) 1.16 (rms 24-Nov-93): ;; There's little hope that we can easily undo after that. 1.20 (kwzh 30-Mar-94): (buffer-disable-undo (current-buffer)) 1.16 (rms 24-Nov-93): (goto-char (rmail-msgbeg 1)) 1.16 (rms 24-Nov-93): ;; To force update of all markers. 1.16 (rms 24-Nov-93): (insert-before-markers ?Z) 1.16 (rms 24-Nov-93): (backward-char 1) 1.16 (rms 24-Nov-93): ;; Now reorder messages. 1.16 (rms 24-Nov-93): (while sort-lists 1.16 (rms 24-Nov-93): (setq msginfo (car sort-lists)) 1.16 (rms 24-Nov-93): ;; Swap two messages. 1.16 (rms 24-Nov-93): (insert-buffer-substring 1.16 (rms 24-Nov-93): (current-buffer) (nth 2 msginfo) (nth 3 msginfo)) 1.16 (rms 24-Nov-93): (delete-region (nth 2 msginfo) (nth 3 msginfo)) 1.16 (rms 24-Nov-93): ;; Is current message? 1.16 (rms 24-Nov-93): (if (nth 1 msginfo) 1.16 (rms 24-Nov-93): (setq current-message msgnum)) 1.16 (rms 24-Nov-93): (setq sort-lists (cdr sort-lists)) 1.16 (rms 24-Nov-93): (if (zerop (% msgnum 10)) 1.16 (rms 24-Nov-93): (message "Reordering messages...%d" msgnum)) 1.16 (rms 24-Nov-93): (setq msgnum (1+ msgnum))) 1.16 (rms 24-Nov-93): ;; Delete the garbage inserted before. 1.16 (rms 24-Nov-93): (delete-char 1) 1.16 (rms 24-Nov-93): (setq quit-flag nil) 1.16 (rms 24-Nov-93): (buffer-enable-undo) 1.16 (rms 24-Nov-93): (rmail-set-message-counters) 1.19 (kwzh 30-Mar-94): (rmail-show-message current-message) 1.26 (rms 10-Feb-97): (goto-char (+ point-offset (point-min))) 1.19 (kwzh 30-Mar-94): (if (rmail-summary-exists) 1.19 (kwzh 30-Mar-94): (rmail-select-summary 1.19 (kwzh 30-Mar-94): (rmail-update-summary))))))) 1.14 (rms 26-May-93): 1.1 (rms 10-Sep-90): (defun rmail-fetch-field (msg field) 1.14 (rms 26-May-93): "Return the value of the header FIELD of MSG. 1.1 (rms 10-Sep-90): Arguments are MSG and FIELD." 1.14 (rms 26-May-93): (save-restriction 1.14 (rms 26-May-93): (widen) 1.14 (rms 26-May-93): (let ((next (rmail-msgend msg))) 1.1 (rms 10-Sep-90): (goto-char (rmail-msgbeg msg)) 1.1 (rms 10-Sep-90): (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t) 1.1 (rms 10-Sep-90): (point) 1.1 (rms 10-Sep-90): (forward-line 1) 1.1 (rms 10-Sep-90): (point)) 1.1 (rms 10-Sep-90): (progn (search-forward "\n\n" nil t) (point))) 1.1 (rms 10-Sep-90): (mail-fetch-field field)))) 1.1 (rms 10-Sep-90): 1.14 (rms 26-May-93): (defun rmail-make-date-sortable (date) 1.14 (rms 26-May-93): "Make DATE sortable using the function string-lessp." 1.14 (rms 26-May-93): ;; Assume the default time zone is GMT. 1.14 (rms 26-May-93): (timezone-make-date-sortable date "GMT" "GMT")) 1.6 (jimb 16-Mar-92): 1.6 (jimb 16-Mar-92): (provide 'rmailsort) 1.7 (eric 30-May-92): 1.38 (monnier 10-Apr-08): ;; arch-tag: 0d90896b-0c35-46ac-b240-38be5ada2360 1.7 (eric 30-May-92): ;;; rmailsort.el ends here