home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / gnus-speedups.el < prev    next >
Encoding:
Text File  |  1992-11-12  |  6.6 KB  |  207 lines
  1. ;;;;;
  2. ;; LCD Archive Entry:
  3. ;; gnus-speedups|Felix Lee|flee@cs.psu.edu|
  4. ;; Simple performance enhancements for GNUS|
  5. ;; 1992-13-11|1.6: stable|~/misc/gnus-speedups.Z|
  6.  
  7. ;; This package contains two plug-compatible performance enhancements
  8. ;; for GNUS 3.13 and 3.14:
  9.  
  10. ;; 1. Faster subject and date sorting in the *Subject* buffer.
  11.  
  12. ;; 2. Functions that implement faster set operations on group lists,
  13. ;; which make startup and saving faster.
  14.  
  15. ;; This file must be loaded after "gnus.el".  Loading this instead of
  16. ;; "gnus.el" will also work fine.  A GNUS maintainer will want to add
  17. ;; this at the end of the local gnus wrapper.
  18.  
  19. (require 'gnus)
  20. (provide 'gnus-speedups)
  21.  
  22. ;;;;;
  23. ;; 1. Faster subject and date sorting in the *Subject* buffer.
  24.  
  25. ;; The basic idea is explained in 'gnus-keyed-sort.
  26.  
  27. " Sample hook usage:
  28.  
  29. To automatically sort a newsgroup by subject:
  30. (setq gnus-Select-group-hook 'gnus-sort-headers-by-subject)
  31.  
  32. To automatically sort by subject and date:
  33. (setq gnus-Select-group-hook
  34.       (function
  35.        (lambda ()
  36.      (gnus-sort-headers-by-date)
  37.      (gnus-sort-headers-by-subject)
  38.      )))
  39. "
  40. ;; XXX These examples should be put in the doc for gnus-Select-group-hook
  41.  
  42. (defun gnus-keyed-sort (list compare extract)
  43.   "Sort LIST stably and return the sorted list.  Does not modify LIST.
  44. Arguments are (LIST COMPARE EXTRACT).  Elements in the list are
  45. compared as if the predicate were:
  46.     (COMPARE (EXTRACT a) (EXTRACT b))
  47. but EXTRACT is run over each element of the list in a preprocessing
  48. stage for efficiency.  This reduces the number of EXTRACT calls from
  49. O(N log N) to O(N).
  50.  
  51. Example: (gnus-keyed-sort load-path 'string< 'downcase)
  52. "
  53.   (let ( (keyed-list
  54.       (mapcar
  55.        (function (lambda (it) (cons (funcall extract it) it)))
  56.        list)) )
  57.     (setq keyed-list
  58.       (sort keyed-list
  59.         (function
  60.          (lambda (a b) (funcall compare (car a) (car b))))))
  61.     (mapcar (function (lambda (it) (cdr it)))
  62.         keyed-list)
  63.     ))
  64.  
  65. (defun gnus-keyed-sort-headers (compare extract &optional reverse)
  66.   "Sort current group's headers by COMPARE and EXTRACT.  Sorting is
  67. done as if the predicate were
  68.     (COMPARE (EXTRACT a) (EXTRACT b))
  69. See 'gnus-keyed-sort for more detailed description.
  70. Optional argument REVERSE means reverse the sense of the sort.
  71. Note: interrupting the sort leaves the headers unsorted.
  72. "
  73.   (setq gnus-newsgroup-headers
  74.     (gnus-keyed-sort gnus-newsgroup-headers compare extract))
  75.   (if reverse
  76.       (setq gnus-newsgroup-headers (nreverse gnus-newsgroup-headers)))
  77.   )
  78.  
  79. ;; For backward compatibility with GNUS 3.13
  80. ;; XXX (eval-and-compile ...)
  81. (if (not (fboundp 'gnus-sortable-date))
  82.     (fset 'gnus-sortable-date 'gnus-comparable-date))
  83.  
  84. (defun gnus-sort-headers-by-date (&optional reverse)
  85.   "Sort the current group by date.  Optional argument REVERSE means
  86. reverse order.  Does not redisplay the *Subject* buffer.  See also
  87. 'gnus-Subject-sort-by-date.
  88. "
  89.   (gnus-keyed-sort-headers
  90.    (function string<)
  91.    (function
  92.     (lambda (it)
  93.       (gnus-sortable-date (nntp-header-date it))))
  94.    reverse))
  95.  
  96. ;; XXX It should be 'gnus-sort-fold-case, not 'case-fold-search
  97. (defun gnus-sort-headers-by-subject (&optional reverse)
  98.   "Sort the current group by subject.  \"Re:\"s are ignored.  If
  99. 'case-fold-search is non-nil, then capitalization is ignored.
  100. Optional argument REVERSE means reverse order.  Does not redisplay the
  101. *Subject* buffer.  See also 'gnus-Subject-sort-by-subject.
  102. "
  103.   ;; The main complication here is we try to speed up the sort process
  104.   ;; by hoisting conditions outside the sort.
  105.   (gnus-keyed-sort-headers
  106.    (function string<)
  107.    (if case-fold-search
  108.        (function
  109.     (lambda (it)
  110.       (downcase (gnus-simplify-subject (nntp-header-subject it) 're-only))))
  111.      (function
  112.       (lambda (it)
  113.     (gnus-simplify-subject (nntp-header-subject it) 're-only)))
  114.      )
  115.    reverse)
  116.   )
  117.  
  118. (defun gnus-Subject-sort-by-subject (reverse)
  119.   "Sort the *Subject* buffer by subject.  With a prefix argument,
  120. reverse the order of the sort.  Uses 'gnus-sort-headers-by-subject.
  121. "
  122.   (interactive "P")
  123.   (let ( (current (gnus-Subject-article-number)) )
  124.     (gnus-sort-headers-by-subject reverse)
  125.     (gnus-Subject-prepare)
  126.     (gnus-Subject-goto-subject current)
  127.     ))
  128.  
  129. (defun gnus-Subject-sort-by-date (&optional reverse)
  130.   "Sort the *Subject* buffer by date.  With a prefix argument, reverse
  131. the order of the sort.  Uses 'gnus-sort-headers-by-date.
  132. "
  133.   (interactive "P")
  134.   (let ( (current (gnus-Subject-article-number)) )
  135.     (gnus-sort-headers-by-date reverse)
  136.     (gnus-Subject-prepare)
  137.     (gnus-Subject-goto-subject current)
  138.     ))
  139.  
  140.  
  141. ;;;;;
  142. ;; 2. Functions that implement faster set operations on group lists,
  143. ;; which make startup and saving faster.
  144.  
  145. ;; We reduce an O(N**2) process to O(N) by building a hash table for
  146. ;; the list of known newsgroups.  (It's a little strange that GNUS
  147. ;; doesn't already have a hash table for this.)
  148.  
  149. ;; XXX hash table size should be self-adjusting.
  150.  
  151. (defun gnus-option-n-filter (group-name)
  152.   "Does GROUP-NAME fit the constraints imposed by an -n option in
  153. the newsrc file?"
  154.   (or (null gnus-newsrc-options-n-no)
  155.       (not (string-match gnus-newsrc-options-n-no group-name))
  156.       (and gnus-newsrc-options-n-yes
  157.        (string-match gnus-newsrc-options-n-yes group-name)))
  158.   )
  159.  
  160. (defun gnus-find-new-newsgroups ()
  161.   "Look for new newsgroups and return names.
  162. `-n' option of options line in .newsrc file is recognized."
  163.   (let ( (group-name nil)
  164.      (new-groups nil)
  165.      (known-groups (make-vector 1031 0)) )
  166.     ;; Build a table of known newsgroups.
  167.     (mapcar
  168.      (function (lambda (group) (gnus-sethash (car group) t known-groups)))
  169.      gnus-killed-assoc)
  170.     (mapcar
  171.      (function (lambda (group) (gnus-sethash (car group) t known-groups)))
  172.      gnus-newsrc-assoc)
  173.     ;; Compare the active file against what's known.
  174.     (mapatoms
  175.      (function
  176.       (lambda (sym)
  177.     (setq group-name (symbol-name sym))
  178.     (and (gnus-option-n-filter group-name)
  179.          (null (gnus-gethash group-name known-groups))
  180.          (setq new-groups (cons group-name new-groups)))
  181.     ))
  182.      gnus-active-hashtb)
  183.     new-groups
  184.     ))
  185.  
  186. (defun gnus-check-killed-newsgroups ()
  187.   "Check consistency between gnus-newsrc-assoc and gnus-killed-assoc."
  188.   (let ( (active-groups (make-vector 1031 0))
  189.      (old-killed gnus-killed-assoc)
  190.      (new-killed nil)
  191.      (group-name nil) )
  192.     ;; Build a table of active newsgroups.
  193.     (mapcar
  194.      (function (lambda (group) (gnus-sethash (car group) t active-groups)))
  195.      gnus-newsrc-assoc)
  196.     ;; Filter the list.
  197.     (while old-killed
  198.       (setq group-name (car (car old-killed)))
  199.       (and (gnus-option-n-filter group-name)
  200.        (null (gnus-gethash group-name active-groups))
  201.        (setq new-killed (cons (car old-killed) new-killed)))
  202.       (setq old-killed (cdr old-killed))
  203.       )
  204.     (setq gnus-killed-assoc (nreverse new-killed))
  205.     ))
  206.  
  207.