home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / r / rm-sort.zip / RM-SORT.EL < prev   
Lisp/Scheme  |  1993-03-25  |  10KB  |  277 lines
  1. ;;; Rmail: sort messages
  2. ;; Copyright (C) 1990, 1992 Masanobu UMEDA (umerin@mse.kyutech.ac.jp)
  3. ;; $Header: rmailsort.el,v 1.4 93/01/26 12:11:29 umerin Locked $
  4.  
  5. ;; LCD Archive Entry:
  6. ;; rmailsort|Masanobu UMEDA|umerin@mse.kyutech.ac.jp|
  7. ;; Rmail: sort messages.|
  8. ;; 1993-01-26|1.4|~/misc/rmailsort.el.Z|
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  14. ;; accepts responsibility to anyone for the consequences of using it
  15. ;; or for whether it serves any particular purpose or works at all,
  16. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  17. ;; License for full details.
  18.  
  19. ;; Everyone is granted permission to copy, modify and redistribute
  20. ;; GNU Emacs, but only under the conditions described in the
  21. ;; GNU Emacs General Public License.   A copy of this license is
  22. ;; supposed to have been given to you along with GNU Emacs so you
  23. ;; can know your rights and responsibilities.  It should be in a
  24. ;; file named COPYING.  Among other things, the copyright notice
  25. ;; and this notice must be preserved on all copies.
  26.  
  27. ;; I would like to thank bob_weiner@pts.mot.com and
  28. ;; bruno@yakima.inria.fr for their improvements.
  29.  
  30. (provide 'rmailsort)
  31. (require 'rmail)
  32. (require 'sort)
  33.  
  34. (autoload 'timezone-make-date-sortable "timezone")
  35.  
  36. ;; GNUS compatible key bindings.
  37.  
  38. (define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date)
  39. (define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
  40. (define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author)
  41. (define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient)
  42. (define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-lines)
  43.  
  44. ;; Key binding may not be installed unless Rmail Summary mode is loaded.
  45. (if (boundp 'rmail-summary-mode-map)
  46.     (progn
  47.       (define-key rmail-summary-mode-map
  48.     "\C-c\C-s\C-d" 'rmail-summary-sort-by-date)
  49.       (define-key rmail-summary-mode-map
  50.     "\C-c\C-s\C-s" 'rmail-summary-sort-by-subject)
  51.       (define-key rmail-summary-mode-map
  52.     "\C-c\C-s\C-a" 'rmail-summary-sort-by-author)
  53.       (define-key rmail-summary-mode-map
  54.     "\C-c\C-s\C-r" 'rmail-summary-sort-by-recipient)
  55.       (define-key rmail-summary-mode-map
  56.     "\C-c\C-s\C-l" 'rmail-summary-sort-by-lines)
  57.       ))
  58.  
  59.  
  60. ;; Sorting messages in Rmail buffer
  61.  
  62. (defun rmail-sort-by-date (reverse)
  63.   "Sort messages of current Rmail file by date.
  64. If prefix argument REVERSE is non-nil, sort them in reverse order."
  65.   (interactive "P")
  66.   (rmail-sort-messages reverse
  67.                (function
  68.             (lambda (msg)
  69.               (rmail-make-date-sortable
  70.                (rmail-fetch-field msg "Date"))))))
  71.  
  72. (defun rmail-sort-by-subject (reverse)
  73.   "Sort messages of current Rmail file by subject.
  74. If prefix argument REVERSE is non-nil, sort them in reverse order."
  75.   (interactive "P")
  76.   (rmail-sort-messages reverse
  77.                (function
  78.             (lambda (msg)
  79.               (let ((key (or (rmail-fetch-field msg "Subject") ""))
  80.                 (case-fold-search t))
  81.                 ;; Remove `Re:'
  82.                 (if (string-match "^\\(re:[ \t]+\\)*" key)
  83.                 (substring key (match-end 0)) key))))))
  84.  
  85. (defun rmail-sort-by-author (reverse)
  86.   "Sort messages of current Rmail file by author.
  87. If prefix argument REVERSE is non-nil, sort them in reverse order."
  88.   (interactive "P")
  89.   (rmail-sort-messages reverse
  90.                (function
  91.             (lambda (msg)
  92.               (downcase    ;Canonical name
  93.                (mail-strip-quoted-names
  94.                 (or (rmail-fetch-field msg "From")
  95.                 (rmail-fetch-field msg "Sender") "")))))))
  96.  
  97. (defun rmail-sort-by-recipient (reverse)
  98.   "Sort messages of current Rmail file by recipient.
  99. If prefix argument REVERSE is non-nil, sort them in reverse order."
  100.   (interactive "P")
  101.   (rmail-sort-messages reverse
  102.                (function
  103.             (lambda (msg)
  104.               (downcase    ;Canonical name
  105.                (mail-strip-quoted-names
  106.                 (or (rmail-fetch-field msg "To")
  107.                 (rmail-fetch-field msg "Apparently-To") "")
  108.                 ))))))
  109.  
  110. (defun rmail-sort-by-lines (reverse)
  111.   "Sort messages of current Rmail file by lines of the message.
  112. If prefix argument REVERSE is non-nil, sort them in reverse order."
  113.   (interactive "P")
  114.   ;; Basic ideas by pinard@IRO.UMontreal.CA
  115.   (rmail-sort-messages reverse
  116.                (function
  117.             (lambda (msg)
  118.               (count-lines (rmail-msgbeg msgnum)
  119.                        (rmail-msgend msgnum))))))
  120.  
  121. ;; Sorting messages in Rmail Summary buffer.
  122.  
  123. (defun rmail-summary-sort-by-date (reverse)
  124.   "Sort messages of current Rmail summary by date.
  125. If prefix argument REVERSE is non-nil, sort them in reverse order."
  126.   (interactive "P")
  127.   (rmail-sort-from-summary (function rmail-sort-by-date) reverse))
  128.  
  129. (defun rmail-summary-sort-by-subject (reverse)
  130.   "Sort messages of current Rmail summary by subject.
  131. If prefix argument REVERSE is non-nil, sort them in reverse order."
  132.   (interactive "P")
  133.   (rmail-sort-from-summary (function rmail-sort-by-subject) reverse))
  134.  
  135. (defun rmail-summary-sort-by-author (reverse)
  136.   "Sort messages of current Rmail summary by author.
  137. If prefix argument REVERSE is non-nil, sort them in reverse order."
  138.   (interactive "P")
  139.   (rmail-sort-from-summary (function rmail-sort-by-author) reverse))
  140.  
  141. (defun rmail-summary-sort-by-recipient (reverse)
  142.   "Sort messages of current Rmail summary by recipient.
  143. If prefix argument REVERSE is non-nil, sort them in reverse order."
  144.   (interactive "P")
  145.   (rmail-sort-from-summary (function rmail-sort-by-recipient) reverse))
  146.  
  147. (defun rmail-summary-sort-by-lines (reverse)
  148.   "Sort messages of current Rmail summary by lines of the message.
  149. If prefix argument REVERSE is non-nil, sort them in reverse order."
  150.   (interactive "P")
  151.   (rmail-sort-from-summary (function rmail-sort-by-lines) reverse))
  152.  
  153.  
  154. ;; Basic functions
  155.  
  156. (defun rmail-sort-messages (reverse keyfun)
  157.   "Sort messages of current Rmail file.
  158. If 1st argument REVERSE is non-nil, sort them in reverse order.
  159. 2nd argument KEYFUN is called with a message number, and should return a key."
  160.   (let ((buffer-read-only nil)
  161.     (predicate nil)            ;< or string-lessp
  162.     (sort-lists nil))
  163.     (message "Finding sort keys...")
  164.     (widen)
  165.     (let ((msgnum 1))
  166.       (while (>= rmail-total-messages msgnum)
  167.     (setq sort-lists
  168.           (cons (list (funcall keyfun msgnum) ;Make sorting key
  169.               (eq rmail-current-message msgnum) ;True if current
  170.               (aref rmail-message-vector msgnum)
  171.               (aref rmail-message-vector (1+ msgnum)))
  172.             sort-lists))
  173.     (if (zerop (% msgnum 10))
  174.         (message "Finding sort keys...%d" msgnum))
  175.     (setq msgnum (1+ msgnum))))
  176.     (or reverse (setq sort-lists (nreverse sort-lists)))
  177.     ;; Decide predicate: < or string-lessp
  178.     (if (numberp (car (car sort-lists))) ;Is a key numeric?
  179.     (setq predicate (function <))
  180.       (setq predicate (function string-lessp)))
  181.     (setq sort-lists
  182.       (sort sort-lists
  183.         (function
  184.          (lambda (a b)
  185.            (funcall predicate (car a) (car b))))))
  186.     (if reverse (setq sort-lists (nreverse sort-lists)))
  187.     ;; Now we enter critical region.  So, keyboard quit is disabled.
  188.     (message "Reordering messages...")
  189.     (let ((inhibit-quit t)        ;Inhibit quit
  190.       (current-message nil)
  191.       (msgnum 1)
  192.       (msginfo nil))
  193.       ;; There's little hope that we can easily undo after that.
  194.       (buffer-flush-undo (current-buffer))
  195.       (goto-char (rmail-msgbeg 1))
  196.       ;; To force update of all markers.
  197.       (insert-before-markers ?Z)
  198.       (backward-char 1)
  199.       ;; Now reorder messages.
  200.       (while sort-lists
  201.     (setq msginfo (car sort-lists))
  202.     ;; Swap two messages.
  203.     (insert-buffer-substring
  204.      (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
  205.     (delete-region  (nth 2 msginfo) (nth 3 msginfo))
  206.     ;; Is current message?
  207.     (if (nth 1 msginfo)
  208.         (setq current-message msgnum))
  209.     (setq sort-lists (cdr sort-lists))
  210.     (if (zerop (% msgnum 10))
  211.         (message "Reordering messages...%d" msgnum))
  212.     (setq msgnum (1+ msgnum)))
  213.       ;; Delete the garbage inserted before.
  214.       (delete-char 1)
  215.       (setq quit-flag nil)
  216.       (buffer-enable-undo)
  217.       (rmail-set-message-counters)
  218.       (rmail-show-message current-message))
  219.     ))
  220.  
  221. (defun rmail-sort-from-summary (sortfun reverse)
  222.   "Sort Rmail messages from Summary buffer and update it after sorting."
  223.   (pop-to-buffer rmail-buffer)
  224.   (funcall sortfun reverse)
  225.   (rmail-summary))
  226.  
  227. (defun rmail-fetch-field (msg field)
  228.   "Return the value of the header FIELD of MSG.
  229. Arguments are MSG and FIELD."
  230.   (save-restriction
  231.     (widen)
  232.     (let ((next (rmail-msgend msg)))
  233.       (goto-char (rmail-msgbeg msg))
  234.       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
  235.                 (point)
  236.               (forward-line 1)
  237.               (point))
  238.             (progn (search-forward "\n\n" nil t) (point)))
  239.       (mail-fetch-field field))))
  240.  
  241. (defun rmail-make-date-sortable (date)
  242.   "Make DATE sortable using the function string-lessp."
  243.   ;; Assume the default time zone is GMT.
  244.   (timezone-make-date-sortable date "GMT" "GMT"))
  245.  
  246. ;; Copy of the function gnus-comparable-date in gnus.el version 3.13
  247. ;
  248. ;(defun rmail-make-date-sortable (date)
  249. ;  "Make sortable string by string-lessp from DATE."
  250. ;  (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
  251. ;         ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
  252. ;         ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
  253. ;         ("OCT" . "10")("NOV" . "11")("DEC" . "12")))
  254. ;    (date (or date "")))
  255. ;    ;; Can understand the following styles:
  256. ;    ;; (1) 14 Apr 89 03:20:12 GMT
  257. ;    ;; (2) Fri, 17 Mar 89 4:01:33 GMT
  258. ;    (if (string-match
  259. ;     "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9:]+\\)" date)
  260. ;    (concat
  261. ;     ;; Year
  262. ;     (substring date (match-beginning 3) (match-end 3))
  263. ;     ;; Month
  264. ;     (cdr
  265. ;      (assoc
  266. ;       (upcase (substring date (match-beginning 2) (match-end 2))) month))
  267. ;     ;; Day
  268. ;     (format "%2d" (string-to-int
  269. ;            (substring date
  270. ;                   (match-beginning 1) (match-end 1))))
  271. ;     ;; Time
  272. ;     (substring date (match-beginning 4) (match-end 4)))
  273. ;      ;; Cannot understand DATE string.
  274. ;      date
  275. ;      )
  276. ;    ))
  277.