home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 31 / CDASC_31_1996_juillet_aout.iso / vrac_os2 / e31el3.zip / EMACS / 19.31 / LISP / RMAILSOR.EL < prev    next >
Lisp/Scheme  |  1996-02-17  |  8KB  |  239 lines
  1. ;;; rmailsort.el --- Rmail: sort messages.
  2.  
  3. ;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
  6. ;; Version: $Header: /home/gd/gnu/emacs/19.0/lisp/RCS/rmailsort.el,v 1.24 1996/01/20 07:41:37 kwzh Exp $
  7. ;; Keywords: mail
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Code:
  27.  
  28. (require 'sort)
  29.  
  30. ;; For rmail-select-summary
  31. (require 'rmail)
  32.  
  33. (autoload 'timezone-make-date-sortable "timezone")
  34.  
  35. ;; Sorting messages in Rmail buffer
  36.  
  37. (defun rmail-sort-by-date (reverse)
  38.   "Sort messages of current Rmail file by date.
  39. If prefix argument REVERSE is non-nil, sort them in reverse order."
  40.   (interactive "P")
  41.   (rmail-sort-messages reverse
  42.                (function
  43.             (lambda (msg)
  44.               (rmail-make-date-sortable
  45.                (rmail-fetch-field msg "Date"))))))
  46.  
  47. (defun rmail-sort-by-subject (reverse)
  48.   "Sort messages of current Rmail file by subject.
  49. If prefix argument REVERSE is non-nil, sort them in reverse order."
  50.   (interactive "P")
  51.   (rmail-sort-messages reverse
  52.                (function
  53.             (lambda (msg)
  54.               (let ((key (or (rmail-fetch-field msg "Subject") ""))
  55.                 (case-fold-search t))
  56.                 ;; Remove `Re:'
  57.                 (if (string-match "^\\(re:[ \t]*\\)*" key)
  58.                 (substring key (match-end 0))
  59.                   key))))))
  60.  
  61. (defun rmail-sort-by-author (reverse)
  62.   "Sort messages of current Rmail file by author.
  63. If prefix argument REVERSE is non-nil, sort them in reverse order."
  64.   (interactive "P")
  65.   (rmail-sort-messages reverse
  66.                (function
  67.             (lambda (msg)
  68.               (downcase    ;Canonical name
  69.                (mail-strip-quoted-names
  70.                 (or (rmail-fetch-field msg "From")
  71.                 (rmail-fetch-field msg "Sender") "")))))))
  72.  
  73. (defun rmail-sort-by-recipient (reverse)
  74.   "Sort messages of current Rmail file by recipient.
  75. If prefix argument REVERSE is non-nil, sort them in reverse order."
  76.   (interactive "P")
  77.   (rmail-sort-messages reverse
  78.                (function
  79.             (lambda (msg)
  80.               (downcase    ;Canonical name
  81.                (mail-strip-quoted-names
  82.                 (or (rmail-fetch-field msg "To")
  83.                 (rmail-fetch-field msg "Apparently-To") "")
  84.                 ))))))
  85.  
  86. (defun rmail-sort-by-correspondent (reverse)
  87.   "Sort messages of current Rmail file by other correspondent.
  88. If prefix argument REVERSE is non-nil, sort them in reverse order."
  89.   (interactive "P")
  90.   (rmail-sort-messages reverse
  91.                (function
  92.             (lambda (msg)
  93.               (rmail-select-correspondent
  94.                msg
  95.                '("From" "Sender" "To" "Apparently-To"))))))
  96.  
  97. (defun rmail-select-correspondent (msg fields)
  98.   (let ((ans ""))
  99.     (while (and fields (string= ans ""))
  100.       (setq ans
  101.         (rmail-dont-reply-to
  102.          (mail-strip-quoted-names
  103.           (or (rmail-fetch-field msg (car fields)) ""))))
  104.       (setq fields (cdr fields)))
  105.     ans))
  106.  
  107. (defun rmail-sort-by-lines (reverse)
  108.   "Sort messages of current Rmail file by number of lines.
  109. If prefix argument REVERSE is non-nil, sort them in reverse order."
  110.   (interactive "P")
  111.   (rmail-sort-messages reverse
  112.                (function
  113.             (lambda (msg)
  114.               (count-lines (rmail-msgbeg msg)
  115.                        (rmail-msgend msg))))))
  116.  
  117. (defun rmail-sort-by-keywords (reverse labels)
  118.   "Sort messages of current Rmail file by labels.
  119. If prefix argument REVERSE is non-nil, sort them in reverse order.
  120. KEYWORDS is a comma-separated list of labels."
  121.   (interactive "P\nsSort by labels: ")
  122.   (or (string-match "[^ \t]" labels)
  123.       (error "No labels specified"))
  124.   (setq labels (concat (substring labels (match-beginning 0)) ","))
  125.   (let (labelvec)
  126.     (while (string-match "[ \t]*,[ \t]*" labels)
  127.       (setq labelvec (cons 
  128.               (concat ", ?\\("
  129.                   (substring labels 0 (match-beginning 0))
  130.                   "\\),")
  131.               labelvec))
  132.       (setq labels (substring labels (match-end 0))))
  133.     (setq labelvec (apply 'vector (nreverse labelvec)))
  134.     (rmail-sort-messages reverse
  135.              (function
  136.               (lambda (msg)
  137.                 (let ((n 0))
  138.                   (while (and (< n (length labelvec))
  139.                       (not (rmail-message-labels-p
  140.                         msg (aref labelvec n))))
  141.                 (setq n (1+ n)))
  142.                   n))))))
  143.  
  144. ;; Basic functions
  145.  
  146. (defun rmail-sort-messages (reverse keyfun)
  147.   "Sort messages of current Rmail file.
  148. If 1st argument REVERSE is non-nil, sort them in reverse order.
  149. 2nd argument KEYFUN is called with a message number, and should return a key."
  150.   (save-excursion
  151.     ;; If we are in a summary buffer, operate on the Rmail buffer.
  152.     (if (eq major-mode 'rmail-summary-mode)
  153.     (set-buffer rmail-buffer))
  154.     (let ((buffer-read-only nil)
  155.       (predicate nil)            ;< or string-lessp
  156.       (sort-lists nil))
  157.       (message "Finding sort keys...")
  158.       (widen)
  159.       (let ((msgnum 1))
  160.     (while (>= rmail-total-messages msgnum)
  161.       (setq sort-lists
  162.         (cons (list (funcall keyfun msgnum) ;Make sorting key
  163.                 (eq rmail-current-message msgnum) ;True if current
  164.                 (aref rmail-message-vector msgnum)
  165.                 (aref rmail-message-vector (1+ msgnum)))
  166.               sort-lists))
  167.       (if (zerop (% msgnum 10))
  168.           (message "Finding sort keys...%d" msgnum))
  169.       (setq msgnum (1+ msgnum))))
  170.       (or reverse (setq sort-lists (nreverse sort-lists)))
  171.       ;; Decide predicate: < or string-lessp
  172.       (if (numberp (car (car sort-lists))) ;Is a key numeric?
  173.       (setq predicate (function <))
  174.     (setq predicate (function string-lessp)))
  175.       (setq sort-lists
  176.         (sort sort-lists
  177.           (function
  178.            (lambda (a b)
  179.              (funcall predicate (car a) (car b))))))
  180.       (if reverse (setq sort-lists (nreverse sort-lists)))
  181.       ;; Now we enter critical region.  So, keyboard quit is disabled.
  182.       (message "Reordering messages...")
  183.       (let ((inhibit-quit t)        ;Inhibit quit
  184.         (current-message nil)
  185.         (msgnum 1)
  186.         (msginfo nil))
  187.     ;; There's little hope that we can easily undo after that.
  188.     (buffer-disable-undo (current-buffer))
  189.     (goto-char (rmail-msgbeg 1))
  190.     ;; To force update of all markers.
  191.     (insert-before-markers ?Z)
  192.     (backward-char 1)
  193.     ;; Now reorder messages.
  194.     (while sort-lists
  195.       (setq msginfo (car sort-lists))
  196.       ;; Swap two messages.
  197.       (insert-buffer-substring
  198.        (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
  199.       (delete-region  (nth 2 msginfo) (nth 3 msginfo))
  200.       ;; Is current message?
  201.       (if (nth 1 msginfo)
  202.           (setq current-message msgnum))
  203.       (setq sort-lists (cdr sort-lists))
  204.       (if (zerop (% msgnum 10))
  205.           (message "Reordering messages...%d" msgnum))
  206.       (setq msgnum (1+ msgnum)))
  207.     ;; Delete the garbage inserted before.
  208.     (delete-char 1)
  209.     (setq quit-flag nil)
  210.     (buffer-enable-undo)
  211.     (rmail-set-message-counters)
  212.     (rmail-show-message current-message)
  213.     (if (rmail-summary-exists)
  214.         (rmail-select-summary
  215.          (rmail-update-summary)))))))
  216.  
  217. (defun rmail-fetch-field (msg field)
  218.   "Return the value of the header FIELD of MSG.
  219. Arguments are MSG and FIELD."
  220.   (save-restriction
  221.     (widen)
  222.     (let ((next (rmail-msgend msg)))
  223.       (goto-char (rmail-msgbeg msg))
  224.       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
  225.                 (point)
  226.               (forward-line 1)
  227.               (point))
  228.             (progn (search-forward "\n\n" nil t) (point)))
  229.       (mail-fetch-field field))))
  230.  
  231. (defun rmail-make-date-sortable (date)
  232.   "Make DATE sortable using the function string-lessp."
  233.   ;; Assume the default time zone is GMT.
  234.   (timezone-make-date-sortable date "GMT" "GMT"))
  235.  
  236. (provide 'rmailsort)
  237.  
  238. ;;; rmailsort.el ends here
  239.