home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / gnus-cache.el < prev    next >
Encoding:
Text File  |  1994-09-20  |  27.2 KB  |  727 lines
  1. ;;; gnus-cache.el - caching extensions to GNUS                 -*-Emacs-Lisp-*-
  2. ;;; Copyright (C) 1993 Rick Sladkey <jrs@world.std.com>
  3.  
  4. ;; This file is not part of GNUS but is distributed under
  5. ;; the same conditions as GNUS.
  6.  
  7. ;; GNUS Cache is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; GNUS Cache is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17.  
  18. ;; LCD Archive Entry:
  19. ;; gnus-cache|Rick Sladkey|jrs@world.std.com|
  20. ;; GNUS speed-up by caching NNTP article headers to disk|
  21. ;; 3-Jan-1994|1.8|~/misc/gnus-cache.el.Z|
  22.  
  23. (defconst gnus-cache-version "GNUS Cache v1.8 - 94-01-03")
  24.  
  25.  
  26. ;; Overview:
  27.  
  28. ;; This add-on package for GNUS is meant to dramatically speed-up
  29. ;; the process of reading netnews using GNUS over NNTP.  It works
  30. ;; by caching unread message headers into files.  It is most useful
  31. ;; if you have a fast local system with some spare disk space but a
  32. ;; slow NNTP server or a slow link to your NNTP server.  It works
  33. ;; with either the old GNUS (<= 3.14.4) or the new GNUS (>= 3.15).
  34.  
  35. ;; Never again catch up on a newsgroup just because you dread
  36. ;; re-entering it with the same 200 articles unread...
  37.  
  38. ;; Never again leave your NNTP connection open for hours on end
  39. ;; just because downloading the active file takes five minutes...
  40.  
  41. ;; Never again wait forever downloading 400 headers from
  42. ;; a newsgroup that you just end up catching up on anyway...
  43.  
  44.  
  45. ;; Usage:
  46.  
  47. ;; To use gnus-cache just put "gnus-cache.el" in your load-path
  48. ;; and byte-compile it and then put "(require 'gnus-cache)"
  49. ;; in your GNUS setup file or in your gnus-open-server-hook.
  50. ;; For GNUS version <= 3.14.4 use gnus-Open-server-hook instead.
  51.  
  52. ;; GNUS Cache works best when you preload the cache with the headers
  53. ;; of newsgroups you read most often.  This can be done by either
  54. ;; running `gnus-batch-kill' (this kills two birds with one stone)
  55. ;; or by running `gnus-cache-preload-cache' after GNUS is started.
  56. ;; Using either method is convenient because all header retrieval
  57. ;; for all your newgroups happens at one time so you can start it
  58. ;; up and do something else until its done.  Then when you go to
  59. ;; read your news the subject summaries appear almost instantly.
  60. ;; Well, pretty fast, anyway.
  61.  
  62. ;; By default, "G" is bound to `gnus-cache-get-new-news-and-preload-cache'
  63. ;; if it is not already defined.
  64.  
  65.  
  66. ;; Variables:
  67.  
  68. ;; gnus-cache-enabled -- If this is false it should act like the regular NNTP.
  69. ;; If you want this to be false I recommend not using gnus-cache.
  70. ;; However, it might be useful if you use more than one NNTP server and
  71. ;; don't want to cache them all.
  72. ;; This is on by default.
  73.  
  74. ;; gnus-cache-verbose -- Controls how chatty gnus-cache is.
  75. ;; This is on by default.
  76.  
  77. ;; gnus-cache-save-active-file -- Controls if the active file is cached.
  78. ;; It is a `good thing' to cache the active file if you quit and restart
  79. ;; GNUS frequently and have a slow NNTP server and a large active file.
  80. ;; When the active file is cached you get the "old" active file when
  81. ;; you restart GNUS which is very fast.  Use "g" or "G" to re-read it.
  82. ;; This is on by default.
  83.  
  84. ;; gnus-cache-save-all-headers -- Controls if deleted articles are cached.
  85. ;; You may want this turned on if you frequently reread already caught up
  86. ;; groups or if you are sharing the cache directory.  Needs lots of disk space.
  87. ;; It is turned off by default.
  88.  
  89. ;; gnus-cache-saved-newsgroups-regexp -- Controls which newsgroups get cached.
  90. ;; If you want to cache only certain newsgroups, this is how.
  91. ;; If you only want to save the active file you can set this to nil.
  92. ;; The default of t caches all newsgroups you read or are subscribed to.
  93.  
  94. ;; gnus-cache-kill-while-preloading -- Controls whether preloading also kills.
  95. ;; If you have a fast system and don't use `gnus-expunge' you will probably
  96. ;; want this leave this turned off.  However, if it is turned on, you may
  97. ;; want to also set gnus-apply-kill-hook (or gnus-Apply-kill-hook) to nil
  98. ;; so that articles are killed only a preload time.
  99. ;; By default, kill files are processed at read time, not preload time.
  100.  
  101. ;; gnus-cache-apply-kill-hook -- Called to perform kills during preloading.
  102. ;; If gnus-cache-kill-while-preloading is t then this hook is called
  103. ;; during cache preloading.
  104. ;; The default value is gnus-apply-kill-file.
  105.  
  106. ;; gnus-cache-saved-file-maximum-age -- Controls deletions from the cache dir.
  107. ;; If this is a number, it specified the number of days a cache file
  108. ;; may be kept.  If a cache file is older than this at server open time
  109. ;; it is deleted.  If it is nil, cache files are never deleted.
  110. ;; If you are using a shared cache directory you may want to turn this
  111. ;; off and do expiry from cron.
  112. ;; The default value is 7 days.
  113.  
  114. ;; gnus-cache-directory-is-shared -- Controls how carefully files are written.
  115. ;; If true, then gnus-cache writes to saved files using temp files and
  116. ;; renaming instead of overwriting.  This prevents cache file corruption.
  117. ;; Also causes created directories to be chmod'ed to 777 and created files
  118. ;; to be chmod'ed to 644.
  119. ;; This is off by default.
  120.  
  121. ;; gnus-cache-directory-template -- A format string for the cache directory.
  122. ;; This may contain a "%s" for the NNTP server name.
  123. ;; If the directory does not exist it is created automatically.
  124. ;; The default value is "~/.gnus-cache/%s".
  125.  
  126. ;; gnus-cache-cache-file-name -- Extension to give cache files. See
  127. ;; gnus-cache-use-long-file-name.  The default value is "CACHE" but
  128. ;; using "CACHE.gz" with a compression package will buy you gzipped
  129. ;; cache files.  Idea from Richard Pieri.
  130.  
  131. ;; gnus-cache-active-file-name -- Name to use for the saved active file.
  132. ;; The default it is "ACTIVE".
  133.  
  134. ;; gnus-cache-use-long-file-name -- Controls the format of header cache files.
  135. ;; If this is turned on then message header cache files look like
  136. ;; "gnu.emacs.gnus.CACHE", otherwise like "gnu/emacs/gnus/CACHE".
  137. ;; The reason it is a different variable than gnus-use-long-file-name
  138. ;; is because you may want to use different values for each.
  139. ;; This defaults to value of gnus-use-long-file-name.
  140.  
  141. ;; gnus-cache-setup-hook -- A hook for gnus-cache customization.
  142. ;; For example, you could set gnus-cache-directory from this hook.
  143.  
  144. ;; gnus-cache-preloading-completed-hook -- A hook for doing something
  145. ;; when preloading is finished.  By default this does nothing but
  146. ;; you could make gnus-cache beep at you by setting it to 'ding.
  147.  
  148.  
  149. ;; Caveats:
  150.  
  151. ;; You can "rm -rf" the cache directory at any time and it will
  152. ;; not harm your ability to read news.  Only the speed...
  153.  
  154. ;; Be aware that if you are subscribed to a lot of large newgroups
  155. ;; that you don't really read then gnus-cache will take much longer
  156. ;; and waste a lot of disk space.
  157.  
  158. ;; If you have, for example, a 100k active file and an total of
  159. ;; 2000 unread messages in any number of groups, then gnus-cache
  160. ;; might use about 500k of disk space for caching.  If you are
  161. ;; more religious about keeping up with all your subscribed
  162. ;; groups it could be much less.
  163.  
  164.  
  165.  
  166. (require 'gnus)
  167. (require 'nntp)
  168.  
  169. (defvar gnus-cache-enabled t
  170.   "*True if gnus-cache should honor the values of
  171. gnus-cache-save-active-file and gnus-cache-saved-newsgroups-regexp.")
  172.  
  173. (defvar gnus-cache-verbose t
  174.   "*True if gnus-cache should be chatty when using cached files.")
  175.  
  176. (defvar gnus-cache-save-active-file t
  177.   "*True if gnus-cache should save a copy of the active file
  178. for faster restarts.  If this variable is true then you must
  179. use `g' or `G' after starting GNUS to truly see the latest news.")
  180.  
  181. (defvar gnus-cache-save-all-headers nil
  182.   "*True if gnus-cache should retain the headers for deleted articles.
  183. You will probably only want to turn this on if the cache directory is shared.")
  184.  
  185. (defvar gnus-cache-saved-newsgroups-regexp t
  186.   "*A regular expression matching the names of all newsgroups
  187. whose headers you want saved for faster access.  Use t to match
  188. all newsgroups or nil to not match any.")
  189.  
  190. (defvar gnus-cache-kill-while-preloading nil
  191.   "*True if gnus-cache should apply kill files when performing
  192. `gnus-cache-preload-cache'.  Leave this off if you like to
  193. see killed articles in newsgroup summaries.  That is, if
  194. you don't use `gnus-expunge' at the end of your kill files.")
  195.  
  196. (defvar gnus-cache-apply-kill-hook 'gnus-apply-kill-file
  197.   "*A hook called to perform kill processing on the current
  198. newsgroup during cache preloading if gnus-cache-kill-while-preloading
  199. is t.  The default value is gnus-apply-kill-file.")
  200.  
  201. (defvar gnus-cache-saved-file-maximum-age 7
  202.   "*Maximum age of files in the cache directory before they are
  203. deleted.  The default value is 7 days.")
  204.  
  205. (defvar gnus-cache-directory-is-shared nil
  206.   "*True if gnus-cache should use temp files and renaming when
  207. writing to files in the cache directory.")
  208.  
  209. (defvar gnus-cache-directory-template "~/.gnus-cache/%s"
  210.   "*Format string used to determine the name of the directory
  211. that cache files are kept in for a given NNTP server.
  212. A \"%s\" is substituted with the server's name.
  213. The default value keeps the cache files in a directory
  214. called \"~/.gnus-cache/SERVER\".  It should be changed if
  215. the cache directory is shared.")
  216.  
  217. (defvar gnus-cache-cache-file-name "CACHE"
  218.   "*File name of a CACHE file. See \"gnus-cache-use-long-file-name\".")
  219.  
  220. (defvar gnus-cache-active-file-name "ACTIVE"
  221.   "*File name of the ACTIVE file.")
  222.  
  223. (defvar gnus-cache-use-long-file-name gnus-use-long-file-name
  224.   "*True if cache files for saved article headers should use names
  225. like gnu.emacs.gnus.CACHE or gnu/emacs/gnus/CACHE.")
  226.  
  227. (defvar gnus-cache-setup-hook nil
  228.   "*Hooks to run after setting up the gnus-cache directory.
  229. You may set gnus-cache variables such as gnus-cache-directory here.")
  230.  
  231. (defvar gnus-cache-preloading-completed-hook nil
  232.   "*Hooks to run after preloading is completed.  Useful for doing
  233. attention-grabbing things.  Use your imagination.")
  234.  
  235.  
  236.  
  237. ;; Current newsgroup for NNTP.
  238. (defvar gnus-cache-current-newsgroup nil)
  239.  
  240. ;; Minimum active article in current newsgroup.
  241. (defvar gnus-cache-current-min-article nil)
  242.  
  243. ;; True if current group command has been issued to NNTP server.
  244. (defvar gnus-cache-newsgroup-requested nil)
  245.  
  246. ;;True if nntp-request-list has been requested once already.
  247. (defvar gnus-cache-request-list-requested nil)
  248.  
  249. ;; Name of directory holding cached header information from NNTP server.
  250. (defvar gnus-cache-directory nil)
  251.  
  252. ;; List of functions from the nntp package that get overloaded by gnus-cache.
  253. (defconst gnus-cache-overloaded-nntp-functions
  254.   '(nntp-retrieve-headers nntp-request-list nntp-open-server nntp-request-group
  255.     nntp-request-article nntp-request-body nntp-request-head
  256.     nntp-request-last nntp-request-next nntp-request-stat))
  257.  
  258. ;; Are we running the old GNUS package?
  259. (defvar gnus-cache-old-gnus (fboundp 'gnus-Group-startup-message))
  260.  
  261. (defvar gnus-cache-buffer nil)
  262.  
  263. ;; Do the overloading.
  264. (let ((list gnus-cache-overloaded-nntp-functions)
  265.       (old-function nil)
  266.       (saved-function nil)
  267.       (new-function nil))
  268.   (while list
  269.     (setq old-function (car list)
  270.       list (cdr list)
  271.       saved-function (intern (concat "gnus-cache-"
  272.                      (symbol-name old-function)
  273.                      "-original"))
  274.       new-function (intern (concat "gnus-cache-"
  275.                        (symbol-name old-function))))
  276.     (if (and (fboundp old-function) (not (fboundp saved-function)))
  277.     (progn
  278.       (fset saved-function (symbol-function old-function))
  279.       (fset old-function new-function)))))
  280.  
  281. ;; Politely install ourselves in the group mode map.
  282. (if gnus-cache-old-gnus
  283.     (let ((old-command (lookup-key gnus-Group-mode-map "G")))
  284.       (and (or (not old-command)
  285.            (eq old-command 'undefined))
  286.        (define-key gnus-Group-mode-map "G"
  287.          'gnus-cache-get-new-news-and-preload-cache)))
  288.   (let ((old-command (lookup-key gnus-group-mode-map "G")))
  289.     (and (or (not old-command)
  290.          (eq old-command 'undefined))
  291.      (define-key gnus-group-mode-map "G"
  292.        'gnus-cache-get-new-news-and-preload-cache))))
  293.  
  294.  
  295.  
  296. (defun gnus-cache-get-new-news-and-preload-cache ()
  297.   "Reread the active file and preload the cache of GNUS headers."
  298.   (interactive)
  299.   (if gnus-cache-old-gnus
  300.       (gnus-Group-get-new-news)
  301.     (gnus-group-get-new-news))
  302.   (gnus-cache-preload-cache))
  303.  
  304. (defun gnus-cache-preload-cache (&optional options)
  305.   ;; This function is based almost entirely on gnus-batch-kill by UMEDA.
  306.   "Preload the cache of GNUS headers.   Optional argument OPTIONS
  307. is a newsrc-style options line describing which newsgroups to preload.
  308. In any case, only newsgroups matching gnus-cache-saved-newsgroup-regexp
  309. are preloaded."
  310.   (interactive "sOptions: (default all) ")
  311.   (if (or (not options) (string-equal options ""))
  312.       (setq options "all"))
  313.   (let* ((last-group (if gnus-cache-old-gnus
  314.              (gnus-Group-group-name)
  315.                (gnus-group-group-name)))
  316.      (group nil)
  317.      (subscribed nil)
  318.      (newsrc nil)
  319.      (yes-and-no (gnus-parse-n-options options))
  320.      (yes (car yes-and-no))
  321.      (no  (cdr yes-and-no))
  322.      ;; Disable verbose message.
  323.      (gnus-novice-user nil)
  324.      (gnus-large-newsgroup nil)
  325.      (nntp-large-newsgroup nil))
  326.     (save-window-excursion
  327.       (setq newsrc (copy-sequence gnus-newsrc-assoc))
  328.       (while newsrc
  329.     (setq group (car (car newsrc)))
  330.     (setq subscribed (nth 1 (car newsrc)))
  331.     (setq newsrc (cdr newsrc))
  332.     (if (and subscribed
  333.  
  334.          (gnus-cache-saved-newsgroup-p group)
  335.          (not (zerop (nth 1 (gnus-gethash group gnus-unread-hashtb))))
  336.          (if yes
  337.              (string-match yes group) t)
  338.          (or (null no)
  339.              (not (string-match no group))))
  340.         (progn
  341.           (message "Preloading %s..." group)
  342.           (if gnus-cache-old-gnus
  343.           (if gnus-cache-kill-while-preloading
  344.               (let ((gnus-Apply-kill-hook
  345.                  (or gnus-cache-apply-kill-hook
  346.                  gnus-Apply-kill-hook)))
  347.             (gnus-Subject-read-group group nil t)
  348.             (if (eq (current-buffer)
  349.                 (get-buffer gnus-Subject-buffer))
  350.                 (gnus-Subject-exit t)))
  351.             (gnus-select-newsgroup group nil)
  352.             (gnus-Subject-exit t))
  353.         (if gnus-cache-kill-while-preloading
  354.             (let ((gnus-apply-kill-hook
  355.                (or gnus-cache-apply-kill-hook
  356.                    gnus-apply-kill-hook)))
  357.               (gnus-summary-read-group group nil t)
  358.               (if (eq (current-buffer)
  359.                   (get-buffer gnus-summary-buffer))
  360.               (gnus-summary-exit t)))
  361.           (gnus-select-newsgroup group nil)
  362.           (gnus-summary-exit t)))))))
  363.     (or (and last-group
  364.          (if gnus-cache-old-gnus
  365.          (gnus-Group-jump-to-group last-group)
  366.            (gnus-group-jump-to-group last-group)))
  367.     (progn
  368.       (beginning-of-line)
  369.       (search-forward ":" nil t)))
  370.     (message "Preloading... done")
  371.     (run-hooks 'gnus-cache-preloading-completed-hook)))
  372.   
  373. (defun gnus-cache-saved-newsgroup-p (group)
  374.   ;; Should this newsgroup get cached?
  375.   (if (stringp gnus-cache-saved-newsgroups-regexp)
  376.       (string-match gnus-cache-saved-newsgroups-regexp group)
  377.     gnus-cache-saved-newsgroups-regexp))
  378.  
  379. (defun gnus-cache-nntp-open-server (host &optional service)
  380.   ;; Must do our package setup at open server time.
  381.   (gnus-cache-setup host)
  382.   (gnus-cache-nntp-open-server-original host service))
  383.  
  384. (defun gnus-cache-setup (host)
  385.   ;; Set up the cache directory name and some variables,
  386.   ;; run our setup hook, and clean out the cache directory.
  387.   (if gnus-cache-enabled
  388.       (progn
  389.     (setq gnus-cache-buffer (get-buffer-create " *gnus-cache*"))
  390.     (setq gnus-cache-directory
  391.           (directory-file-name
  392.            (expand-file-name
  393.         (format gnus-cache-directory-template host))))
  394.     (setq gnus-cache-request-list-requested nil)
  395.     (run-hooks 'gnus-cache-setup-hook)
  396.     (if (file-directory-p gnus-cache-directory)
  397.         (and gnus-cache-saved-file-maximum-age
  398.          (gnus-cache-expire-saved-files))
  399.       (gnus-cache-make-directory gnus-cache-directory)))))
  400.  
  401. (defun gnus-cache-expire-saved-files ()
  402.   ;; Delete all old files in the cache directory.
  403.   (let* ((default-directory gnus-cache-directory)
  404.      (cache-files
  405.       (if gnus-cache-use-long-file-name
  406.           (directory-files gnus-cache-directory nil "\\.CACHE$")
  407.         (gnus-cache-recursive-files-of gnus-cache-directory "/CACHE$")))
  408.      (expired-cache-files
  409.       (gnus-cache-files-older-than
  410.        cache-files gnus-cache-saved-file-maximum-age)))
  411.     (mapcar (if gnus-cache-verbose
  412.         (function
  413.          (lambda (file)
  414.            (message "Deleting expired %s" file)
  415.            (delete-file file)))
  416.           (function delete-file))
  417.         expired-cache-files)))
  418.  
  419. (defun gnus-cache-recursive-files-of (dir-or-file regexp)
  420.   ;; Create a list of all files in or below a directory matching a pattern.
  421.   (if (file-directory-p dir-or-file)
  422.       (apply (function nconc)
  423.          (mapcar (function
  424.               (lambda (dir-or-file)
  425.             (gnus-cache-recursive-files-of dir-or-file regexp)))
  426.              (directory-files dir-or-file t "^[^.]")))
  427.     (and (or (not regexp) (string-match regexp dir-or-file))
  428.      (list dir-or-file))))
  429.  
  430. (defun gnus-cache-make-directory (dir)
  431.   ;; Makes leading directory components as necessary.
  432.   ;; Only use existing make-directory if it is a subr.
  433.   ;; Make dir mode 777 if the cache-directory is shared.
  434.   (let ((parent (and (string-match "^.*/" dir)
  435.              (substring dir 0 (1- (match-end 0))))))
  436.     (if (and parent (not (file-directory-p parent)))
  437.     (gnus-cache-make-directory parent)))
  438.   (prog1
  439.       (if (and (fboundp 'make-directory)
  440.            (subrp (symbol-function 'make-directory)))
  441.       (make-directory dir)
  442.     (eq (call-process "mkdir" nil nil nil dir) 0))
  443.     (and gnus-cache-directory-is-shared
  444.      (set-file-modes dir 511))))    ; 511 == 0777
  445.  
  446. (defun gnus-cache-files-older-than (files age)
  447.   ;; For some versions of Emacs the age in days must be less than about 100.
  448.   (setq age (* age 86400))
  449.   (let* ((ms-age (/ age 65536))
  450.      (ls-age (- age (* ms-age 65536)))
  451.      (current-time (gnus-cache-current-time))
  452.      (ms-time (car current-time))
  453.      (ls-time (car (cdr current-time)))
  454.      (file nil)
  455.      (result nil))
  456.     (while files
  457.       (setq file (car files) files (cdr files))
  458.       (let* ((file-time (nth 5 (file-attributes file)))
  459.          (ms-diff (- ms-time (car file-time)))
  460.          (ls-diff (- ls-time (if (numberp (cdr file-time))
  461.                      (cdr file-time)
  462.                    (car (cdr file-time))))))
  463.     (and (< ls-diff 0)
  464.          (setq ls-diff (+ ls-diff 65536) ms-diff (1- ms-diff)))
  465.     (and (or (> ms-diff ms-age)
  466.          (and (= ms-diff ms-age)
  467.               (> ls-diff ls-age)))
  468.          (setq result (cons file result)))))
  469.     result))
  470.  
  471. (defun gnus-cache-current-time ()
  472.   ;; Only use existing current-time if it is a subr (FSF 19).
  473.   ;; Only use existing current-time-seconds if it is a subr (Lucid).
  474.   ;; The temp file idea is due to Joe Wells.
  475.   (cond
  476.    ((and (fboundp 'current-time)
  477.      (subrp (symbol-function 'current-time)))
  478.     (current-time))
  479.    ((and (fboundp 'current-time-seconds)
  480.      (subrp (symbol-function 'current-time-seconds)))
  481.     (let ((time (current-time-seconds)))
  482.       (list (car time) (cdr time))))
  483.    (t
  484.     (let ((temp (make-temp-name gnus-cache-directory)))
  485.       (unwind-protect
  486.       (progn
  487.         (write-region (point-min) (point-min) temp nil 'no-message)
  488.         (nth 5 (file-attributes temp)))
  489.     (delete-file temp))))))
  490.  
  491.  
  492.  
  493. (defun gnus-cache-nntp-retrieve-headers (sequence)
  494.   ;; If this is a newsgroup to be cached then retrieve headers using the cache.
  495.   (if (and (not (stringp (car sequence)))
  496.        gnus-cache-enabled
  497.        (gnus-cache-saved-newsgroup-p gnus-cache-current-newsgroup))
  498.       (gnus-cache-retrieve-headers-using-cache sequence)
  499.     (gnus-cache-retrieve-headers-using-nntp sequence)))
  500.  
  501. (defun gnus-cache-retrieve-headers-using-cache (sequence)
  502.   ;; This is the workhorse for the header caching feature.
  503.   (save-excursion
  504.     (set-buffer gnus-cache-buffer)
  505.     (erase-buffer)
  506.     (let* ((cache-dir gnus-cache-directory)
  507.        (cache-file (gnus-cache-saved-file-name
  508.             gnus-cache-current-newsgroup))
  509.        (cached-headers (and (file-exists-p cache-file)
  510.                 (insert-file-contents cache-file)
  511.                 (read gnus-cache-buffer)))
  512.        (cached-sequence (mapcar (function (lambda (header)
  513.                         (nntp-header-number header)))
  514.                     cached-headers))
  515.        (uncached-sequence (gnus-cache-sequence-difference sequence
  516.                                   cached-sequence))
  517.        (uncached-headers (and uncached-sequence
  518.                   (gnus-cache-retrieve-headers-using-nntp
  519.                    uncached-sequence)))
  520.        (headers (if uncached-sequence
  521.             (gnus-cache-merge-headers sequence
  522.                           cached-headers
  523.                           uncached-headers)
  524.               cached-headers)))
  525.       (and uncached-sequence
  526.        (progn
  527.          (erase-buffer)
  528.          (print headers gnus-cache-buffer)
  529.          (gnus-cache-write-file (point-min) (point-max) cache-file)))
  530.       (gnus-cache-trim-headers sequence headers))))
  531.  
  532. (defun gnus-cache-saved-file-name (group)
  533.   ;; Cache file names end with "CACHE" so that expiry won't accidentally
  534.   ;; clobber important files.  Makes any leading directory components
  535.   ;; if using short file names.
  536.   (if gnus-cache-use-long-file-name
  537.       (concat gnus-cache-directory "/" group "." gnus-cache-cache-file-name)
  538.     (let ((path gnus-cache-directory))
  539.       (while (string-match "\\." group)
  540.     (setq path (concat path "/" (substring group 0 (1- (match-end 0))))
  541.           group (substring group (match-end 0))))
  542.       (setq path (concat path "/" group))
  543.       (or (file-directory-p path)
  544.       (gnus-cache-make-directory path))
  545.       (concat path "/" gnus-cache-cache-file-name))))
  546.  
  547. (defun gnus-cache-sequence-difference (sequence cached-sequence)
  548.   ;; Determine which headers are not in the cache and must be retrieved.
  549.   (let ((uncached-sequence nil)
  550.     (article nil)
  551.     (cached-article nil))
  552.   (while (and sequence cached-sequence)
  553.     (setq article (car sequence) sequence (cdr sequence))
  554.     (while (and cached-sequence
  555.         (> article (setq cached-article (car cached-sequence))))
  556.       (setq cached-sequence (cdr cached-sequence)))
  557.     (if (or (not cached-sequence) (< article cached-article))
  558.     (setq uncached-sequence (cons article uncached-sequence))))
  559.   (nconc (nreverse uncached-sequence) sequence)))
  560.  
  561. (defun gnus-cache-merge-headers (sequence cached-headers uncached-headers)
  562.   ;; Merge cached and uncached headers to create a superset of the
  563.   ;; requested sequence.  The cached-headers list is modified.
  564.   (let ((old-headers nil)
  565.     (headers nil)
  566.     (article nil))
  567.     ;; Trim expired articles.
  568.     (while (and cached-headers
  569.         (< (nntp-header-number (car cached-headers))
  570.            gnus-cache-current-min-article))
  571.       (setq cached-headers (cdr cached-headers)))
  572.     ;; Avoid lots of consing for articles cached but not requested.
  573.     (setq old-headers cached-headers
  574.       article (car sequence))
  575.     (let ((last-cons nil))
  576.       (while (and cached-headers
  577.           (< (nntp-header-number (car cached-headers)) article))
  578.     (setq last-cons cached-headers
  579.           cached-headers (cdr cached-headers)))
  580.       (if (eq old-headers cached-headers)
  581.       (setq old-headers nil)
  582.     (setcdr last-cons nil)))
  583.     ;; Note that cached and uncached sequences don't intersect
  584.     ;; and that the uncached sequence is a subset of the requested sequence.
  585.     (while sequence
  586.       (setq article (car sequence)
  587.         sequence (cdr sequence))
  588.       (while (and cached-headers
  589.           (< (nntp-header-number (car cached-headers)) article))
  590.     (setq headers (cons (car cached-headers) headers)
  591.           cached-headers (cdr cached-headers)))
  592.       (cond
  593.        ((and cached-headers
  594.          (= (nntp-header-number (car cached-headers)) article))
  595.     (setq headers (cons (car cached-headers) headers)
  596.           cached-headers (cdr cached-headers)))
  597.        ((and uncached-headers
  598.          (= (nntp-header-number (car uncached-headers)) article))
  599.     (setq headers (cons (car uncached-headers) headers)
  600.           uncached-headers (cdr uncached-headers)))
  601.        (t
  602.     (setq headers (cons (vector article) headers)))))
  603.     (if gnus-cache-save-all-headers
  604.     (nconc old-headers (nreverse headers))
  605.       (nreverse headers))))
  606.  
  607. (defun gnus-cache-trim-headers (sequence headers)
  608.   ;; Remove unrequested or expired headers by modifying list.
  609.   ;; Requested sequence must be a subset of the headers.
  610.   (let ((result (setq headers (cons nil headers)))
  611.     (article (car sequence)))
  612.     (while sequence
  613.       (setq article (car sequence)
  614.         sequence (cdr sequence))
  615.       (while (< (nntp-header-number (car (cdr headers))) article)
  616.     (setcdr headers (cdr (cdr headers))))
  617.       (if (= (length (car (cdr headers))) 1)
  618.       (setcdr headers (cdr (cdr headers)))
  619.     (setq headers (cdr headers))))
  620.     (setcdr headers nil)
  621.     (cdr result)))
  622.  
  623. (defun gnus-cache-write-file (beg end file)
  624.   ;; Maybe replace file instead of overwriting so cache dir can be shared.
  625.   (if gnus-cache-directory-is-shared
  626.       (let ((temp (make-temp-name file)))
  627.     (write-region beg end temp nil 'no-message)
  628.     (set-file-modes temp 420)    ; 420 == 0644
  629.     (rename-file temp file t))
  630.     (write-region beg end file nil 'no-message)))
  631.  
  632. (defun gnus-cache-nntp-request-list ()
  633.   ;; Read the active file, perhaps from the cache.
  634.   (if (and gnus-cache-enabled
  635.        gnus-cache-save-active-file
  636.        (not noninteractive))
  637.       (gnus-cache-request-list-using-cache)
  638.     (gnus-cache-nntp-request-list-original)))
  639.  
  640. (defun gnus-cache-request-list-using-cache ()
  641.   ;; Active file caching.
  642.   (let ((cached-active-file
  643.      (concat gnus-cache-directory "/" gnus-cache-active-file-name))
  644.     (result nil))
  645.     (if (or gnus-cache-request-list-requested
  646.         (not (file-exists-p cached-active-file)))
  647.     (if (setq result (gnus-cache-nntp-request-list-original))
  648.         (save-excursion
  649.           (set-buffer nntp-server-buffer)
  650.           (and gnus-cache-verbose
  651.            (message "Writing saved active file..."))
  652.           (gnus-cache-write-file (point-min) (point-max)
  653.                      cached-active-file)))
  654.       (save-excursion
  655.     (and gnus-cache-verbose
  656.          (message "Reading saved active file..."))
  657.     (set-buffer nntp-server-buffer)
  658.     (erase-buffer)
  659.     (setq result (insert-file-contents cached-active-file))))
  660.     (setq gnus-cache-request-list-requested t)
  661.     result))
  662.  
  663. (defun gnus-cache-nntp-request-group (group)
  664.   ;; We defer group requests until the last minute for extra speed.
  665.   (setq gnus-cache-current-newsgroup group
  666.     gnus-cache-current-min-article 0
  667.     gnus-cache-newsgroup-requested nil)
  668.   t)
  669.  
  670. (defun gnus-cache-request-group-internal ()
  671.   ;; Must be called when we are about the read an article or retrieve headers.
  672.   (if gnus-cache-newsgroup-requested
  673.       t
  674.     (setq gnus-cache-newsgroup-requested t)
  675.     (let* ((result (gnus-cache-nntp-request-group-original
  676.             gnus-cache-current-newsgroup))
  677.        (message (and result (nntp-status-message))))
  678.       (and result
  679.        (stringp message)
  680.        (string-match "^[0-9]+[ \t]+\\([0-9]+\\)[ \t]+[0-9]+" message)
  681.        (setq gnus-cache-current-min-article
  682.          (string-to-int (substring message
  683.                        (match-beginning 1)
  684.                        (match-end 1)))))
  685.       result)))
  686.  
  687. ;; Several functions need to verify that the group is properly set.
  688.  
  689. (defun gnus-cache-retrieve-headers-using-nntp (sequence)
  690.   (and
  691.    (gnus-cache-request-group-internal)
  692.    (gnus-cache-nntp-retrieve-headers-original sequence)))
  693.  
  694. (defun gnus-cache-nntp-request-article (id)
  695.   (and
  696.    (gnus-cache-request-group-internal)
  697.    (gnus-cache-nntp-request-article-original id)))
  698.  
  699. (defun gnus-cache-nntp-request-body (id)
  700.   (and
  701.    (gnus-cache-request-group-internal)
  702.    (gnus-cache-nntp-request-body-original id)))
  703.  
  704. (defun gnus-cache-nntp-request-head (id)
  705.   (and
  706.    (gnus-cache-request-group-internal)
  707.    (gnus-cache-nntp-request-head-original id)))
  708.  
  709. (defun gnus-cache-nntp-request-stat (id)
  710.   (and
  711.    (gnus-cache-request-group-internal)
  712.    (gnus-cache-nntp-request-stat-original id)))
  713.  
  714. (defun gnus-cache-nntp-request-last ()
  715.   (and
  716.    (gnus-cache-request-group-internal)
  717.    (gnus-cache-nntp-request-last-original)))
  718.  
  719. (defun gnus-cache-nntp-request-next ()
  720.   (and
  721.    (gnus-cache-request-group-internal)
  722.    (gnus-cache-nntp-request-next-original)))
  723.  
  724. (provide 'gnus-cache)
  725.  
  726. ;;; gnus-cache.el ends here
  727.