home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / rmailsort.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  8KB  |  235 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: /gd/gnu/emacs/19.0/lisp/RCS/rmailsort.el,v 1.22 1994/05/03 22:46: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
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Code:
  26.  
  27. (require 'sort)
  28.  
  29. (autoload 'timezone-make-date-sortable "timezone")
  30.  
  31. ;; Sorting messages in Rmail buffer
  32.  
  33. (defun rmail-sort-by-date (reverse)
  34.   "Sort messages of current Rmail file by date.
  35. If prefix argument REVERSE is non-nil, sort them in reverse order."
  36.   (interactive "P")
  37.   (rmail-sort-messages reverse
  38.                (function
  39.             (lambda (msg)
  40.               (rmail-make-date-sortable
  41.                (rmail-fetch-field msg "Date"))))))
  42.  
  43. (defun rmail-sort-by-subject (reverse)
  44.   "Sort messages of current Rmail file by subject.
  45. If prefix argument REVERSE is non-nil, sort them in reverse order."
  46.   (interactive "P")
  47.   (rmail-sort-messages reverse
  48.                (function
  49.             (lambda (msg)
  50.               (let ((key (or (rmail-fetch-field msg "Subject") ""))
  51.                 (case-fold-search t))
  52.                 ;; Remove `Re:'
  53.                 (if (string-match "^\\(re:[ \t]*\\)*" key)
  54.                 (substring key (match-end 0))
  55.                   key))))))
  56.  
  57. (defun rmail-sort-by-author (reverse)
  58.   "Sort messages of current Rmail file by author.
  59. If prefix argument REVERSE is non-nil, sort them in reverse order."
  60.   (interactive "P")
  61.   (rmail-sort-messages reverse
  62.                (function
  63.             (lambda (msg)
  64.               (downcase    ;Canonical name
  65.                (mail-strip-quoted-names
  66.                 (or (rmail-fetch-field msg "From")
  67.                 (rmail-fetch-field msg "Sender") "")))))))
  68.  
  69. (defun rmail-sort-by-recipient (reverse)
  70.   "Sort messages of current Rmail file by recipient.
  71. If prefix argument REVERSE is non-nil, sort them in reverse order."
  72.   (interactive "P")
  73.   (rmail-sort-messages reverse
  74.                (function
  75.             (lambda (msg)
  76.               (downcase    ;Canonical name
  77.                (mail-strip-quoted-names
  78.                 (or (rmail-fetch-field msg "To")
  79.                 (rmail-fetch-field msg "Apparently-To") "")
  80.                 ))))))
  81.  
  82. (defun rmail-sort-by-correspondent (reverse)
  83.   "Sort messages of current Rmail file by other correspondent.
  84. If prefix argument REVERSE is non-nil, sort them in reverse order."
  85.   (interactive "P")
  86.   (rmail-sort-messages reverse
  87.                (function
  88.             (lambda (msg)
  89.               (rmail-select-correspondent
  90.                msg
  91.                '("From" "Sender" "To" "Apparently-To"))))))
  92.  
  93. (defun rmail-select-correspondent (msg fields)
  94.   (let ((ans ""))
  95.     (while (and fields (string= ans ""))
  96.       (setq ans
  97.         (rmail-dont-reply-to
  98.          (mail-strip-quoted-names
  99.           (or (rmail-fetch-field msg (car fields)) ""))))
  100.       (setq fields (cdr fields)))
  101.     ans))
  102.  
  103. (defun rmail-sort-by-lines (reverse)
  104.   "Sort messages of current Rmail file by number of lines.
  105. If prefix argument REVERSE is non-nil, sort them in reverse order."
  106.   (interactive "P")
  107.   (rmail-sort-messages reverse
  108.                (function
  109.             (lambda (msg)
  110.               (count-lines (rmail-msgbeg msg)
  111.                        (rmail-msgend msg))))))
  112.  
  113. (defun rmail-sort-by-keywords (reverse labels)
  114.   "Sort messages of current Rmail file by labels.
  115. If prefix argument REVERSE is non-nil, sort them in reverse order.
  116. KEYWORDS is a comma-separated list of labels."
  117.   (interactive "P\nsSort by labels: ")
  118.   (or (string-match "[^ \t]" labels)
  119.       (error "No labels specified"))
  120.   (setq labels (concat (substring labels (match-beginning 0)) ","))
  121.   (let (labelvec)
  122.     (while (string-match "[ \t]*,[ \t]*" labels)
  123.       (setq labelvec (cons 
  124.               (concat ", ?\\("
  125.                   (substring labels 0 (match-beginning 0))
  126.                   "\\),")
  127.               labelvec))
  128.       (setq labels (substring labels (match-end 0))))
  129.     (setq labelvec (apply 'vector (nreverse labelvec)))
  130.     (rmail-sort-messages reverse
  131.              (function
  132.               (lambda (msg)
  133.                 (let ((n 0))
  134.                   (while (and (< n (length labelvec))
  135.                       (not (rmail-message-labels-p
  136.                         msg (aref labelvec n))))
  137.                 (setq n (1+ n)))
  138.                   n))))))
  139.  
  140. ;; Basic functions
  141.  
  142. (defun rmail-sort-messages (reverse keyfun)
  143.   "Sort messages of current Rmail file.
  144. If 1st argument REVERSE is non-nil, sort them in reverse order.
  145. 2nd argument KEYFUN is called with a message number, and should return a key."
  146.   (save-excursion
  147.     ;; If we are in a summary buffer, operate on the Rmail buffer.
  148.     (if (eq major-mode 'rmail-summary-mode)
  149.     (set-buffer rmail-buffer))
  150.     (let ((buffer-read-only nil)
  151.       (predicate nil)            ;< or string-lessp
  152.       (sort-lists nil))
  153.       (message "Finding sort keys...")
  154.       (widen)
  155.       (let ((msgnum 1))
  156.     (while (>= rmail-total-messages msgnum)
  157.       (setq sort-lists
  158.         (cons (list (funcall keyfun msgnum) ;Make sorting key
  159.                 (eq rmail-current-message msgnum) ;True if current
  160.                 (aref rmail-message-vector msgnum)
  161.                 (aref rmail-message-vector (1+ msgnum)))
  162.               sort-lists))
  163.       (if (zerop (% msgnum 10))
  164.           (message "Finding sort keys...%d" msgnum))
  165.       (setq msgnum (1+ msgnum))))
  166.       (or reverse (setq sort-lists (nreverse sort-lists)))
  167.       ;; Decide predicate: < or string-lessp
  168.       (if (numberp (car (car sort-lists))) ;Is a key numeric?
  169.       (setq predicate (function <))
  170.     (setq predicate (function string-lessp)))
  171.       (setq sort-lists
  172.         (sort sort-lists
  173.           (function
  174.            (lambda (a b)
  175.              (funcall predicate (car a) (car b))))))
  176.       (if reverse (setq sort-lists (nreverse sort-lists)))
  177.       ;; Now we enter critical region.  So, keyboard quit is disabled.
  178.       (message "Reordering messages...")
  179.       (let ((inhibit-quit t)        ;Inhibit quit
  180.         (current-message nil)
  181.         (msgnum 1)
  182.         (msginfo nil))
  183.     ;; There's little hope that we can easily undo after that.
  184.     (buffer-disable-undo (current-buffer))
  185.     (goto-char (rmail-msgbeg 1))
  186.     ;; To force update of all markers.
  187.     (insert-before-markers ?Z)
  188.     (backward-char 1)
  189.     ;; Now reorder messages.
  190.     (while sort-lists
  191.       (setq msginfo (car sort-lists))
  192.       ;; Swap two messages.
  193.       (insert-buffer-substring
  194.        (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
  195.       (delete-region  (nth 2 msginfo) (nth 3 msginfo))
  196.       ;; Is current message?
  197.       (if (nth 1 msginfo)
  198.           (setq current-message msgnum))
  199.       (setq sort-lists (cdr sort-lists))
  200.       (if (zerop (% msgnum 10))
  201.           (message "Reordering messages...%d" msgnum))
  202.       (setq msgnum (1+ msgnum)))
  203.     ;; Delete the garbage inserted before.
  204.     (delete-char 1)
  205.     (setq quit-flag nil)
  206.     (buffer-enable-undo)
  207.     (rmail-set-message-counters)
  208.     (rmail-show-message current-message)
  209.     (if (rmail-summary-exists)
  210.         (rmail-select-summary
  211.          (rmail-update-summary)))))))
  212.  
  213. (defun rmail-fetch-field (msg field)
  214.   "Return the value of the header FIELD of MSG.
  215. Arguments are MSG and FIELD."
  216.   (save-restriction
  217.     (widen)
  218.     (let ((next (rmail-msgend msg)))
  219.       (goto-char (rmail-msgbeg msg))
  220.       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
  221.                 (point)
  222.               (forward-line 1)
  223.               (point))
  224.             (progn (search-forward "\n\n" nil t) (point)))
  225.       (mail-fetch-field field))))
  226.  
  227. (defun rmail-make-date-sortable (date)
  228.   "Make DATE sortable using the function string-lessp."
  229.   ;; Assume the default time zone is GMT.
  230.   (timezone-make-date-sortable date "GMT" "GMT"))
  231.  
  232. (provide 'rmailsort)
  233.  
  234. ;;; rmailsort.el ends here
  235.