home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / expire-kill.el < prev    next >
Encoding:
Text File  |  1993-05-07  |  29.4 KB  |  756 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         expire-kill.el
  5. ;; RCS:          $Id: expire-kill.el,v 2.3 1993/05/07 05:16:45 liblit Exp $
  6. ;; Description:  Expiring kill patterns for GNUS
  7. ;; Author:       Ben Liblit, liblit@cs.psu.edu
  8. ;; Created:      Wed Mar 2 1993
  9. ;; Modified:     Fri May  7 01:13:25 1993 (Ben) liblit@cs.psu.edu
  10. ;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. ;;; Copyright (C) 1993  Ben Liblit.
  14. ;;;
  15. ;;; Author: Ben Liblit (liblit@cs.psu.edu)
  16. ;;;
  17. ;;; This program is free software; you can redistribute it and/or
  18. ;;; modify it under the terms of the GNU General Public License as
  19. ;;; published by the Free Software Foundation; either version 1, or
  20. ;;; (at your option) any later version.
  21. ;;;
  22. ;;; This program is distributed in the hope that it will be useful,
  23. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25. ;;; General Public License for more details.
  26. ;;;
  27. ;;; A copy of the GNU General Public License can be obtained from this
  28. ;;; program's author (send electronic mail to liblit@cs.psu.edu) or
  29. ;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
  30. ;;; MA 02139, USA.
  31.  
  32. ;;; Description:
  33. ;;;
  34. ;;; This package augments the standard GNUS kill file mechanism to
  35. ;;; allow expiring kill patterns.  Time stamps may be stored with
  36. ;;; patterns, and if a pattern's time stamp indicates that it has not
  37. ;;; been matched in a long period of time, that pattern is removed.
  38.  
  39. ;;; Installation:
  40. ;;;
  41. ;;; Optionally byte-compile expire-kill.el to expire-kill.elc and put
  42. ;;; them both in a directory on your load-path.  To load expire-kill
  43. ;;; when GNUS first up, add the following to your .emacs:
  44. ;;;
  45. ;;;   (setq gnus-Startup-hook
  46. ;;;         '(lambda ()
  47. ;;;            (require 'expire-kill)))
  48. ;;;
  49. ;;; Autoloading based on the function "expire-kill" will *not* work
  50. ;;; properly, as expire-kill needs to hook itself into other parts of
  51. ;;; GNUS before the first kill file is loaded.
  52. ;;;
  53. ;;; Also, please note that expire-kill needs to use either Dave
  54. ;;; Gillespie's calc package or Edward Reingold's calendar package for
  55. ;;; performing date calculations.  The variable expire-date-package
  56. ;;; should be set to either 'calc or 'calendar, depending on which you
  57. ;;; wish to use.
  58.  
  59. ;;; Background and Motivation:
  60. ;;;
  61. ;;; The standard GNUS kill file mechanism is fairly powerful and
  62. ;;; flexible.  However, its usefulness is limited by the fact that
  63. ;;; kill patterns remain active indefinitely, unless manually removed
  64. ;;; by the user.  This makes certain uses of kill files highly
  65. ;;; impractical.
  66. ;;;
  67. ;;; For example, one might wish to use a subject-matching kill pattern
  68. ;;; to mark articles in a discussion thread that one is not interested
  69. ;;; in.  Using standard (gnus-kill ...), though, means that the
  70. ;;; pattern will remain in the kill file long after the thread itself
  71. ;;; has died out.  As time goes on, kill files will become bloated
  72. ;;; with patterns that have long ceased to be active.
  73. ;;;
  74. ;;; This package provides a time stamped alternative to "gnus-kill".
  75. ;;; The function "expire-kill" takes similar arguments, and performs
  76. ;;; the same function.  However, "expire-kill" also takes a time stamp
  77. ;;; argument (stored as a string) that indicates the last time its
  78. ;;; pattern was successfully matched.  Thus, instead of:
  79. ;;;
  80. ;;;   (gnus-kill "Subject" "cheese")
  81. ;;;
  82. ;;; in a kill file, one might see:
  83. ;;;
  84. ;;;   (expire-kill "Subject" "cheese" "<Tue Mar 2, 1993>")
  85. ;;;
  86. ;;; which would perform the same kill actions as "gnus-kill", but
  87. ;;; which additionally records that it hasn't actually seen a subject
  88. ;;; of "cheese" since March 2.
  89. ;;;
  90. ;;; A new method of applying kill files allows these time stamps to be
  91. ;;; updated when matches are made.  Other support functions sweep
  92. ;;; through a newsgroup's kill file and delete patterns that have not
  93. ;;; been matched in a long enough time (seven days, by default).
  94. ;;; Updated kill files are saved back to disk, or optionally deleted
  95. ;;; entirely if *all* their patterns have expired.
  96. ;;;
  97. ;;; Note that expire-kill is backward compatible with standard GNUS
  98. ;;; kill files.  Calls to "gnus-kill" and other elisp still work as
  99. ;;; before, and will never be expired.
  100.  
  101. ;;; Usage:
  102. ;;;
  103. ;;; To use this package, simply add calls to "expire-kill" to your
  104. ;;; GNUS kill files.  The first two arguments specify a header field
  105. ;;; and a regexp pattern, just as for "gnus-kill".  The third should
  106. ;;; be a string or integer that can be parsed into an initial time
  107. ;;; stamp.
  108. ;;;
  109. ;;; You should never need to construct these calls by hand, though.
  110. ;;; Instead, a suite of functions are provided that add calls, or
  111. ;;; portions of calls, for you.  All of these are suitable for calling
  112. ;;; via M-x, or for binding onto keys.  In fact, each function
  113. ;;; described below has a corresponding variable with the same name.
  114. ;;; If that variable is set to a string representing some sequence of
  115. ;;; keys, that key seuqence will be bound to evoke the corresponding
  116. ;;; function in the appropriate buffers.  These functions (and
  117. ;;; associated variables) are as follows:
  118. ;;;
  119. ;;;   - expire-Subject-kill-same-subject
  120. ;;;   - expire-Subject-kill-same-subject-and-select
  121. ;;;   - expire-Subject-kill-thread
  122. ;;;   - expire-Subject-kill-thread-and-select
  123. ;;;
  124. ;;; These functions should be used from the *Subject* buffer.  The
  125. ;;; first two functions add expiring kill patterns for the subject of
  126. ;;; the article at the cursor.  The second two functions add expiring
  127. ;;; kill patterns for followups to the article at the cursor.  All
  128. ;;; four functions mark any articles already in the *Subject* buffer
  129. ;;; that match their targets.  Furthermore, the "-and-select" forms
  130. ;;; immediately select the next unread article.
  131. ;;;
  132. ;;;   - expire-Kill-file-kill-by-subject
  133. ;;;   - expire-Kill-file-kill-by-thread
  134. ;;;
  135. ;;; These two functions may be used while editing a kill file.  They
  136. ;;; insert "expire-kill" calls to match the most recently seen subject
  137. ;;; and followups to the current article, respectively.
  138. ;;;
  139. ;;;   - expire-Kill-file-insert-time-stamp
  140. ;;;
  141. ;;; This function is also intended for use while editing kill files.
  142. ;;; It will insert a time stamp corresponding to the present time
  143. ;;; after the cursor.  This can be useful for finishing up hand
  144. ;;; written calls to "expire-kill".
  145. ;;;
  146. ;;; By default, expire-Subject-kill-same-subject-and-select is bound
  147. ;;; to "C-c C-k" and expire-Subject-kill-thread-and-select is bound to
  148. ;;; "C-c k", both in the *Subject* buffer.  None of the others are
  149. ;;; bound by default, although this may easily be customized by
  150. ;;; setting the same-named variable to the desired key sequence.
  151.  
  152. ;;; Known Bugs and Limitations:
  153. ;;;
  154. ;;; For simplicity's sake, empty (whitespace only) kill files are not
  155. ;;; deleted until the next time their newsgroup is selected.  It might
  156. ;;; be nicer to delete empties as soon as the last s-expression is removed.
  157. ;;;
  158. ;;; Some users symlink kill files, using one such file for several
  159. ;;; related newsgroups.  We try to do right by these users, not
  160. ;;; deleting empty kill files that are also symlinks.  However,
  161. ;;; patterns may tend to expire more quickly when a kill file is
  162. ;;; shared.  If a pattern doesn't match in one group, it can be
  163. ;;; expired before it even gets to look at a second group.
  164.  
  165. ;;; Acknowledgments:
  166. ;;;
  167. ;;; Thanks for release 2.x go out to the many users who were kind
  168. ;;; enough to discuss and suggest improvements over earlier releases.
  169. ;;; In particular, Dave Disser's insightful correspondence has
  170. ;;; inspired many of 2.x's enhancements.  Don Wells and Bill Oakley
  171. ;;; also deserve recognition for their suggestions, bug reports, and
  172. ;;; invaluable feedback.
  173.  
  174. ;;; LISPDIR ENTRY for the Elisp Archive
  175. ;;; 
  176. ;;;    LCD Archive Entry:
  177. ;;;    expire-kill|Ben Liblit|liblit@cs.psu.edu|
  178. ;;;    expiring kill patterns for GNUS|
  179. ;;;    7-May-1993|2.3|~/misc/expire-kill.el.Z|
  180.  
  181. ;;;; ------------------------------------------------------------
  182. ;;;; User customization variables.
  183. ;;;; ------------------------------------------------------------
  184.  
  185. (defvar expire-maximum-age 7
  186.   "*Longest time a pattern can go unmatched before being removed.
  187. The units on this measure are in days, and its value should be an
  188. integer.")
  189.  
  190.  
  191. (defvar expire-flush-frequency 'group
  192.   "*Determines how often modified kill file buffers are flushed.
  193. If set to the atom 'always, then flushing happens after every
  194. modification.  If set to 'group, then flushing occurs when you exit
  195. the current newsgroup.  If set to 'session, then modifications are
  196. flushed only when you exit GNUS itself.  Otherwise, no automatic
  197. actions are taken.
  198.  
  199. The variable expire-flush-action determines what it actually means to
  200. \"flush\" a modified kill file buffer.")
  201.  
  202.  
  203. (defvar expire-flush-action 'kill
  204.   "*Determines what to do with buffers of modified kill files.
  205. If set to the atom 'kill, then the modified buffer is saved and
  206. killed.  If set to 'save, then the modified buffer is saved, but is
  207. not killed.  Otherwise, no actions are taken.
  208.  
  209. The variable expire-flush-frequency determines how frequently the
  210. requested action is taken.")
  211.  
  212.  
  213. (defvar expire-Subject-kill-same-subject nil
  214.   "*Key sequence to which to bind the function of the same name.
  215. If set to a string representing a key sequence, that sequence will
  216. evoke the same-named function in the *Subject* buffer.  Otherwise, no
  217. binding will be made for this function.")
  218.  
  219. (defvar expire-Subject-kill-same-subject-and-select "\C-c\C-k"
  220.   "*Key sequence to which to bind the function of the same name.
  221. If set to a string representing a key sequence, that sequence will
  222. evoke the same-named function in the *Subject* buffer.  Otherwise, no
  223. binding will be made for this function.")
  224.  
  225. (defvar expire-Subject-kill-thread nil
  226.   "*Key sequence to which to bind the function of the same name.
  227. If set to a string representing a key sequence, that sequence will
  228. evoke the same-named function in the *Subject* buffer.  Otherwise, no
  229. binding will be made for this function.")
  230.  
  231. (defvar expire-Subject-kill-thread-and-select "\C-ck"
  232.   "*Key sequence to which to bind the function of the same name.
  233. If set to a string representing a key sequence, that sequence will
  234. evoke the same-named function in the *Subject* buffer.  Otherwise, no
  235. binding will be made for this function.")
  236.  
  237. (defvar expire-Kill-file-kill-by-subject "\C-c\C-x\C-s"
  238.   "*Key sequence to which to bind the function of the same name.
  239. If set to a string representing a key sequence, that sequence will
  240. evoke the same-named function in the kill file buffers.  Otherwise, no
  241. binding will be made for this function.")
  242.  
  243. (defvar expire-Kill-file-kill-by-thread "\C-c\C-x\C-t"
  244.   "*Key sequence to which to bind the function of the same name.
  245. If set to a string representing a key sequence, that sequence will
  246. evoke the same-named function in the kill file buffers.  Otherwise, no
  247. binding will be made for this function.")
  248.  
  249. (defvar expire-Kill-file-insert-time-stamp "\C-c\C-x\C-i"
  250.   "*Key sequence to which to bind the function of the same name.
  251. If set to a string representing a key sequence, that sequence will
  252. evoke the same-named function in the kill file buffers.  Otherwise, no
  253. binding will be made for this function.")
  254.  
  255.  
  256. (defvar expire-delete-empties 't
  257.   "*Determines whether or not empty kill files should be deleted.
  258. If set to the atom 'ask, then the user will be asked each time.  If
  259. set to some other non-nil value, then empties will be deleted
  260. automatically the first time they are applied to a newsgroup.  If nil,
  261. no deletions will be performed.")
  262.  
  263.  
  264. (defvar expire-kill-default-command '(gnus-Subject-mark-as-read nil "x")
  265.   "*Default command to be evaluated by expire-kill if none is given.
  266. This must be a lisp expression or a string representing a key sequence.")
  267.  
  268.  
  269. (defvar expire-after-apply-hook (function
  270.                  (lambda ()
  271.                    (gnus-expunge "Xx")))
  272.   "*A hook called after all kill files have been applied.
  273. This hook is called after the global and local kill files have been
  274. applied to the currently-selected newsgroup.
  275.  
  276. If you used to finish off all of your kill files with a call to
  277. gnus-expunge, you can factor all of that out into this hook.  This
  278. reduces kill file size, and makes it easy to delete empty ones.")
  279.  
  280.  
  281. (defvar expire-load-hook nil
  282.   "*A hook called after expire-kill is loaded in.
  283. This can be a good place to put custom key bindings.")
  284.  
  285.  
  286. (defvar expire-date-package 'calendar
  287.   "*The name of the package to use for date calculations.
  288. This should be set to an atom for which expire-date-package-profiles
  289. has an entry, and which may be loaded using (require ...).  Currently
  290. supported packages include calc and calendar.
  291.  
  292. Note that stamps may be read from either format, assuming both are
  293. available.  New stamps, however, will always be generated using the
  294. selected package.")
  295.  
  296.  
  297. (defvar expire-date-package-profiles
  298.   '((calendar (calendar-absolute-from-gregorian (calendar-current-date))
  299.           (- (calendar-absolute-from-gregorian (calendar-current-date))
  300.          timestamp))
  301.     (calc (calc-eval "floor(now())")
  302.       (calc-eval "floor(now() - $)" 'raw timestamp)))
  303.   "*A list of profiles of known date calculation packages.
  304. Each profile is, itself, a list of three values.
  305.  
  306.  - The first is the package name as an atom, which may be used in
  307.    expire-date-package and which is used in (require ...) at load
  308.    time.
  309.  
  310.  - The second is an s-expression that returns the current date.
  311.  
  312.  - The third is an s-expression that returns the (integral) difference
  313.    between the date stored in the variable \"timestamp\" and the
  314.    current date.")
  315.  
  316.  
  317. (defconst expire-version "$Revision: 2.3 $"
  318.   "The current version, of revision number, of expire-kill.
  319. Be sure to include this in any bug reports.")
  320.  
  321. ;;;; ------------------------------------------------------------
  322. ;;;; Dependencies.
  323. ;;;; ------------------------------------------------------------
  324.  
  325. ;;; We need to plug into several GNUS hooks, and add-hook is the
  326. ;;; cleanest way to do so.  Several implementations exist; any should
  327. ;;; suffice.
  328.  
  329. (require 'add-hook)
  330.  
  331. ;;; Backquoting is used to construct the augmented commands that
  332. ;;; expire-kill passes down to gnus-kill.
  333.  
  334. (require 'backquote)
  335.  
  336. ;;; All of expire-kill's date calculations are handled by outside
  337. ;;; packages.  Currently supported are Dave Gillespie's winning calc
  338. ;;; package, and Edward Reingold's equally winning calendar package.
  339. ;;; If you don't have either, you should.  Inquire at your
  340. ;;; neighborhood elisp archive.
  341.  
  342. ;;; Note that if you are using calendar and receive errors about a
  343. ;;; void function named current-time-zone, you will need to initialize
  344. ;;; some of calendar's variables for it.  Those variables are
  345. ;;; calendar-time-zone, calendar-standard-time-zone-name, and
  346. ;;; calendar-daylight-time-zone-name.  See calendar.el for further
  347. ;;; information.
  348.  
  349. (and (boundp 'expire-date-package)
  350.      (require expire-date-package))
  351.  
  352. ;;; Common Lisp defines a really handy (case...) form, that we use for
  353. ;;; checking the value of various user options.  We also use its
  354. ;;; convenient push and pop functions.
  355.  
  356. (require 'cl)
  357.  
  358. ;;; Normally, GNUS should already be loaded by the time we are loaded.
  359. ;;; Just in case, though, make sure it is there.
  360.  
  361. (require 'gnus)
  362.  
  363. ;;;; ------------------------------------------------------------
  364. ;;;; Internal-use variables.
  365. ;;;; ------------------------------------------------------------
  366.  
  367. (defvar expire-current-kill-buffer nil
  368.   "The buffer of the kill file currently (or recently) being applied.")
  369.  
  370. (defvar expire-modified-buffers nil
  371.   "A list of all kill file buffers that may have been modified recently.")
  372.  
  373.  
  374. (defun expire-current-date ()
  375.   "Return some representation of today's date."
  376.   (eval (nth 1 (assq expire-date-package
  377.            expire-date-package-profiles))))
  378.  
  379.  
  380. (defun expire-days-since (timestamp)
  381.   "Return the integral number of days between today and TIMESTAMP."
  382.   (eval (nth 2 (assq expire-date-package
  383.              expire-date-package-profiles))))
  384.  
  385. ;;;; ------------------------------------------------------------
  386. ;;;; User functions.
  387. ;;;; ------------------------------------------------------------
  388.  
  389. (defun expire-kill (field pattern timestamp &optional command all)
  390.   "If FIELD of an article matches REGEXP, update TIMESTAMP and execute COMMAND.
  391. If no COMMAND is given, the value of expire-kill-default-command is
  392. used.  If optional 5th argument ALL is non-nil, articles marked are
  393. also applied to.  If FIELD is an empty string (or nil), entire article
  394. body is searched for.  COMMAND must be a lisp expression or a string
  395. representing a key sequence."
  396. (let (successful)
  397.   (let ((command (or command expire-kill-default-command)))
  398.     (gnus-kill field pattern
  399.            (` (progn (setq successful t)
  400.              (, (if (stringp command)
  401.                 (list 'execute-kbd-macro command)
  402.                   command))))
  403.            all))
  404.   (if successful
  405.       (expire-restamp field pattern
  406.               (expire-convert-timestamp timestamp)
  407.               command all)
  408.     (expire-filter (expire-convert-timestamp timestamp)))))
  409.  
  410.  
  411. (defun expire-Kill-file-kill-by-subject (ask)
  412.   "Insert expiring KILL command for current subject.
  413. Argument ASK non-nil (C-u if called interactively) allows the user to
  414. edit the pattern before it is inserted."
  415.   (interactive "P")
  416.   (expire-insert-kill "Subject"
  417.               (regexp-quote
  418.                (nntp-header-subject
  419.             (gnus-find-header-by-number
  420.              gnus-newsgroup-headers
  421.              gnus-current-kill-article)))
  422.               ask))
  423.  
  424.  
  425. (defun expire-Kill-file-kill-by-thread (ask)
  426.   "Insert expiring KILL command for current thread.
  427. Argument ASK non-nil (C-u if called interactively) allows the user
  428. to edit the pattern before it is inserted."
  429.   (interactive "P")
  430.   (expire-insert-kill "References"
  431.               (regexp-quote
  432.                (gnus-header-id
  433.             (gnus-find-header-by-number
  434.              gnus-newsgroup-headers
  435.              gnus-current-kill-article)))
  436.               ask))
  437.  
  438.  
  439. (defun expire-Kill-file-insert-time-stamp ()
  440.   "Insert a time stamp for the current date after point.
  441. Handy for finishing up hand written calls to expire-kill."
  442.   (interactive)
  443.   (prin1 (expire-current-date)
  444.      (current-buffer)))
  445.  
  446.  
  447. (defun expire-Subject-kill-same-subject (ask)
  448.   "Add a local, expiring kill pattern for the current subject.
  449. Also, mark all articles with this subject in the current buffer as
  450. read, but do not select the next unread article.  Argument ASK non-nil
  451. (C-u if called interactively) allows the user to edit the pattern
  452. before it is inserted."
  453.   (interactive "P")
  454.   (expire-Subject-kill-using 'expire-Kill-file-kill-by-subject ask)
  455.   (gnus-Subject-kill-same-subject nil))
  456.  
  457.  
  458. (defun expire-Subject-kill-same-subject-and-select (ask)
  459.   "Add a local, expiring kill pattern for the current subject.
  460. Also, mark all articles with this subject in the current buffer as
  461. read and select the next unread article.  Argument ASK non-nil (C-u if
  462. called interactively) allows the user to edit the pattern before it is
  463. inserted."
  464.   (interactive "P")
  465.   (expire-Subject-kill-using 'expire-Kill-file-kill-by-subject ask)
  466.   (gnus-Subject-kill-same-subject-and-select nil))
  467.  
  468.  
  469. (defun expire-Subject-kill-thread (ask)
  470.   "Add a local, expiring kill pattern for the current thread.  Also,
  471. mark all articles in the current thread as read.  Argument ASK non-nil
  472. (C-u if called interactively) allows the user to edit the pattern
  473. before it is inserted."
  474.   (interactive "P")
  475.   (expire-Subject-kill-using 'expire-Kill-file-kill-by-thread ask)
  476.   (gnus-Subject-kill-thread nil))
  477.  
  478.  
  479. (defun expire-Subject-kill-thread-and-select (ask)
  480.   "Add a local, expiring kill pattern for the current thread.  Also,
  481. mark all articles in the current thread as read and select the next
  482. unread article.  Argument ASK non-nil (C-u if called interactively)
  483. allows the user to edit the pattern before it is inserted."
  484.   (interactive "P")
  485.   (expire-Subject-kill-using 'expire-Kill-file-kill-by-thread ask)
  486.   (gnus-Subject-kill-thread nil)
  487.   (if (memq (gnus-Subject-article-number)
  488.         gnus-newsgroup-unreads)
  489.       (gnus-Subject-select-article)
  490.     (gnus-Subject-next-unread-article)))
  491.  
  492. ;;;; ------------------------------------------------------------
  493. ;;;; Internal-use hook functions.
  494. ;;;; ------------------------------------------------------------
  495.  
  496. (defun expire-apply-kill-file ()
  497.   "Apply kill files to the current newsgroup.  The global kill file,
  498. if it exists, is loaded in the standard manner.  The local kill file,
  499. however, is read and evaluated one s-expression at a time.  This
  500. allows calls to \"expire-kill\" to modify themselves.  If the local
  501. kill file consists of nothing but whitespace, it may be deleted,
  502. depending upon the value of expire-delete-empties.
  503.  
  504. The hook expire-after-apply-hook is executed after both the global and
  505. local kill files have been applied.  If neither the global nor the
  506. local kill file actually existed, though, this hook is ignored."
  507.   (let (kill-files-applied)
  508.     (let ((global-kill-file (gnus-newsgroup-kill-file nil)))
  509.       (if (file-readable-p global-kill-file)
  510.       (progn
  511.         (message "Loading %s..." global-kill-file)
  512.         (load (gnus-newsgroup-kill-file nil) 'noerr nil 'nosufx)
  513.         (message "Loading %s...done" global-kill-file)
  514.         (setq kill-files-applied 't))))
  515.     (let ((local-kill-file (gnus-newsgroup-kill-file gnus-newsgroup-name)))
  516.       (if (or (file-readable-p local-kill-file)
  517.           (get-file-buffer local-kill-file))
  518.       (save-excursion
  519.         (message "Loading %s..." local-kill-file)
  520.         (find-file local-kill-file)
  521.         (push (setq expire-current-kill-buffer (current-buffer))
  522.           expire-modified-buffers)
  523.         (goto-char (point-min))
  524.         (if (re-search-forward "[^ \t\r\n\f]" nil 'noerr)
  525.         (progn
  526.           (goto-char (point-min))
  527.           (condition-case nil
  528.               (expire-eval-buffer local-kill-file)
  529.             (end-of-file))
  530.           (setq kill-files-applied 't)
  531.           (message "Loading %s...done" local-kill-file)
  532.           (bury-buffer expire-current-kill-buffer)
  533.           (expire-possibly-flush 'always))
  534.           (if (and expire-delete-empties
  535.                (not (file-symlink-p local-kill-file))
  536.                (if (eq expire-delete-empties 'ask)
  537.                (y-or-n-p
  538.                 (format "Delete empty %s " local-kill-file))
  539.              t))
  540.           (progn
  541.             (message "Deleting %s..." local-kill-file)
  542.             (delete-file local-kill-file)
  543.             (set-buffer-modified-p nil)
  544.             (kill-buffer nil)
  545.             (message "Deleting %s...done" local-kill-file))
  546.         (bury-buffer expire-current-kill-buffer)
  547.         (expire-possibly-flush 'always))))))
  548.     (and kill-files-applied
  549.      (run-hooks 'expire-after-apply-hook))))
  550.  
  551.  
  552. (defun expire-Exit-group ()
  553.   "Possibly flush all modified buffers.
  554. Should be called from gnus-Exit-group-hook."
  555.   (expire-possibly-flush 'group))
  556.  
  557.  
  558. (defun expire-Exit-gnus ()
  559.   "Possibly flush all modified buffers.
  560. Should be called from gnus-Exit-gnus-hook."
  561.   (expire-possibly-flush 'session))
  562.  
  563. ;;;; ------------------------------------------------------------
  564. ;;;; Internal-use buffer functions.
  565. ;;;; ------------------------------------------------------------
  566.  
  567. (defun expire-eval-buffer (name)
  568.   "Evaluate the s-expressions following point in the current buffer,
  569. one at a time.  NAME gives the buffer's displayed name."
  570.   ;; Note: while this function could be quite elegant if written
  571.   ;; tail-recursively, even optimizing byte-compilers have difficulty
  572.   ;; making tail-recursion as efficient as a flat loop.  This is
  573.   ;; primarily due to Lisp's dynamic scoping.
  574.   (while 't
  575.     (set-buffer gnus-Subject-buffer)
  576.     (eval (read expire-current-kill-buffer))
  577.     (set-buffer expire-current-kill-buffer)
  578.     (message "Loading %s...%d%%"
  579.          name
  580.          (/ (* 100 (point))   ;; Re-evaluate (point-max) each time,
  581.         (point-max)))))   ;; as the buffer can change in size.
  582.  
  583.  
  584. (defun expire-possibly-flush (frequency)
  585.   "Possibly flush modified kill file buffers.
  586. Flushing actually happens only if argument FREQUENCY and the variable
  587. expire-flush-frequency are the same."
  588.   (if (eq frequency expire-flush-frequency)
  589.       (expire-flush)))
  590.  
  591.  
  592. (defun expire-flush ()
  593.   "Flush modified buffers as called for by expire-flush-action.
  594. Depending on the value of this variable, we either save and kill the
  595. buffers in expire-modified-buffers just save them, or don't do
  596. anything.  Also, reset expire-modified-buffers to nil when we are done."
  597.   ;; Note: while this function could be quite elegant if written
  598.   ;; tail-recursively, even optimizing byte-compilers have difficulty
  599.   ;; making tail-recursion as efficient as a flat loop.  This is
  600.   ;; primarily due to Lisp's dynamic scoping.
  601.   (while expire-modified-buffers
  602.     (let ((buffer (pop expire-modified-buffers)))
  603.       (if (buffer-name buffer)
  604.       (case expire-flush-action
  605.         ('kill (expire-save-if-modified buffer)
  606.            (kill-buffer buffer))
  607.         ('save (expire-save-if-modified buffer)))))))
  608.  
  609.  
  610. (defun expire-save-if-modified (buffer)
  611.   "Save BUFFER, but only if it has been modified.
  612. This prevents unsightly \"(No changes need to be saved)\" messages."
  613.   (if (buffer-modified-p buffer)
  614.       (save-excursion
  615.     (set-buffer buffer)
  616.     (save-buffer)
  617.     (bury-buffer))))
  618.  
  619. ;;;; ------------------------------------------------------------
  620. ;;;; Internal-use pattern functions.
  621. ;;;; ------------------------------------------------------------
  622.  
  623. (defun expire-convert-timestamp (timestamp)
  624.   "Convert a time stamp to the user's preferred format.
  625. If TIMESTAMP is a string, it is assumed to be in calc format; integers
  626. are assumed to belong to calendar.  An equivalent string or integer is
  627. returned, depending upon the value of expire-date-package."
  628.   (cond ((integerp timestamp)
  629.      (case expire-date-package
  630.        (calendar timestamp)
  631.        (calc (require 'calendar)
  632.          (calc-eval "date($)" nil (1+ timestamp)))))
  633.     ((stringp timestamp)
  634.      (case expire-date-package
  635.        (calc timestamp)
  636.        (calendar (require 'calc)
  637.              (1- (calc-eval "date($)" 'raw timestamp)))))))
  638.  
  639.  
  640. (defun expire-restamp (field pattern timestamp &optional command all)
  641.   "Replace a call to \"expire-kill\" with one having an updated time
  642. stamp.  The s-expression before the point is deleted, and a new one is
  643. inserted that calls \"expire-kill\" with the given FIELD and REGEXP,
  644. and the current time as its time stamp.  If the current time is not
  645. different from TIMESTAMP, however, the buffer is not modified.
  646. Optional arguments COMMAND and ALL correspond to those passed to the
  647. original expire-kill call, and if given will be reproduced in the new
  648. call."
  649. (let ((now (expire-current-date)))
  650.   (or (equal timestamp now)
  651.       (progn (set-buffer expire-current-kill-buffer)
  652.          (backward-sexp)
  653.          (kill-sexp 1)
  654.          (delete-blank-lines)
  655.          (delete-blank-lines)
  656.          (expire-insert-kill field pattern nil now command all)))))
  657.  
  658.  
  659. (defun expire-insert-kill (field pattern ask &optional timestamp command all)
  660.   "General purpose function to produce \"expire-kill\" calls.
  661. Inserts a call to \"expire-kill\" with the given FIELD and REGEXP.  If
  662. third argument ASK is non-nil, the user will be allowed to edit the
  663. regexp. An optional fourth argument provides the TIMESTAMP; if none is
  664. given, a stamp for the current time is used.  Fifth and sixth optional
  665. arguments COMMAND and ALL specify the corresponding optional arguments
  666. to the expire-kill call."
  667.   (prin1 (append (list 'expire-kill
  668.                field
  669.                (if ask
  670.                (read-from-minibuffer (concat field ":  ")
  671.                          pattern)
  672.              pattern)
  673.                (or timestamp
  674.                (expire-current-date)))
  675.          (cond (all (list command all))
  676.                (command (list command))))
  677.      (current-buffer))
  678.   (or (eolp)
  679.       (insert ?\n)))
  680.  
  681.  
  682. (defun expire-filter (timestamp)
  683.   "Delete outdated calls to \"expire-kill.\"
  684. If TIMESTAMP is older than the age limit given by expire-maximum-age,
  685. delete the s-expression before the point.  Presumably, this
  686. corresponds to an outdated \"expire-kill\" call."
  687.   (if (> (expire-days-since timestamp)
  688.       expire-maximum-age)
  689.       (progn
  690.     (set-buffer expire-current-kill-buffer)
  691.     (let ((end-of-sexp (point)))
  692.       (backward-sexp)
  693.       (delete-region (point) end-of-sexp)
  694.       (delete-blank-lines)
  695.       (delete-blank-lines)))))
  696.  
  697.  
  698. (defun expire-Subject-kill-using (kill-mode-function ask)
  699.   "In the *Subject* buffer, add a new expiring kill pattern.
  700. First argument FUNCTION should be the name of a function to be called,
  701. with no arguments, in the local kill file to actually insert the new
  702. pattern.  If second argument ASK is non-nil, allow the user to edit
  703. the kill pattern before it is inserted."
  704.   (let ((gnus-current-kill-article (gnus-Subject-article-number)))
  705.     (save-window-excursion
  706.       (find-file (gnus-newsgroup-kill-file gnus-newsgroup-name))
  707.       (goto-char (point-min))
  708.       (funcall kill-mode-function ask)
  709.       (push (current-buffer) expire-modified-buffers)
  710.       (bury-buffer)
  711.       (expire-possibly-flush 'always))))
  712.  
  713. ;;;; ------------------------------------------------------------
  714. ;;;; Initialization.
  715. ;;;; ------------------------------------------------------------
  716.  
  717. ;;; Bind each of the major user-callable functions, if the same-named
  718. ;;; variable is set to a string representing a key sequence.
  719.  
  720. (mapcar (function
  721.      (lambda (binding)
  722.        (let ((function (car binding))
  723.          (keymap (cdr binding)))
  724.          (if (stringp (symbol-value function))
  725.          (define-key
  726.            (symbol-value keymap)
  727.            (symbol-value function)
  728.            function)))))
  729.     '((expire-Subject-kill-same-subject . gnus-Subject-mode-map)
  730.       (expire-Subject-kill-same-subject-and-select . gnus-Subject-mode-map)
  731.       (expire-Subject-kill-thread . gnus-Subject-mode-map)
  732.       (expire-Subject-kill-thread-and-select . gnus-Subject-mode-map)
  733.       (expire-Kill-file-kill-by-subject . gnus-Kill-file-mode-map)
  734.       (expire-Kill-file-kill-by-thread . gnus-Kill-file-mode-map)
  735.       (expire-Kill-file-insert-time-stamp . gnus-Kill-file-mode-map)))
  736.     
  737.  
  738. ;;; Install ourselves as the kill file applier of choice.
  739.  
  740. (setq gnus-Apply-kill-hook 'expire-apply-kill-file)
  741.  
  742.  
  743. ;;; Plug in to some exit conditions that might prompt flushing.
  744.  
  745. (add-hook 'gnus-Exit-group-hook 'expire-Exit-group)
  746. (add-hook 'gnus-Exit-gnus-hook 'expire-Exit-gnus)
  747.  
  748.  
  749. ;;; Announce our presence and call any user hooks.
  750.  
  751. (provide 'expire-kill)
  752. (run-hooks 'expire-load-hook)
  753.  
  754.  
  755. ;;; The End
  756.