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