| 1 | ;;; gnus-cache.el --- cache interface for Gnus |
| 2 | |
| 3 | ;; Copyright (C) 1995 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> |
| 6 | ;; Keywords: news |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 13 | ;; any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 23 | ;; Boston, MA 02111-1307, USA. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;;; Code: |
| 28 | |
| 29 | (require 'gnus) |
| 30 | |
| 31 | (defvar gnus-cache-directory (concat gnus-article-save-directory "cache/") |
| 32 | "*The directory where cached articles will be stored.") |
| 33 | |
| 34 | (defvar gnus-cache-enter-articles '(ticked dormant) |
| 35 | "*Classes of articles to enter into the cache.") |
| 36 | |
| 37 | (defvar gnus-cache-remove-articles '(read) |
| 38 | "*Classes of articles to remove from the cache.") |
| 39 | |
| 40 | \f |
| 41 | |
| 42 | (defvar gnus-cache-buffer nil) |
| 43 | |
| 44 | \f |
| 45 | |
| 46 | (defun gnus-cache-change-buffer (group) |
| 47 | (and gnus-cache-buffer |
| 48 | ;; see if the current group's overview cache has been loaded |
| 49 | (or (string= group (car gnus-cache-buffer)) |
| 50 | ;; another overview cache is current, save it |
| 51 | (gnus-cache-save-buffers))) |
| 52 | ;; if gnus-cache buffer is nil, create it |
| 53 | (or gnus-cache-buffer |
| 54 | ;; create cache buffer |
| 55 | (save-excursion |
| 56 | (setq gnus-cache-buffer |
| 57 | (cons group |
| 58 | (set-buffer (get-buffer-create " *gnus-cache-overview*")))) |
| 59 | (buffer-disable-undo (current-buffer)) |
| 60 | ;; insert the contents of this groups cache overview |
| 61 | (erase-buffer) |
| 62 | (let ((file (gnus-cache-file-name group ".overview"))) |
| 63 | (and (file-exists-p file) |
| 64 | (insert-file-contents file))) |
| 65 | ;; we have a fresh (empty/just loaded) buffer, |
| 66 | ;; mark it as unmodified to save a redundant write later. |
| 67 | (set-buffer-modified-p nil)))) |
| 68 | |
| 69 | |
| 70 | (defun gnus-cache-save-buffers () |
| 71 | ;; save the overview buffer if it exists and has been modified |
| 72 | ;; delete empty cache subdirectories |
| 73 | (if (null gnus-cache-buffer) |
| 74 | () |
| 75 | (let ((buffer (cdr gnus-cache-buffer)) |
| 76 | (overview-file (gnus-cache-file-name |
| 77 | (car gnus-cache-buffer) ".overview"))) |
| 78 | ;; write the overview only if it was modified |
| 79 | (if (buffer-modified-p buffer) |
| 80 | (save-excursion |
| 81 | (set-buffer buffer) |
| 82 | (if (> (buffer-size) 0) |
| 83 | ;; non-empty overview, write it out |
| 84 | (progn |
| 85 | (gnus-make-directory (file-name-directory overview-file)) |
| 86 | (write-region (point-min) (point-max) |
| 87 | overview-file nil 'quietly)) |
| 88 | ;; empty overview file, remove it |
| 89 | (and (file-exists-p overview-file) |
| 90 | (delete-file overview-file)) |
| 91 | ;; if possible, remove group's cache subdirectory |
| 92 | (condition-case nil |
| 93 | ;; FIXME: we can detect the error type and warn the user |
| 94 | ;; of any inconsistencies (articles w/o nov entries?). |
| 95 | ;; for now, just be conservative...delete only if safe -- sj |
| 96 | (delete-directory (file-name-directory overview-file)) |
| 97 | (error nil))))) |
| 98 | ;; kill the buffer, it's either unmodified or saved |
| 99 | (gnus-kill-buffer buffer) |
| 100 | (setq gnus-cache-buffer nil)))) |
| 101 | |
| 102 | |
| 103 | ;; Return whether an article is a member of a class. |
| 104 | (defun gnus-cache-member-of-class (class ticked dormant unread) |
| 105 | (or (and ticked (memq 'ticked class)) |
| 106 | (and dormant (memq 'dormant class)) |
| 107 | (and unread (memq 'unread class)) |
| 108 | (and (not unread) (memq 'read class)))) |
| 109 | |
| 110 | (defun gnus-cache-file-name (group article) |
| 111 | (concat (file-name-as-directory gnus-cache-directory) |
| 112 | (if (gnus-use-long-file-name 'not-cache) |
| 113 | group |
| 114 | (let ((group (concat group ""))) |
| 115 | (if (string-match ":" group) |
| 116 | (aset group (match-beginning 0) ?/)) |
| 117 | (gnus-replace-chars-in-string group ?. ?/))) |
| 118 | "/" (if (stringp article) article (int-to-string article)))) |
| 119 | |
| 120 | (defun gnus-cache-possibly-enter-article |
| 121 | (group article headers ticked dormant unread) |
| 122 | (let ((number (mail-header-number headers)) |
| 123 | file dir) |
| 124 | (if (or (not (vectorp headers)) ; This might be a dummy article. |
| 125 | (< number 0) ; Reffed article from other group. |
| 126 | (not (gnus-cache-member-of-class |
| 127 | gnus-cache-enter-articles ticked dormant unread)) |
| 128 | (file-exists-p (setq file (gnus-cache-file-name group article)))) |
| 129 | () ; Do nothing. |
| 130 | ;; Possibly create the cache directory. |
| 131 | (or (file-exists-p (setq dir (file-name-directory file))) |
| 132 | (gnus-make-directory dir)) |
| 133 | ;; Save the article in the cache. |
| 134 | (if (file-exists-p file) |
| 135 | t ; The article already is saved, so we end here. |
| 136 | (let ((gnus-use-cache nil)) |
| 137 | (gnus-summary-select-article)) |
| 138 | (save-excursion |
| 139 | (set-buffer gnus-article-buffer) |
| 140 | (save-restriction |
| 141 | (widen) |
| 142 | (write-region (point-min) (point-max) file nil 'quiet)) |
| 143 | (gnus-cache-change-buffer group) |
| 144 | (set-buffer (cdr gnus-cache-buffer)) |
| 145 | (goto-char (point-max)) |
| 146 | (forward-line -1) |
| 147 | (while (condition-case () |
| 148 | (and (not (bobp)) |
| 149 | (> (read (current-buffer)) number)) |
| 150 | (error |
| 151 | ;; The line was malformed, so we just remove it!! |
| 152 | (gnus-delete-line) |
| 153 | t)) |
| 154 | (forward-line -1)) |
| 155 | (if (bobp) |
| 156 | (if (not (eobp)) |
| 157 | (progn |
| 158 | (beginning-of-line) |
| 159 | (if (< (read (current-buffer)) number) |
| 160 | (forward-line 1))) |
| 161 | (beginning-of-line)) |
| 162 | (forward-line 1)) |
| 163 | (beginning-of-line) |
| 164 | ;; [number subject from date id references chars lines xref] |
| 165 | (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n" |
| 166 | (mail-header-number headers) |
| 167 | (mail-header-subject headers) |
| 168 | (mail-header-from headers) |
| 169 | (mail-header-date headers) |
| 170 | (mail-header-id headers) |
| 171 | (or (mail-header-references headers) "") |
| 172 | (or (mail-header-chars headers) "") |
| 173 | (or (mail-header-lines headers) "") |
| 174 | (or (mail-header-xref headers) "")))) |
| 175 | t)))) |
| 176 | |
| 177 | (defun gnus-cache-enter-remove-article (article) |
| 178 | (setq gnus-cache-removable-articles |
| 179 | (cons article gnus-cache-removable-articles))) |
| 180 | |
| 181 | (defsubst gnus-cache-possibly-remove-article |
| 182 | (article ticked dormant unread) |
| 183 | (let ((file (gnus-cache-file-name gnus-newsgroup-name article))) |
| 184 | (if (or (not (file-exists-p file)) |
| 185 | (not (gnus-cache-member-of-class |
| 186 | gnus-cache-remove-articles ticked dormant unread))) |
| 187 | nil |
| 188 | (save-excursion |
| 189 | (delete-file file) |
| 190 | (set-buffer (cdr gnus-cache-buffer)) |
| 191 | (goto-char (point-min)) |
| 192 | (if (or (looking-at (concat (int-to-string article) "\t")) |
| 193 | (search-forward (concat "\n" (int-to-string article) "\t") |
| 194 | (point-max) t)) |
| 195 | (delete-region (progn (beginning-of-line) (point)) |
| 196 | (progn (forward-line 1) (point)))))))) |
| 197 | |
| 198 | (defun gnus-cache-possibly-remove-articles () |
| 199 | (let ((articles gnus-cache-removable-articles) |
| 200 | (cache-articles (gnus-cache-articles-in-group gnus-newsgroup-name)) |
| 201 | article) |
| 202 | (gnus-cache-change-buffer gnus-newsgroup-name) |
| 203 | (while articles |
| 204 | (setq article (car articles) |
| 205 | articles (cdr articles)) |
| 206 | (if (memq article cache-articles) |
| 207 | ;; The article was in the cache, so we see whether we are |
| 208 | ;; supposed to remove it from the cache. |
| 209 | (gnus-cache-possibly-remove-article |
| 210 | article (memq article gnus-newsgroup-marked) |
| 211 | (memq article gnus-newsgroup-dormant) |
| 212 | (or (memq article gnus-newsgroup-unreads) |
| 213 | (memq article gnus-newsgroup-unselected)))))) |
| 214 | ;; the overview file might have been modified, save it |
| 215 | ;; safe because we're only called at group exit anyway |
| 216 | (gnus-cache-save-buffers)) |
| 217 | |
| 218 | |
| 219 | (defun gnus-cache-request-article (article group) |
| 220 | (let ((file (gnus-cache-file-name group article))) |
| 221 | (if (not (file-exists-p file)) |
| 222 | () |
| 223 | (erase-buffer) |
| 224 | ;; There may be some overlays that we have to kill... |
| 225 | (insert "i") |
| 226 | (let ((overlays (overlays-at (point-min)))) |
| 227 | (while overlays |
| 228 | (delete-overlay (car overlays)) |
| 229 | (setq overlays (cdr overlays)))) |
| 230 | (erase-buffer) |
| 231 | (insert-file-contents file) |
| 232 | t))) |
| 233 | |
| 234 | (defun gnus-cache-articles-in-group (group) |
| 235 | (let ((dir (file-name-directory (gnus-cache-file-name group 1))) |
| 236 | articles) |
| 237 | (if (not (file-exists-p dir)) |
| 238 | nil |
| 239 | (setq articles (directory-files dir nil "^[0-9]+$" t)) |
| 240 | (if (not articles) |
| 241 | nil |
| 242 | (sort (mapcar (function (lambda (name) |
| 243 | (string-to-int name))) |
| 244 | articles) |
| 245 | '<))))) |
| 246 | |
| 247 | (defun gnus-cache-active-articles (group) |
| 248 | (let ((articles (gnus-cache-articles-in-group group))) |
| 249 | (and articles |
| 250 | (cons (car articles) (gnus-last-element articles))))) |
| 251 | |
| 252 | (defun gnus-cache-possibly-alter-active (group active) |
| 253 | (let ((cache-active (gnus-cache-active-articles group))) |
| 254 | (and cache-active (< (car cache-active) (car active)) |
| 255 | (setcar active (car cache-active))) |
| 256 | (and cache-active (> (cdr cache-active) (cdr active)) |
| 257 | (setcdr active (cdr cache-active))))) |
| 258 | |
| 259 | (defun gnus-cache-retrieve-headers (articles group) |
| 260 | (let* ((cached (gnus-cache-articles-in-group group)) |
| 261 | (articles (gnus-sorted-complement articles cached)) |
| 262 | (cache-file (gnus-cache-file-name group ".overview")) |
| 263 | type) |
| 264 | (let ((gnus-use-cache nil)) |
| 265 | (setq type (and articles (gnus-retrieve-headers articles group)))) |
| 266 | (gnus-cache-save-buffers) |
| 267 | (save-excursion |
| 268 | (cond ((not (file-exists-p cache-file)) |
| 269 | type) |
| 270 | ((null type) |
| 271 | (set-buffer nntp-server-buffer) |
| 272 | (erase-buffer) |
| 273 | (insert-file-contents cache-file) |
| 274 | 'nov) |
| 275 | ((eq type 'nov) |
| 276 | (gnus-cache-braid-nov group cached) |
| 277 | type) |
| 278 | (t |
| 279 | (gnus-cache-braid-heads group cached) |
| 280 | type))))) |
| 281 | |
| 282 | (defun gnus-cache-braid-nov (group cached) |
| 283 | (let ((cache-buf (get-buffer-create " *gnus-cache*")) |
| 284 | beg end) |
| 285 | (gnus-cache-save-buffers) |
| 286 | (save-excursion |
| 287 | (set-buffer cache-buf) |
| 288 | (buffer-disable-undo (current-buffer)) |
| 289 | (erase-buffer) |
| 290 | (insert-file-contents (gnus-cache-file-name group ".overview")) |
| 291 | (goto-char (point-min)) |
| 292 | (insert "\n") |
| 293 | (goto-char (point-min))) |
| 294 | (set-buffer nntp-server-buffer) |
| 295 | (goto-char (point-min)) |
| 296 | (while cached |
| 297 | (while (and (not (eobp)) |
| 298 | (< (read (current-buffer)) (car cached))) |
| 299 | (forward-line 1)) |
| 300 | (beginning-of-line) |
| 301 | (save-excursion |
| 302 | (set-buffer cache-buf) |
| 303 | (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") |
| 304 | nil t) |
| 305 | (setq beg (progn (beginning-of-line) (point)) |
| 306 | end (progn (end-of-line) (point))) |
| 307 | (setq beg nil))) |
| 308 | (if beg (progn (insert-buffer-substring cache-buf beg end) |
| 309 | (insert "\n"))) |
| 310 | (setq cached (cdr cached))) |
| 311 | (kill-buffer cache-buf))) |
| 312 | |
| 313 | (defun gnus-cache-braid-heads (group cached) |
| 314 | (let ((cache-buf (get-buffer-create " *gnus-cache*"))) |
| 315 | (save-excursion |
| 316 | (set-buffer cache-buf) |
| 317 | (buffer-disable-undo (current-buffer)) |
| 318 | (erase-buffer)) |
| 319 | (set-buffer nntp-server-buffer) |
| 320 | (goto-char (point-min)) |
| 321 | (while cached |
| 322 | (while (and (not (eobp)) |
| 323 | (looking-at "2.. +\\([0-9]+\\) ") |
| 324 | (< (progn (goto-char (match-beginning 1)) |
| 325 | (read (current-buffer))) |
| 326 | (car cached))) |
| 327 | (search-forward "\n.\n" nil 'move)) |
| 328 | (beginning-of-line) |
| 329 | (save-excursion |
| 330 | (set-buffer cache-buf) |
| 331 | (erase-buffer) |
| 332 | (insert-file-contents (gnus-cache-file-name group (car cached))) |
| 333 | (goto-char (point-min)) |
| 334 | (insert "220 " (int-to-string (car cached)) " Article retrieved.\n") |
| 335 | (search-forward "\n\n" nil 'move) |
| 336 | (delete-region (point) (point-max)) |
| 337 | (forward-char -1) |
| 338 | (insert ".")) |
| 339 | (insert-buffer-substring cache-buf) |
| 340 | (setq cached (cdr cached))) |
| 341 | (kill-buffer cache-buf))) |
| 342 | |
| 343 | (defun gnus-jog-cache () |
| 344 | "Go through all groups and put the articles into the cache." |
| 345 | (interactive) |
| 346 | (let ((newsrc (cdr gnus-newsrc-alist)) |
| 347 | (gnus-cache-enter-articles '(unread)) |
| 348 | (gnus-mark-article-hook nil) |
| 349 | (gnus-expert-user t) |
| 350 | (gnus-large-newsgroup nil)) |
| 351 | (while newsrc |
| 352 | (gnus-summary-read-group (car (car newsrc))) |
| 353 | (if (not (eq major-mode 'gnus-summary-mode)) |
| 354 | () |
| 355 | (while gnus-newsgroup-unreads |
| 356 | (gnus-summary-select-article t t nil (car gnus-newsgroup-unreads)) |
| 357 | (setq gnus-newsgroup-unreads (cdr gnus-newsgroup-unreads))) |
| 358 | (kill-buffer (current-buffer))) |
| 359 | (setq newsrc (cdr newsrc))))) |
| 360 | |
| 361 | (provide 'gnus-cache) |
| 362 | |
| 363 | ;;; gnus-cache.el ends here |