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