Mercurial > hg > xemacs-beta
comparison lisp/gnus/gnus-cache.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; gnus-cache.el --- cache interface for Gnus | |
| 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. | |
| 3 | |
| 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
| 5 ;; Keywords: news | |
| 6 | |
| 7 ;; This file is part of GNU Emacs. | |
| 8 | |
| 9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 10 ;; it under the terms of the GNU General Public License as published by | |
| 11 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 12 ;; any later version. | |
| 13 | |
| 14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 17 ;; GNU General Public License for more details. | |
| 18 | |
| 19 ;; You should have received a copy of the GNU General Public License | |
| 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 ;; Boston, MA 02111-1307, USA. | |
| 23 | |
| 24 ;;; Commentary: | |
| 25 | |
| 26 ;;; Code: | |
| 27 | |
| 28 (require 'gnus) | |
| 29 (eval-when-compile (require 'cl)) | |
| 30 | |
| 31 (defvar gnus-cache-directory | |
| 32 (nnheader-concat gnus-directory "cache/") | |
| 33 "*The directory where cached articles will be stored.") | |
| 34 | |
| 35 (defvar gnus-cache-active-file | |
| 36 (concat (file-name-as-directory gnus-cache-directory) "active") | |
| 37 "*The cache active file.") | |
| 38 | |
| 39 (defvar gnus-cache-enter-articles '(ticked dormant) | |
| 40 "*Classes of articles to enter into the cache.") | |
| 41 | |
| 42 (defvar gnus-cache-remove-articles '(read) | |
| 43 "*Classes of articles to remove from the cache.") | |
| 44 | |
| 45 (defvar gnus-uncacheable-groups nil | |
| 46 "*Groups that match this regexp will not be cached. | |
| 47 | |
| 48 If you want to avoid caching your nnml groups, you could set this | |
| 49 variable to \"^nnml\".") | |
| 50 | |
| 51 | |
| 52 | |
| 53 ;;; Internal variables. | |
| 54 | |
| 55 (defvar gnus-cache-buffer nil) | |
| 56 (defvar gnus-cache-active-hashtb nil) | |
| 57 (defvar gnus-cache-active-altered nil) | |
| 58 | |
| 59 (eval-and-compile | |
| 60 (autoload 'nnml-generate-nov-databases-1 "nnml") | |
| 61 (autoload 'nnvirtual-find-group-art "nnvirtual")) | |
| 62 | |
| 63 | |
| 64 | |
| 65 ;;; Functions called from Gnus. | |
| 66 | |
| 67 (defun gnus-cache-open () | |
| 68 "Initialize the cache." | |
| 69 (gnus-cache-read-active)) | |
| 70 | |
| 71 (gnus-add-shutdown 'gnus-cache-close 'gnus) | |
| 72 | |
| 73 (defun gnus-cache-close () | |
| 74 "Shut down the cache." | |
| 75 (gnus-cache-write-active) | |
| 76 (gnus-cache-save-buffers) | |
| 77 (setq gnus-cache-active-hashtb nil)) | |
| 78 | |
| 79 (defun gnus-cache-save-buffers () | |
| 80 ;; save the overview buffer if it exists and has been modified | |
| 81 ;; delete empty cache subdirectories | |
| 82 (if (null gnus-cache-buffer) | |
| 83 () | |
| 84 (let ((buffer (cdr gnus-cache-buffer)) | |
| 85 (overview-file (gnus-cache-file-name | |
| 86 (car gnus-cache-buffer) ".overview"))) | |
| 87 ;; write the overview only if it was modified | |
| 88 (if (buffer-modified-p buffer) | |
| 89 (save-excursion | |
| 90 (set-buffer buffer) | |
| 91 (if (> (buffer-size) 0) | |
| 92 ;; non-empty overview, write it out | |
| 93 (progn | |
| 94 (gnus-make-directory (file-name-directory overview-file)) | |
| 95 (write-region (point-min) (point-max) | |
| 96 overview-file nil 'quietly)) | |
| 97 ;; empty overview file, remove it | |
| 98 (and (file-exists-p overview-file) | |
| 99 (delete-file overview-file)) | |
| 100 ;; if possible, remove group's cache subdirectory | |
| 101 (condition-case nil | |
| 102 ;; FIXME: we can detect the error type and warn the user | |
| 103 ;; of any inconsistencies (articles w/o nov entries?). | |
| 104 ;; for now, just be conservative...delete only if safe -- sj | |
| 105 (delete-directory (file-name-directory overview-file)) | |
| 106 (error nil))))) | |
| 107 ;; kill the buffer, it's either unmodified or saved | |
| 108 (gnus-kill-buffer buffer) | |
| 109 (setq gnus-cache-buffer nil)))) | |
| 110 | |
| 111 (defun gnus-cache-possibly-enter-article | |
| 112 (group article headers ticked dormant unread &optional force) | |
| 113 (when (and (or force (not (eq gnus-use-cache 'passive))) | |
| 114 (numberp article) | |
| 115 (> article 0) | |
| 116 (vectorp headers)) ; This might be a dummy article. | |
| 117 ;; If this is a virtual group, we find the real group. | |
| 118 (when (gnus-virtual-group-p group) | |
| 119 (let ((result (nnvirtual-find-group-art | |
| 120 (gnus-group-real-name group) article))) | |
| 121 (setq group (car result) | |
| 122 headers (copy-sequence headers)) | |
| 123 (mail-header-set-number headers (cdr result)))) | |
| 124 (let ((number (mail-header-number headers)) | |
| 125 file dir) | |
| 126 (when (and (> number 0) ; Reffed article. | |
| 127 (or (not gnus-uncacheable-groups) | |
| 128 (not (string-match gnus-uncacheable-groups group))) | |
| 129 (or force | |
| 130 (gnus-cache-member-of-class | |
| 131 gnus-cache-enter-articles ticked dormant unread)) | |
| 132 (not (file-exists-p (setq file (gnus-cache-file-name | |
| 133 group number))))) | |
| 134 ;; Possibly create the cache directory. | |
| 135 (or (file-exists-p (setq dir (file-name-directory file))) | |
| 136 (gnus-make-directory dir)) | |
| 137 ;; Save the article in the cache. | |
| 138 (if (file-exists-p file) | |
| 139 t ; The article already is saved. | |
| 140 (save-excursion | |
| 141 (set-buffer nntp-server-buffer) | |
| 142 (let ((gnus-use-cache nil)) | |
| 143 (gnus-request-article-this-buffer number group)) | |
| 144 (when (> (buffer-size) 0) | |
| 145 (write-region (point-min) (point-max) file nil 'quiet) | |
| 146 (gnus-cache-change-buffer group) | |
| 147 (set-buffer (cdr gnus-cache-buffer)) | |
| 148 (goto-char (point-max)) | |
| 149 (forward-line -1) | |
| 150 (while (condition-case () | |
| 151 (and (not (bobp)) | |
| 152 (> (read (current-buffer)) number)) | |
| 153 (error | |
| 154 ;; The line was malformed, so we just remove it!! | |
| 155 (gnus-delete-line) | |
| 156 t)) | |
| 157 (forward-line -1)) | |
| 158 (if (bobp) | |
| 159 (if (not (eobp)) | |
| 160 (progn | |
| 161 (beginning-of-line) | |
| 162 (if (< (read (current-buffer)) number) | |
| 163 (forward-line 1))) | |
| 164 (beginning-of-line)) | |
| 165 (forward-line 1)) | |
| 166 (beginning-of-line) | |
| 167 ;; [number subject from date id references chars lines xref] | |
| 168 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n" | |
| 169 (mail-header-number headers) | |
| 170 (mail-header-subject headers) | |
| 171 (mail-header-from headers) | |
| 172 (mail-header-date headers) | |
| 173 (mail-header-id headers) | |
| 174 (or (mail-header-references headers) "") | |
| 175 (or (mail-header-chars headers) "") | |
| 176 (or (mail-header-lines headers) "") | |
| 177 (or (mail-header-xref headers) ""))) | |
| 178 ;; Update the active info. | |
| 179 (set-buffer gnus-summary-buffer) | |
| 180 (gnus-cache-update-active group number) | |
| 181 (push article gnus-newsgroup-cached) | |
| 182 (gnus-summary-update-secondary-mark article)) | |
| 183 t)))))) | |
| 184 | |
| 185 (defun gnus-cache-enter-remove-article (article) | |
| 186 "Mark ARTICLE for later possible removal." | |
| 187 (when article | |
| 188 (push article gnus-cache-removable-articles))) | |
| 189 | |
| 190 (defun gnus-cache-possibly-remove-articles () | |
| 191 "Possibly remove some of the removable articles." | |
| 192 (if (not (gnus-virtual-group-p gnus-newsgroup-name)) | |
| 193 (gnus-cache-possibly-remove-articles-1) | |
| 194 (let ((arts gnus-cache-removable-articles) | |
| 195 ga) | |
| 196 (while arts | |
| 197 (when (setq ga (nnvirtual-find-group-art | |
| 198 (gnus-group-real-name gnus-newsgroup-name) (pop arts))) | |
| 199 (let ((gnus-cache-removable-articles (list (cdr ga))) | |
| 200 (gnus-newsgroup-name (car ga))) | |
| 201 (gnus-cache-possibly-remove-articles-1))))) | |
| 202 (setq gnus-cache-removable-articles nil))) | |
| 203 | |
| 204 (defun gnus-cache-possibly-remove-articles-1 () | |
| 205 "Possibly remove some of the removable articles." | |
| 206 (unless (eq gnus-use-cache 'passive) | |
| 207 (let ((articles gnus-cache-removable-articles) | |
| 208 (cache-articles gnus-newsgroup-cached) | |
| 209 article) | |
| 210 (gnus-cache-change-buffer gnus-newsgroup-name) | |
| 211 (while articles | |
| 212 (if (memq (setq article (pop articles)) cache-articles) | |
| 213 ;; The article was in the cache, so we see whether we are | |
| 214 ;; supposed to remove it from the cache. | |
| 215 (gnus-cache-possibly-remove-article | |
| 216 article (memq article gnus-newsgroup-marked) | |
| 217 (memq article gnus-newsgroup-dormant) | |
| 218 (or (memq article gnus-newsgroup-unreads) | |
| 219 (memq article gnus-newsgroup-unselected)))))) | |
| 220 ;; The overview file might have been modified, save it | |
| 221 ;; safe because we're only called at group exit anyway. | |
| 222 (gnus-cache-save-buffers))) | |
| 223 | |
| 224 (defun gnus-cache-request-article (article group) | |
| 225 "Retrieve ARTICLE in GROUP from the cache." | |
| 226 (let ((file (gnus-cache-file-name group article)) | |
| 227 (buffer-read-only nil)) | |
| 228 (when (file-exists-p file) | |
| 229 (erase-buffer) | |
| 230 (gnus-kill-all-overlays) | |
| 231 (insert-file-contents file) | |
| 232 t))) | |
| 233 | |
| 234 (defun gnus-cache-possibly-alter-active (group active) | |
| 235 "Alter the ACTIVE info for GROUP to reflect the articles in the cache." | |
| 236 (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) | |
| 237 (and cache-active | |
| 238 (< (car cache-active) (car active)) | |
| 239 (setcar active (car cache-active))) | |
| 240 (and cache-active | |
| 241 (> (cdr cache-active) (cdr active)) | |
| 242 (setcdr active (cdr cache-active))))) | |
| 243 | |
| 244 (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) | |
| 245 "Retrieve the headers for ARTICLES in GROUP." | |
| 246 (let ((cached | |
| 247 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) | |
| 248 (if (not cached) | |
| 249 ;; No cached articles here, so we just retrieve them | |
| 250 ;; the normal way. | |
| 251 (let ((gnus-use-cache nil)) | |
| 252 (gnus-retrieve-headers articles group fetch-old)) | |
| 253 (let ((uncached-articles (gnus-sorted-intersection | |
| 254 (gnus-sorted-complement articles cached) | |
| 255 articles)) | |
| 256 (cache-file (gnus-cache-file-name group ".overview")) | |
| 257 type) | |
| 258 ;; We first retrieve all the headers that we don't have in | |
| 259 ;; the cache. | |
| 260 (let ((gnus-use-cache nil)) | |
| 261 (when uncached-articles | |
| 262 (setq type (and articles | |
| 263 (gnus-retrieve-headers | |
| 264 uncached-articles group fetch-old))))) | |
| 265 (gnus-cache-save-buffers) | |
| 266 ;; Then we insert the cached headers. | |
| 267 (save-excursion | |
| 268 (cond | |
| 269 ((not (file-exists-p cache-file)) | |
| 270 ;; There are no cached headers. | |
| 271 type) | |
| 272 ((null type) | |
| 273 ;; There were no uncached headers (or retrieval was | |
| 274 ;; unsuccessful), so we use the cached headers exclusively. | |
| 275 (set-buffer nntp-server-buffer) | |
| 276 (erase-buffer) | |
| 277 (insert-file-contents cache-file) | |
| 278 'nov) | |
| 279 ((eq type 'nov) | |
| 280 ;; We have both cached and uncached NOV headers, so we | |
| 281 ;; braid them. | |
| 282 (gnus-cache-braid-nov group cached) | |
| 283 type) | |
| 284 (t | |
| 285 ;; We braid HEADs. | |
| 286 (gnus-cache-braid-heads group (gnus-sorted-intersection | |
| 287 cached articles)) | |
| 288 type))))))) | |
| 289 | |
| 290 (defun gnus-cache-enter-article (&optional n) | |
| 291 "Enter the next N articles into the cache. | |
| 292 If not given a prefix, use the process marked articles instead. | |
| 293 Returns the list of articles entered." | |
| 294 (interactive "P") | |
| 295 (gnus-set-global-variables) | |
| 296 (let ((articles (gnus-summary-work-articles n)) | |
| 297 article out) | |
| 298 (while articles | |
| 299 (setq article (pop articles)) | |
| 300 (when (gnus-cache-possibly-enter-article | |
| 301 gnus-newsgroup-name article (gnus-summary-article-header article) | |
| 302 nil nil nil t) | |
| 303 (push article out)) | |
| 304 (gnus-summary-remove-process-mark article) | |
| 305 (gnus-summary-update-secondary-mark article)) | |
| 306 (gnus-summary-next-subject 1) | |
| 307 (gnus-summary-position-point) | |
| 308 (nreverse out))) | |
| 309 | |
| 310 (defun gnus-cache-remove-article (n) | |
| 311 "Remove the next N articles from the cache. | |
| 312 If not given a prefix, use the process marked articles instead. | |
| 313 Returns the list of articles removed." | |
| 314 (interactive "P") | |
| 315 (gnus-set-global-variables) | |
| 316 (gnus-cache-change-buffer gnus-newsgroup-name) | |
| 317 (let ((articles (gnus-summary-work-articles n)) | |
| 318 article out) | |
| 319 (while articles | |
| 320 (setq article (pop articles)) | |
| 321 (when (gnus-cache-possibly-remove-article article nil nil nil t) | |
| 322 (push article out)) | |
| 323 (gnus-summary-remove-process-mark article) | |
| 324 (gnus-summary-update-secondary-mark article)) | |
| 325 (gnus-summary-next-subject 1) | |
| 326 (gnus-summary-position-point) | |
| 327 (nreverse out))) | |
| 328 | |
| 329 (defun gnus-cached-article-p (article) | |
| 330 "Say whether ARTICLE is cached in the current group." | |
| 331 (memq article gnus-newsgroup-cached)) | |
| 332 | |
| 333 ;;; Internal functions. | |
| 334 | |
| 335 (defun gnus-cache-change-buffer (group) | |
| 336 (and gnus-cache-buffer | |
| 337 ;; See if the current group's overview cache has been loaded. | |
| 338 (or (string= group (car gnus-cache-buffer)) | |
| 339 ;; Another overview cache is current, save it. | |
| 340 (gnus-cache-save-buffers))) | |
| 341 ;; if gnus-cache buffer is nil, create it | |
| 342 (or gnus-cache-buffer | |
| 343 ;; Create cache buffer | |
| 344 (save-excursion | |
| 345 (setq gnus-cache-buffer | |
| 346 (cons group | |
| 347 (set-buffer (get-buffer-create " *gnus-cache-overview*")))) | |
| 348 (buffer-disable-undo (current-buffer)) | |
| 349 ;; Insert the contents of this group's cache overview. | |
| 350 (erase-buffer) | |
| 351 (let ((file (gnus-cache-file-name group ".overview"))) | |
| 352 (and (file-exists-p file) | |
| 353 (insert-file-contents file))) | |
| 354 ;; We have a fresh (empty/just loaded) buffer, | |
| 355 ;; mark it as unmodified to save a redundant write later. | |
| 356 (set-buffer-modified-p nil)))) | |
| 357 | |
| 358 ;; Return whether an article is a member of a class. | |
| 359 (defun gnus-cache-member-of-class (class ticked dormant unread) | |
| 360 (or (and ticked (memq 'ticked class)) | |
| 361 (and dormant (memq 'dormant class)) | |
| 362 (and unread (memq 'unread class)) | |
| 363 (and (not unread) (not ticked) (not dormant) (memq 'read class)))) | |
| 364 | |
| 365 (defun gnus-cache-file-name (group article) | |
| 366 (concat (file-name-as-directory gnus-cache-directory) | |
| 367 (file-name-as-directory | |
| 368 (if (gnus-use-long-file-name 'not-cache) | |
| 369 group | |
| 370 (let ((group (concat group ""))) | |
| 371 (if (string-match ":" group) | |
| 372 (aset group (match-beginning 0) ?/)) | |
| 373 (nnheader-replace-chars-in-string group ?. ?/)))) | |
| 374 (if (stringp article) article (int-to-string article)))) | |
| 375 | |
| 376 (defun gnus-cache-update-article (group article) | |
| 377 "If ARTICLE is in the cache, remove it and re-enter it." | |
| 378 (when (gnus-cache-possibly-remove-article article nil nil nil t) | |
| 379 (let ((gnus-use-cache nil)) | |
| 380 (gnus-cache-possibly-enter-article | |
| 381 gnus-newsgroup-name article (gnus-summary-article-header article) | |
| 382 nil nil nil t)))) | |
| 383 | |
| 384 (defun gnus-cache-possibly-remove-article (article ticked dormant unread | |
| 385 &optional force) | |
| 386 "Possibly remove ARTICLE from the cache." | |
| 387 (let ((group gnus-newsgroup-name) | |
| 388 (number article) | |
| 389 file) | |
| 390 ;; If this is a virtual group, we find the real group. | |
| 391 (when (gnus-virtual-group-p group) | |
| 392 (let ((result (nnvirtual-find-group-art | |
| 393 (gnus-group-real-name group) article))) | |
| 394 (setq group (car result) | |
| 395 number (cdr result)))) | |
| 396 (setq file (gnus-cache-file-name group number)) | |
| 397 (when (and (file-exists-p file) | |
| 398 (or force | |
| 399 (gnus-cache-member-of-class | |
| 400 gnus-cache-remove-articles ticked dormant unread))) | |
| 401 (save-excursion | |
| 402 (delete-file file) | |
| 403 (set-buffer (cdr gnus-cache-buffer)) | |
| 404 (goto-char (point-min)) | |
| 405 (if (or (looking-at (concat (int-to-string number) "\t")) | |
| 406 (search-forward (concat "\n" (int-to-string number) "\t") | |
| 407 (point-max) t)) | |
| 408 (delete-region (progn (beginning-of-line) (point)) | |
| 409 (progn (forward-line 1) (point))))) | |
| 410 (setq gnus-newsgroup-cached | |
| 411 (delq article gnus-newsgroup-cached)) | |
| 412 (gnus-summary-update-secondary-mark article) | |
| 413 t))) | |
| 414 | |
| 415 (defun gnus-cache-articles-in-group (group) | |
| 416 "Return a sorted list of cached articles in GROUP." | |
| 417 (let ((dir (file-name-directory (gnus-cache-file-name group 1))) | |
| 418 articles) | |
| 419 (when (file-exists-p dir) | |
| 420 (sort (mapcar (lambda (name) (string-to-int name)) | |
| 421 (directory-files dir nil "^[0-9]+$" t)) | |
| 422 '<)))) | |
| 423 | |
| 424 (defun gnus-cache-braid-nov (group cached) | |
| 425 (let ((cache-buf (get-buffer-create " *gnus-cache*")) | |
| 426 beg end) | |
| 427 (gnus-cache-save-buffers) | |
| 428 (save-excursion | |
| 429 (set-buffer cache-buf) | |
| 430 (buffer-disable-undo (current-buffer)) | |
| 431 (erase-buffer) | |
| 432 (insert-file-contents (gnus-cache-file-name group ".overview")) | |
| 433 (goto-char (point-min)) | |
| 434 (insert "\n") | |
| 435 (goto-char (point-min))) | |
| 436 (set-buffer nntp-server-buffer) | |
| 437 (goto-char (point-min)) | |
| 438 (while cached | |
| 439 (while (and (not (eobp)) | |
| 440 (< (read (current-buffer)) (car cached))) | |
| 441 (forward-line 1)) | |
| 442 (beginning-of-line) | |
| 443 (save-excursion | |
| 444 (set-buffer cache-buf) | |
| 445 (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") | |
| 446 nil t) | |
| 447 (setq beg (progn (beginning-of-line) (point)) | |
| 448 end (progn (end-of-line) (point))) | |
| 449 (setq beg nil))) | |
| 450 (if beg (progn (insert-buffer-substring cache-buf beg end) | |
| 451 (insert "\n"))) | |
| 452 (setq cached (cdr cached))) | |
| 453 (kill-buffer cache-buf))) | |
| 454 | |
| 455 (defun gnus-cache-braid-heads (group cached) | |
| 456 (let ((cache-buf (get-buffer-create " *gnus-cache*"))) | |
| 457 (save-excursion | |
| 458 (set-buffer cache-buf) | |
| 459 (buffer-disable-undo (current-buffer)) | |
| 460 (erase-buffer)) | |
| 461 (set-buffer nntp-server-buffer) | |
| 462 (goto-char (point-min)) | |
| 463 (while cached | |
| 464 (while (and (not (eobp)) | |
| 465 (looking-at "2.. +\\([0-9]+\\) ") | |
| 466 (< (progn (goto-char (match-beginning 1)) | |
| 467 (read (current-buffer))) | |
| 468 (car cached))) | |
| 469 (search-forward "\n.\n" nil 'move)) | |
| 470 (beginning-of-line) | |
| 471 (save-excursion | |
| 472 (set-buffer cache-buf) | |
| 473 (erase-buffer) | |
| 474 (insert-file-contents (gnus-cache-file-name group (car cached))) | |
| 475 (goto-char (point-min)) | |
| 476 (insert "220 ") | |
| 477 (princ (car cached) (current-buffer)) | |
| 478 (insert " Article retrieved.\n") | |
| 479 (search-forward "\n\n" nil 'move) | |
| 480 (delete-region (point) (point-max)) | |
| 481 (forward-char -1) | |
| 482 (insert ".")) | |
| 483 (insert-buffer-substring cache-buf) | |
| 484 (setq cached (cdr cached))) | |
| 485 (kill-buffer cache-buf))) | |
| 486 | |
| 487 ;;;###autoload | |
| 488 (defun gnus-jog-cache () | |
| 489 "Go through all groups and put the articles into the cache." | |
| 490 (interactive) | |
| 491 (let ((gnus-mark-article-hook nil) | |
| 492 (gnus-expert-user t) | |
| 493 (nnmail-spool-file nil) | |
| 494 (gnus-use-dribble-file nil) | |
| 495 (gnus-novice-user nil) | |
| 496 (gnus-large-newsgroup nil)) | |
| 497 ;; Start Gnus. | |
| 498 (gnus) | |
| 499 ;; Go through all groups... | |
| 500 (gnus-group-mark-buffer) | |
| 501 (gnus-group-universal-argument | |
| 502 nil nil | |
| 503 (lambda () | |
| 504 (gnus-summary-read-group nil nil t) | |
| 505 ;; ... and enter the articles into the cache. | |
| 506 (when (eq major-mode 'gnus-summary-mode) | |
| 507 (gnus-uu-mark-buffer) | |
| 508 (gnus-cache-enter-article) | |
| 509 (kill-buffer (current-buffer))))))) | |
| 510 | |
| 511 (defun gnus-cache-read-active (&optional force) | |
| 512 "Read the cache active file." | |
| 513 (unless (file-exists-p gnus-cache-directory) | |
| 514 (make-directory gnus-cache-directory t)) | |
| 515 (if (not (and (file-exists-p gnus-cache-active-file) | |
| 516 (or force (not gnus-cache-active-hashtb)))) | |
| 517 ;; There is no active file, so we generate one. | |
| 518 (gnus-cache-generate-active) | |
| 519 ;; We simply read the active file. | |
| 520 (save-excursion | |
| 521 (gnus-set-work-buffer) | |
| 522 (insert-file-contents gnus-cache-active-file) | |
| 523 (gnus-active-to-gnus-format | |
| 524 nil (setq gnus-cache-active-hashtb | |
| 525 (gnus-make-hashtable | |
| 526 (count-lines (point-min) (point-max))))) | |
| 527 (setq gnus-cache-active-altered nil)))) | |
| 528 | |
| 529 (defun gnus-cache-write-active (&optional force) | |
| 530 "Write the active hashtb to the active file." | |
| 531 (when (or force | |
| 532 (and gnus-cache-active-hashtb | |
| 533 gnus-cache-active-altered)) | |
| 534 (save-excursion | |
| 535 (gnus-set-work-buffer) | |
| 536 (mapatoms | |
| 537 (lambda (sym) | |
| 538 (when (and sym (boundp sym)) | |
| 539 (insert (format "%s %d %d y\n" | |
| 540 (symbol-name sym) (cdr (symbol-value sym)) | |
| 541 (car (symbol-value sym)))))) | |
| 542 gnus-cache-active-hashtb) | |
| 543 (gnus-make-directory (file-name-directory gnus-cache-active-file)) | |
| 544 (write-region | |
| 545 (point-min) (point-max) gnus-cache-active-file nil 'silent)) | |
| 546 ;; Mark the active hashtb as unaltered. | |
| 547 (setq gnus-cache-active-altered nil))) | |
| 548 | |
| 549 (defun gnus-cache-update-active (group number &optional low) | |
| 550 "Update the upper bound of the active info of GROUP to NUMBER. | |
| 551 If LOW, update the lower bound instead." | |
| 552 (let ((active (gnus-gethash group gnus-cache-active-hashtb))) | |
| 553 (if (null active) | |
| 554 ;; We just create a new active entry for this group. | |
| 555 (gnus-sethash group (cons number number) gnus-cache-active-hashtb) | |
| 556 ;; Update the lower or upper bound. | |
| 557 (if low | |
| 558 (setcar active number) | |
| 559 (setcdr active number)) | |
| 560 ;; Mark the active hashtb as altered. | |
| 561 (setq gnus-cache-active-altered t)))) | |
| 562 | |
| 563 ;;;###autoload | |
| 564 (defun gnus-cache-generate-active (&optional directory) | |
| 565 "Generate the cache active file." | |
| 566 (interactive) | |
| 567 (let* ((top (null directory)) | |
| 568 (directory (expand-file-name (or directory gnus-cache-directory))) | |
| 569 (files (directory-files directory 'full)) | |
| 570 (group | |
| 571 (if top | |
| 572 "" | |
| 573 (string-match | |
| 574 (concat "^" (file-name-as-directory | |
| 575 (expand-file-name gnus-cache-directory))) | |
| 576 (directory-file-name directory)) | |
| 577 (nnheader-replace-chars-in-string | |
| 578 (substring (directory-file-name directory) (match-end 0)) | |
| 579 ?/ ?.))) | |
| 580 nums alphs) | |
| 581 (when top | |
| 582 (gnus-message 5 "Generating the cache active file...") | |
| 583 (setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) | |
| 584 ;; Separate articles from all other files and directories. | |
| 585 (while files | |
| 586 (if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) | |
| 587 (push (string-to-int (file-name-nondirectory (pop files))) nums) | |
| 588 (push (pop files) alphs))) | |
| 589 ;; If we have nums, then this is probably a valid group. | |
| 590 (when (setq nums (sort nums '<)) | |
| 591 (gnus-sethash group (cons (car nums) (gnus-last-element nums)) | |
| 592 gnus-cache-active-hashtb)) | |
| 593 ;; Go through all the other files. | |
| 594 (while alphs | |
| 595 (when (and (file-directory-p (car alphs)) | |
| 596 (not (string-match "^\\.\\.?$" | |
| 597 (file-name-nondirectory (car alphs))))) | |
| 598 ;; We descend directories. | |
| 599 (gnus-cache-generate-active (car alphs))) | |
| 600 (setq alphs (cdr alphs))) | |
| 601 ;; Write the new active file. | |
| 602 (when top | |
| 603 (gnus-cache-write-active t) | |
| 604 (gnus-message 5 "Generating the cache active file...done")))) | |
| 605 | |
| 606 ;;;###autoload | |
| 607 (defun gnus-cache-generate-nov-databases (dir) | |
| 608 "Generate NOV files recursively starting in DIR." | |
| 609 (interactive (list gnus-cache-directory)) | |
| 610 (gnus-cache-close) | |
| 611 (let ((nnml-generate-active-function 'identity)) | |
| 612 (nnml-generate-nov-databases-1 dir))) | |
| 613 | |
| 614 (provide 'gnus-cache) | |
| 615 | |
| 616 ;;; gnus-cache.el ends here |