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