gnus-cache.el 31.1 KB
Newer Older
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
1
;;; gnus-cache.el --- cache interface for Gnus
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1995-2019 Free Software Foundation, Inc.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
4

5
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
6 7 8 9
;; Keywords: news

;; This file is part of GNU Emacs.

10
;; GNU Emacs is free software: you can redistribute it and/or modify
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
14 15 16 17 18 19 20

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
21
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
22 23 24 25 26

;;; Commentary:

;;; Code:

Glenn Morris's avatar
Glenn Morris committed
27
(eval-when-compile (require 'cl-lib))
28

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
29
(require 'gnus)
30 31
(require 'gnus-sum)

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
32
(eval-when-compile
33
  (unless (fboundp 'gnus-agent-load-alist)
34
    (defun gnus-agent-load-alist (group))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
35 36

(defcustom gnus-cache-active-file
37
  (expand-file-name "active" gnus-cache-directory)
38
  "The cache active file."
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
39 40 41 42 43 44 45 46 47 48 49 50 51
  :group 'gnus-cache
  :type 'file)

(defcustom gnus-cache-enter-articles '(ticked dormant)
  "Classes of articles to enter into the cache."
  :group 'gnus-cache
  :type '(set (const ticked) (const dormant) (const unread) (const read)))

(defcustom gnus-cache-remove-articles '(read)
  "Classes of articles to remove from the cache."
  :group 'gnus-cache
  :type '(set (const ticked) (const dormant) (const unread) (const read)))

52
(defcustom gnus-cacheable-groups nil
53
  "Groups that match this regexp will be cached.
54 55 56 57 58 59 60 61

If you only want to cache your nntp groups, you could set this
variable to \"^nntp\".

If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
it's not cached."
  :group 'gnus-cache
  :type '(choice (const :tag "off" nil)
62
		 regexp))
63

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
64
(defcustom gnus-uncacheable-groups nil
65
  "Groups that match this regexp will not be cached.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
66 67

If you want to avoid caching your nnml groups, you could set this
68 69 70 71
variable to \"^nnml\".

If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
it's not cached."
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
72 73 74 75
  :group 'gnus-cache
  :type '(choice (const :tag "off" nil)
		 regexp))

76 77 78
(defvar gnus-cache-overview-coding-system 'raw-text
  "Coding system used on Gnus cache files.")

79 80 81
(defvar gnus-cache-coding-system 'raw-text
  "Coding system used on Gnus cache files.")

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
82 83 84 85 86 87 88 89


;;; Internal variables.

(defvar gnus-cache-removable-articles nil)
(defvar gnus-cache-buffer nil)
(defvar gnus-cache-active-hashtb nil)
(defvar gnus-cache-active-altered nil)
90
(defvar gnus-cache-total-fetched-hashtb nil)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
91

92 93
(declare-function nnvirtual-find-group-art "nnvirtual" (group article))

94 95
(autoload 'nnml-generate-nov-databases-directory "nnml")
(autoload 'nnvirtual-find-group-art "nnvirtual")
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125



;;; Functions called from Gnus.

(defun gnus-cache-open ()
  "Initialize the cache."
  (when (or (file-exists-p gnus-cache-directory)
	    (and gnus-use-cache
		 (not (eq gnus-use-cache 'passive))))
    (gnus-cache-read-active)))

;; Complexities of byte-compiling make this kludge necessary.  Eeek.
(ignore-errors
  (gnus-add-shutdown 'gnus-cache-close 'gnus))

(defun gnus-cache-close ()
  "Shut down the cache."
  (gnus-cache-write-active)
  (gnus-cache-save-buffers)
  (setq gnus-cache-active-hashtb nil))

(defun gnus-cache-save-buffers ()
  ;; save the overview buffer if it exists and has been modified
  ;; delete empty cache subdirectories
  (when gnus-cache-buffer
    (let ((buffer (cdr gnus-cache-buffer))
	  (overview-file (gnus-cache-file-name
			  (car gnus-cache-buffer) ".overview")))
      ;; write the overview only if it was modified
126 127
      (when (and (buffer-live-p buffer) (buffer-modified-p buffer))
	(with-current-buffer buffer
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
128 129
	  (if (> (buffer-size) 0)
	      ;; Non-empty overview, write it to a file.
130 131 132
	      (let ((coding-system-for-write
		     gnus-cache-overview-coding-system))
		(gnus-write-buffer overview-file))
133 134 135 136 137 138 139 140 141 142 143 144 145 146
	    (let ((file-name-coding-system nnmail-pathname-coding-system))
	      ;; Empty overview file, remove it
	      (when (file-exists-p overview-file)
		(delete-file overview-file))
	      ;; If possible, remove group's cache subdirectory.
	      (condition-case nil
		  ;; FIXME: we can detect the error type and warn the user
		  ;; of any inconsistencies (articles w/o nov entries?).
		  ;; for now, just be conservative...delete only if safe -- sj
		  (delete-directory (file-name-directory overview-file))
		(error))))

	  (gnus-cache-update-overview-total-fetched-for
	   (car gnus-cache-buffer) overview-file)))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
147 148 149 150 151
      ;; Kill the buffer -- it's either unmodified or saved.
      (gnus-kill-buffer buffer)
      (setq gnus-cache-buffer nil))))

(defun gnus-cache-possibly-enter-article
152
  (group article ticked dormant unread &optional force)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
153 154
  (when (and (or force (not (eq gnus-use-cache 'passive)))
	     (numberp article)
155
	     (> article 0))		; This might be a dummy article.
156 157 158
    (let ((number article)
	  file headers lines-chars
	  (file-name-coding-system nnmail-pathname-coding-system))
159 160 161 162 163 164
      ;; If this is a virtual group, we find the real group.
      (when (gnus-virtual-group-p group)
	(let ((result (nnvirtual-find-group-art
		       (gnus-group-real-name group) article)))
	  (setq group (car result)
		number (cdr result))))
165 166
      (when (and number
		 (> number 0)		; Reffed article.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
167
		 (or force
168
		     (and (gnus-cache-fully-p group)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
169 170 171 172 173
			  (gnus-cache-member-of-class
			   gnus-cache-enter-articles ticked dormant unread)))
		 (not (file-exists-p (setq file (gnus-cache-file-name
						 group number)))))
	;; Possibly create the cache directory.
174
	(gnus-make-directory (file-name-directory file))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
175 176 177
	;; Save the article in the cache.
	(if (file-exists-p file)
	    t				; The article already is saved.
178
	  (with-current-buffer nntp-server-buffer
179 180 181
	    (require 'gnus-art)
	    (let ((gnus-use-cache nil)
		  (gnus-article-decode-hook nil))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
182 183
	      (gnus-request-article-this-buffer number group))
	    (when (> (buffer-size) 0)
184
	      (let ((coding-system-for-write gnus-cache-coding-system))
185 186 187
		(gnus-write-buffer file)
		(gnus-cache-update-file-total-fetched-for group file))
	      (setq lines-chars (nnheader-get-lines-and-char))
188 189
	      (nnheader-remove-body)
	      (setq headers (nnheader-parse-naked-head))
190
	      (mail-header-set-number headers number)
191 192
	      (mail-header-set-lines headers (car lines-chars))
	      (mail-header-set-chars headers (cadr lines-chars))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
	      (gnus-cache-change-buffer group)
	      (set-buffer (cdr gnus-cache-buffer))
	      (goto-char (point-max))
	      (forward-line -1)
	      (while (condition-case ()
			 (when (not (bobp))
			   (> (read (current-buffer)) number))
		       (error
			;; The line was malformed, so we just remove it!!
			(gnus-delete-line)
			t))
		(forward-line -1))
	      (if (bobp)
		  (if (not (eobp))
		      (progn
			(beginning-of-line)
			(when (< (read (current-buffer)) number)
			  (forward-line 1)))
		    (beginning-of-line))
		(forward-line 1))
	      (beginning-of-line)
214
	      (nnheader-insert-nov headers)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
215 216
	      ;; Update the active info.
	      (set-buffer gnus-summary-buffer)
217 218 219
	      (gnus-cache-possibly-update-active group (cons number number))
	      (setq gnus-newsgroup-cached
		    (gnus-add-to-sorted-list gnus-newsgroup-cached article))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
	      (gnus-summary-update-secondary-mark article))
	    t))))))

(defun gnus-cache-enter-remove-article (article)
  "Mark ARTICLE for later possible removal."
  (when article
    (push article gnus-cache-removable-articles)))

(defun gnus-cache-possibly-remove-articles ()
  "Possibly remove some of the removable articles."
  (if (not (gnus-virtual-group-p gnus-newsgroup-name))
      (gnus-cache-possibly-remove-articles-1)
    (let ((arts gnus-cache-removable-articles)
	  ga)
      (while arts
	(when (setq ga (nnvirtual-find-group-art
			(gnus-group-real-name gnus-newsgroup-name) (pop arts)))
	  (let ((gnus-cache-removable-articles (list (cdr ga)))
		(gnus-newsgroup-name (car ga)))
	    (gnus-cache-possibly-remove-articles-1)))))
    (setq gnus-cache-removable-articles nil)))

(defun gnus-cache-possibly-remove-articles-1 ()
  "Possibly remove some of the removable articles."
244
  (when (gnus-cache-fully-p gnus-newsgroup-name)
245
    (let ((cache-articles gnus-newsgroup-cached))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
246
      (gnus-cache-change-buffer gnus-newsgroup-name)
247 248
      (dolist (article gnus-cache-removable-articles)
	(when (memq article cache-articles)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
249 250 251 252 253 254 255 256 257 258 259 260 261 262
	  ;; The article was in the cache, so we see whether we are
	  ;; supposed to remove it from the cache.
	  (gnus-cache-possibly-remove-article
	   article (memq article gnus-newsgroup-marked)
	   (memq article gnus-newsgroup-dormant)
	   (or (memq article gnus-newsgroup-unreads)
	       (memq article gnus-newsgroup-unselected))))))
    ;; The overview file might have been modified, save it
    ;; safe because we're only called at group exit anyway.
    (gnus-cache-save-buffers)))

(defun gnus-cache-request-article (article group)
  "Retrieve ARTICLE in GROUP from the cache."
  (let ((file (gnus-cache-file-name group article))
263 264
	(buffer-read-only nil)
	(file-name-coding-system nnmail-pathname-coding-system))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
265 266 267
    (when (file-exists-p file)
      (erase-buffer)
      (gnus-kill-all-overlays)
268 269
      (let ((coding-system-for-read gnus-cache-coding-system))
	(insert-file-contents file))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
270 271 272 273 274
      t)))

(defun gnus-cache-possibly-alter-active (group active)
  "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
  (when gnus-cache-active-hashtb
275
    (let ((cache-active (gethash group gnus-cache-active-hashtb)))
276 277 278 279 280
      (when cache-active
	(when (< (car cache-active) (car active))
	  (setcar active (car cache-active)))
	(when (> (cdr cache-active) (cdr active))
	  (setcdr active (cdr cache-active)))))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
281 282 283 284 285 286 287 288 289 290

(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
  "Retrieve the headers for ARTICLES in GROUP."
  (let ((cached
	 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
    (if (not cached)
	;; No cached articles here, so we just retrieve them
	;; the normal way.
	(let ((gnus-use-cache nil))
	  (gnus-retrieve-headers articles group fetch-old))
291
      (let ((uncached-articles (gnus-sorted-difference articles cached))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
292
	    (cache-file (gnus-cache-file-name group ".overview"))
293 294
	    type
	    (file-name-coding-system nnmail-pathname-coding-system))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
	;; We first retrieve all the headers that we don't have in
	;; the cache.
	(let ((gnus-use-cache nil))
	  (when uncached-articles
	    (setq type (and articles
			    (gnus-retrieve-headers
			     uncached-articles group fetch-old)))))
	(gnus-cache-save-buffers)
	;; Then we insert the cached headers.
	(save-excursion
	  (cond
	   ((not (file-exists-p cache-file))
	    ;; There are no cached headers.
	    type)
	   ((null type)
	    ;; There were no uncached headers (or retrieval was
	    ;; unsuccessful), so we use the cached headers exclusively.
	    (set-buffer nntp-server-buffer)
	    (erase-buffer)
314
	    (let ((coding-system-for-read
315 316
		   gnus-cache-overview-coding-system))
	      (insert-file-contents cache-file))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333
	    'nov)
	   ((eq type 'nov)
	    ;; We have both cached and uncached NOV headers, so we
	    ;; braid them.
	    (gnus-cache-braid-nov group cached)
	    type)
	   (t
	    ;; We braid HEADs.
	    (gnus-cache-braid-heads group (gnus-sorted-intersection
					   cached articles))
	    type)))))))

(defun gnus-cache-enter-article (&optional n)
  "Enter the next N articles into the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles entered."
  (interactive "P")
334 335
  (let (out)
    (dolist (article (gnus-summary-work-articles n))
336
      (gnus-summary-remove-process-mark article)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
337 338 339 340
      (if (natnump article)
	  (when (gnus-cache-possibly-enter-article
		 gnus-newsgroup-name article
		 nil nil nil t)
341
            (setq gnus-newsgroup-undownloaded (delq article gnus-newsgroup-undownloaded))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
342 343
	    (push article out))
	(gnus-message 2 "Can't cache article %d" article))
344
      (gnus-summary-update-download-mark article)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
345 346 347 348 349
      (gnus-summary-update-secondary-mark article))
    (gnus-summary-next-subject 1)
    (gnus-summary-position-point)
    (nreverse out)))

350
(defun gnus-cache-remove-article (&optional n)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
351 352 353 354 355
  "Remove the next N articles from the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles removed."
  (interactive "P")
  (gnus-cache-change-buffer gnus-newsgroup-name)
356 357
  (let (out)
    (dolist (article (gnus-summary-work-articles n))
358
      (gnus-summary-remove-process-mark article)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
359
      (when (gnus-cache-possibly-remove-article article nil nil nil t)
360 361 362 363
        (when gnus-newsgroup-agentized
          (let ((alist (gnus-agent-load-alist gnus-newsgroup-name)))
            (unless (cdr (assoc article alist))
              (setq gnus-newsgroup-undownloaded
364
                    (gnus-add-to-sorted-list
365
                     gnus-newsgroup-undownloaded article)))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
366
	(push article out))
367
      (gnus-summary-update-download-mark article)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
368 369 370 371 372 373 374 375 376 377 378 379
      (gnus-summary-update-secondary-mark article))
    (gnus-summary-next-subject 1)
    (gnus-summary-position-point)
    (nreverse out)))

(defun gnus-cached-article-p (article)
  "Say whether ARTICLE is cached in the current group."
  (memq article gnus-newsgroup-cached))

(defun gnus-summary-insert-cached-articles ()
  "Insert all the articles cached for this group into the current buffer."
  (interactive)
380
  (let ((gnus-verbose (max 6 gnus-verbose)))
381 382 383 384 385 386 387 388
    (cond
     ((not gnus-newsgroup-cached)
      (gnus-message 3 "No cached articles for this group"))
     ;; This is faster if there are few articles to insert.
     ((< (length gnus-newsgroup-cached) 20)
      (gnus-summary-goto-subjects gnus-newsgroup-cached))
     (t
      (gnus-summary-include-articles gnus-newsgroup-cached)))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
389

390 391 392 393 394 395 396 397 398
(defun gnus-summary-limit-include-cached ()
  "Limit the summary buffer to articles that are cached."
  (interactive)
  (let ((gnus-verbose (max 6 gnus-verbose)))
    (if gnus-newsgroup-cached
	(progn
	  (gnus-summary-limit gnus-newsgroup-cached)
	  (gnus-summary-position-point))
      (gnus-message 3 "No cached articles for this group"))))
399

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
400 401 402 403 404 405 406 407 408 409 410 411 412 413
;;; Internal functions.

(defun gnus-cache-change-buffer (group)
  (and gnus-cache-buffer
       ;; See if the current group's overview cache has been loaded.
       (or (string= group (car gnus-cache-buffer))
	   ;; Another overview cache is current, save it.
	   (gnus-cache-save-buffers)))
  ;; if gnus-cache buffer is nil, create it
  (unless gnus-cache-buffer
    ;; Create cache buffer
    (save-excursion
      (setq gnus-cache-buffer
	    (cons group
414 415
		  (set-buffer (gnus-get-buffer-create
			       " *gnus-cache-overview*"))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
416 417
      ;; Insert the contents of this group's cache overview.
      (erase-buffer)
418 419
      (let ((file (gnus-cache-file-name group ".overview"))
	    (file-name-coding-system nnmail-pathname-coding-system))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
420 421 422 423 424 425 426 427 428 429 430 431 432 433
	(when (file-exists-p file)
	  (nnheader-insert-file-contents file)))
      ;; We have a fresh (empty/just loaded) buffer,
      ;; mark it as unmodified to save a redundant write later.
      (set-buffer-modified-p nil))))

;; Return whether an article is a member of a class.
(defun gnus-cache-member-of-class (class ticked dormant unread)
  (or (and ticked (memq 'ticked class))
      (and dormant (memq 'dormant class))
      (and unread (memq 'unread class))
      (and (not unread) (not ticked) (not dormant) (memq 'read class))))

(defun gnus-cache-file-name (group article)
434 435 436 437 438 439 440 441 442 443 444 445
  (expand-file-name
   (if (stringp article) article (int-to-string article))
   (file-name-as-directory
    (expand-file-name
     (nnheader-translate-file-chars
      (if (gnus-use-long-file-name 'not-cache)
	  group
	(let ((group (nnheader-replace-duplicate-chars-in-string
		      (nnheader-replace-chars-in-string group ?/ ?_)
		      ?. ?_)))
	  ;; Translate the first colon into a slash.
	  (when (string-match ":" group)
446 447
		  (setq group (concat (substring group 0 (match-beginning 0))
				      "/" (substring group (match-end 0)))))
448 449 450
	  (nnheader-replace-chars-in-string group ?. ?/)))
      t)
     gnus-cache-directory))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
451 452 453

(defun gnus-cache-update-article (group article)
  "If ARTICLE is in the cache, remove it and re-enter it."
454
  (gnus-cache-change-buffer group)
455
  (when (gnus-cache-possibly-remove-article article nil nil nil t)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
456 457
    (let ((gnus-use-cache nil))
      (gnus-cache-possibly-enter-article
458
       gnus-newsgroup-name article
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
459 460 461 462 463 464 465
       nil nil nil t))))

(defun gnus-cache-possibly-remove-article (article ticked dormant unread
						   &optional force)
  "Possibly remove ARTICLE from the cache."
  (let ((group gnus-newsgroup-name)
	(number article)
466 467
	file
	(file-name-coding-system nnmail-pathname-coding-system))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
468 469 470 471 472 473 474 475 476 477 478 479
    ;; If this is a virtual group, we find the real group.
    (when (gnus-virtual-group-p group)
      (let ((result (nnvirtual-find-group-art
		     (gnus-group-real-name group) article)))
	(setq group (car result)
	      number (cdr result))))
    (setq file (gnus-cache-file-name group number))
    (when (and (file-exists-p file)
	       (or force
		   (gnus-cache-member-of-class
		    gnus-cache-remove-articles ticked dormant unread)))
      (save-excursion
480
	(gnus-cache-update-file-total-fetched-for group file t)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
481
	(delete-file file)
482

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
483 484 485 486 487
	(set-buffer (cdr gnus-cache-buffer))
	(goto-char (point-min))
	(when (or (looking-at (concat (int-to-string number) "\t"))
		  (search-forward (concat "\n" (int-to-string number) "\t")
				  (point-max) t))
488
	    (gnus-delete-line)))
489 490
      (unless (setq gnus-newsgroup-cached
		    (delq article gnus-newsgroup-cached))
491
	(remhash gnus-newsgroup-name gnus-cache-active-hashtb)
492
	(setq gnus-cache-active-altered t))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
493 494 495 496 497
      (gnus-summary-update-secondary-mark article)
      t)))

(defun gnus-cache-articles-in-group (group)
  "Return a sorted list of cached articles in GROUP."
498
  (let ((dir (file-name-directory (gnus-cache-file-name group 1)))
499 500
	articles
	(file-name-coding-system nnmail-pathname-coding-system))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
501
    (when (file-exists-p dir)
502
      (setq articles
503
	    (sort (mapcar (lambda (name) (string-to-number name))
504 505 506
			  (directory-files dir nil "^[0-9]+$" t))
		  '<))
      ;; Update the cache active file, just to synch more.
507 508 509 510
      (if articles
	  (progn
	    (gnus-cache-update-active group (car articles) t)
	    (gnus-cache-update-active group (car (last articles))))
511 512
	(when (gethash group gnus-cache-active-hashtb)
	  (remhash group gnus-cache-active-hashtb)
513
	  (setq gnus-cache-active-altered t)))
514 515 516
      articles)))

(defun gnus-cache-braid-nov (group cached &optional file)
517
  (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
518 519
	beg end)
    (gnus-cache-save-buffers)
520
    (with-current-buffer cache-buf
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
521
      (erase-buffer)
522 523
      (let ((coding-system-for-read gnus-cache-overview-coding-system)
	    (file-name-coding-system nnmail-pathname-coding-system))
524
	(insert-file-contents
525
	 (or file (gnus-cache-file-name group ".overview"))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
526 527 528 529 530 531 532 533 534 535
      (goto-char (point-min))
      (insert "\n")
      (goto-char (point-min)))
    (set-buffer nntp-server-buffer)
    (goto-char (point-min))
    (while cached
      (while (and (not (eobp))
		  (< (read (current-buffer)) (car cached)))
	(forward-line 1))
      (beginning-of-line)
536 537 538
      (set-buffer cache-buf)
      (if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
			  nil t)
539
	  (setq beg (point-at-bol)
540 541 542
		end (progn (end-of-line) (point)))
	(setq beg nil))
      (set-buffer nntp-server-buffer)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
543 544 545 546 547 548 549
      (when beg
	(insert-buffer-substring cache-buf beg end)
	(insert "\n"))
      (setq cached (cdr cached)))
    (kill-buffer cache-buf)))

(defun gnus-cache-braid-heads (group cached)
550
  (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
551
    (with-current-buffer cache-buf
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
552 553 554
      (erase-buffer))
    (set-buffer nntp-server-buffer)
    (goto-char (point-min))
555
    (dolist (entry cached)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
556 557 558 559
      (while (and (not (eobp))
		  (looking-at "2.. +\\([0-9]+\\) ")
		  (< (progn (goto-char (match-beginning 1))
			    (read (current-buffer)))
560
		     entry))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
561 562
	(search-forward "\n.\n" nil 'move))
      (beginning-of-line)
563 564
      (set-buffer cache-buf)
      (erase-buffer)
565 566 567
      (let ((coding-system-for-read gnus-cache-coding-system)
	    (file-name-coding-system nnmail-pathname-coding-system))
	(insert-file-contents (gnus-cache-file-name group entry)))
568 569
      (goto-char (point-min))
      (insert "220 ")
570
      (princ (pop cached) (current-buffer))
571 572 573 574 575 576
      (insert " Article retrieved.\n")
      (search-forward "\n\n" nil 'move)
      (delete-region (point) (point-max))
      (forward-char -1)
      (insert ".")
      (set-buffer nntp-server-buffer)
577
      (insert-buffer-substring cache-buf))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
578 579 580 581 582 583 584 585 586 587 588
    (kill-buffer cache-buf)))

;;;###autoload
(defun gnus-jog-cache ()
  "Go through all groups and put the articles into the cache.

Usage:
$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
  (interactive)
  (let ((gnus-mark-article-hook nil)
	(gnus-expert-user t)
589
	(mail-sources nil)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
590 591 592 593 594 595 596
	(gnus-use-dribble-file nil)
	(gnus-novice-user nil)
	(gnus-large-newsgroup nil))
    ;; Start Gnus.
    (gnus)
    ;; Go through all groups...
    (gnus-group-mark-buffer)
597 598 599 600 601 602 603 604 605
    (gnus-group-iterate nil
      (lambda (group)
	(let (gnus-auto-select-next)
	  (gnus-summary-read-group group nil t)
	  ;; ... and enter the articles into the cache.
	  (when (eq major-mode 'gnus-summary-mode)
	    (gnus-uu-mark-buffer)
	    (gnus-cache-enter-article)
	    (kill-buffer (current-buffer))))))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
606 607 608 609

(defun gnus-cache-read-active (&optional force)
  "Read the cache active file."
  (gnus-make-directory gnus-cache-directory)
610
  (if (or (not (file-exists-p gnus-cache-active-file))
Paul Eggert's avatar
Paul Eggert committed
611 612
	  (zerop (file-attribute-size
		  (file-attributes gnus-cache-active-file)))
613
	  force)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
614 615 616 617 618
      ;; There is no active file, so we generate one.
      (gnus-cache-generate-active)
    ;; We simply read the active file.
    (save-excursion
      (gnus-set-work-buffer)
619
      (nnheader-insert-file-contents gnus-cache-active-file)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
620 621 622 623 624 625 626 627 628 629 630
      (gnus-active-to-gnus-format
       nil (setq gnus-cache-active-hashtb
		 (gnus-make-hashtable
		  (count-lines (point-min) (point-max)))))
      (setq gnus-cache-active-altered nil))))

(defun gnus-cache-write-active (&optional force)
  "Write the active hashtb to the active file."
  (when (or force
	    (and gnus-cache-active-hashtb
		 gnus-cache-active-altered))
631
    (gnus-write-active-file gnus-cache-active-file gnus-cache-active-hashtb t)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
632 633 634
    ;; Mark the active hashtb as unaltered.
    (setq gnus-cache-active-altered nil)))

635 636 637
;; FIXME: Why is there a `gnus-cache-possibly-alter-active',
;; `gnus-cache-possibly-update-active', and
;; `gnus-cache-update-active'?  Do we really need all three?
638 639 640 641 642 643
(defun gnus-cache-possibly-update-active (group active)
  "Update active info bounds of GROUP with ACTIVE if necessary.
The update is performed if ACTIVE contains a higher or lower bound
than the current."
  (let ((lower t) (higher t))
    (if gnus-cache-active-hashtb
644
	(let ((cache-active (gethash group gnus-cache-active-hashtb)))
645 646 647 648 649 650 651 652 653 654 655
	  (when cache-active
	    (unless (< (car active) (car cache-active))
	      (setq lower nil))
	    (unless (> (cdr active) (cdr cache-active))
	      (setq higher nil))))
      (gnus-cache-read-active))
    (when lower
      (gnus-cache-update-active group (car active) t))
    (when higher
      (gnus-cache-update-active group (cdr active)))))

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
656 657 658
(defun gnus-cache-update-active (group number &optional low)
  "Update the upper bound of the active info of GROUP to NUMBER.
If LOW, update the lower bound instead."
659
  (let ((active (gethash group gnus-cache-active-hashtb)))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
660 661
    (if (null active)
	;; We just create a new active entry for this group.
662
	(puthash group (cons number number) gnus-cache-active-hashtb)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
663 664 665 666 667 668 669 670 671 672 673 674 675
      ;; Update the lower or upper bound.
      (if low
	  (setcar active number)
	(setcdr active number)))
    ;; Mark the active hashtb as altered.
    (setq gnus-cache-active-altered t)))

;;;###autoload
(defun gnus-cache-generate-active (&optional directory)
  "Generate the cache active file."
  (interactive)
  (let* ((top (null directory))
	 (directory (expand-file-name (or directory gnus-cache-directory)))
676
	 (file-name-coding-system nnmail-pathname-coding-system)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
677 678 679 680 681
	 (files (directory-files directory 'full))
	 (group
	  (if top
	      ""
	    (string-match
682 683 684
	     (concat "^" (regexp-quote
			  (file-name-as-directory
			   (expand-file-name gnus-cache-directory))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
685 686 687 688 689 690 691 692
	     (directory-file-name directory))
	    (nnheader-replace-chars-in-string
	     (substring (directory-file-name directory) (match-end 0))
	     ?/ ?.)))
	 nums alphs)
    (when top
      (gnus-message 5 "Generating the cache active file...")
      (setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
693
    (when (string-match "^\\(nn[^_]+\\)_" group)
694
      (setq group (replace-match "\\1:" t nil group)))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
695 696 697
    ;; Separate articles from all other files and directories.
    (while files
      (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
698
	  (push (string-to-number (file-name-nondirectory (pop files))) nums)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
699 700 701
	(push (pop files) alphs)))
    ;; If we have nums, then this is probably a valid group.
    (when (setq nums (sort nums '<))
702
      (puthash group
703 704
	       (cons (car nums) (car (last nums)))
	       gnus-cache-active-hashtb))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
705
    ;; Go through all the other files.
706 707
    (dolist (file alphs)
      (when (and (file-directory-p file)
708
		 (not (string-match "^\\."
709
				    (file-name-nondirectory file))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
710
	;; We descend directories.
711
	(gnus-cache-generate-active file)))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
712 713 714 715 716 717 718 719 720 721 722
    ;; Write the new active file.
    (when top
      (gnus-cache-write-active t)
      (gnus-message 5 "Generating the cache active file...done"))))

;;;###autoload
(defun gnus-cache-generate-nov-databases (dir)
  "Generate NOV files recursively starting in DIR."
  (interactive (list gnus-cache-directory))
  (gnus-cache-close)
  (let ((nnml-generate-active-function 'identity))
Miles Bader's avatar
Miles Bader committed
723
    (nnml-generate-nov-databases-directory dir))
724 725 726

  (setq gnus-cache-total-fetched-hashtb nil)

727
  (gnus-cache-open))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
728 729 730

(defun gnus-cache-move-cache (dir)
  "Move the cache tree to somewhere else."
731
  (interactive "FMove the cache tree to: ")
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
732 733
  (rename-file gnus-cache-directory dir))

734 735 736 737 738 739 740 741 742 743 744 745 746
(defun gnus-cache-fully-p (&optional group)
  "Returns non-nil if the cache should be fully used.
If GROUP is non-nil, also cater to `gnus-cacheable-groups' and
`gnus-uncacheable-groups'."
  (and gnus-use-cache
       (not (eq gnus-use-cache 'passive))
       (if (null group)
	   t
	 (and (or (not gnus-cacheable-groups)
		  (string-match gnus-cacheable-groups group))
	      (or (not gnus-uncacheable-groups)
		  (not (string-match gnus-uncacheable-groups group)))))))

747 748
;;;###autoload
(defun gnus-cache-rename-group (old-group new-group)
749 750 751 752 753
  "Rename OLD-GROUP as NEW-GROUP.
Always updates the cache, even when disabled, as the old cache
files would corrupt Gnus when the cache was next enabled.  It
depends on the caller to determine whether group renaming is
supported."
754
  (let ((old-dir (gnus-cache-file-name old-group ""))
755 756
	(new-dir (gnus-cache-file-name new-group ""))
	(file-name-coding-system nnmail-pathname-coding-system))
757 758
    (gnus-rename-file old-dir new-dir t))

759 760
  (gnus-cache-rename-group-total-fetched-for old-group new-group)

761 762 763
  (let ((no-save gnus-cache-active-hashtb))
    (unless gnus-cache-active-hashtb
      (gnus-cache-read-active))
764
    (let* ((old-group-hash-value
765
	    (gethash old-group gnus-cache-active-hashtb))
766
	   (new-group-hash-value
767
	    (gethash new-group gnus-cache-active-hashtb))
768 769
	   (delta
	    (or old-group-hash-value new-group-hash-value)))
770 771
      (puthash new-group old-group-hash-value gnus-cache-active-hashtb)
      (puthash old-group nil gnus-cache-active-hashtb)
772 773 774 775 776 777 778

      (if no-save
	  (setq gnus-cache-active-altered delta)
	(gnus-cache-write-active delta)))))

;;;###autoload
(defun gnus-cache-delete-group (group)
779 780 781 782 783
  "Delete GROUP from the cache.
Always updates the cache, even when disabled, as the old cache
files would corrupt gnus when the cache was next enabled.
Depends upon the caller to determine whether group deletion is
supported."
784 785
  (let ((dir (gnus-cache-file-name group ""))
	(file-name-coding-system nnmail-pathname-coding-system))
786
    (gnus-delete-directory dir))
787

788 789
  (gnus-cache-delete-group-total-fetched-for group)

790 791 792
  (let ((no-save gnus-cache-active-hashtb))
    (unless gnus-cache-active-hashtb
      (gnus-cache-read-active))
793 794
    (let* ((group-hash-value (gethash group gnus-cache-active-hashtb)))
      (remhash group gnus-cache-active-hashtb)
795 796 797 798 799

      (if no-save
	  (setq gnus-cache-active-altered group-hash-value)
	(gnus-cache-write-active group-hash-value)))))

800 801 802 803 804 805 806 807
(defvar gnus-cache-inhibit-update-total-fetched-for nil)
(defvar gnus-cache-need-update-total-fetched-for nil)

(defmacro gnus-cache-with-refreshed-group (group &rest body)
  `(prog1 (let ((gnus-cache-inhibit-update-total-fetched-for t))
	    ,@body)
     (when (and gnus-cache-need-update-total-fetched-for
		(not gnus-cache-inhibit-update-total-fetched-for))
808
	(with-current-buffer gnus-group-buffer
809 810 811 812 813 814 815
	  (setq gnus-cache-need-update-total-fetched-for nil)
	  (gnus-group-update-group ,group t)))))

(defun gnus-cache-update-file-total-fetched-for (group file &optional subtract)
  (when gnus-cache-total-fetched-hashtb
    (gnus-cache-with-refreshed-group
     group
816 817 818
     (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
		       (puthash group (make-vector 2 0)
				gnus-cache-total-fetched-hashtb)))
819 820 821
	    size)

       (if file
Paul Eggert's avatar
Paul Eggert committed
822
	   (setq size (or (file-attribute-size (file-attributes file)) 0))
823 824 825 826 827 828 829
	 (let* ((file-name-coding-system nnmail-pathname-coding-system)
		(files (directory-files (gnus-cache-file-name group "")
					t nil t))
		file attrs)
	   (setq size 0.0)
	   (while (setq file (pop files))
	     (setq attrs (file-attributes file))
Paul Eggert's avatar
Paul Eggert committed
830 831
	     (unless (file-attribute-type attrs)
	       (cl-incf size (float (file-attribute-size attrs)))))))
832 833 834

       (setq gnus-cache-need-update-total-fetched-for t)

Glenn Morris's avatar
Glenn Morris committed
835
       (cl-incf (nth 1 entry) (if subtract (- size) size))))))
836 837 838 839 840

(defun gnus-cache-update-overview-total-fetched-for (group file)
  (when gnus-cache-total-fetched-hashtb
    (gnus-cache-with-refreshed-group
     group
841 842
     (let* ((entry (or (gethash group gnus-cache-total-fetched-hashtb)
		       (puthash group (make-list 2 0)
843 844
				     gnus-cache-total-fetched-hashtb)))
	    (file-name-coding-system nnmail-pathname-coding-system)
Paul Eggert's avatar
Paul Eggert committed
845
	    (size (or (file-attribute-size (file-attributes
846 847 848 849 850 851 852 853 854
			      (or file
				  (gnus-cache-file-name group ".overview"))))
		      0)))
       (setq gnus-cache-need-update-total-fetched-for t)
       (setf (nth 0 entry) size)))))

(defun gnus-cache-rename-group-total-fetched-for (old-group new-group)
  "Record of disk space used by OLD-GROUP now associated with NEW-GROUP."
  (when gnus-cache-total-fetched-hashtb
855 856 857
    (let ((entry (gethash old-group gnus-cache-total-fetched-hashtb)))
      (puthash new-group entry gnus-cache-total-fetched-hashtb)
      (remhash old-group gnus-cache-total-fetched-hashtb))))
858 859 860 861

(defun gnus-cache-delete-group-total-fetched-for (group)
  "Delete record of disk space used by GROUP being deleted."
  (when gnus-cache-total-fetched-hashtb
862
      (remhash group gnus-cache-total-fetched-hashtb)))
863 864 865 866 867

(defun gnus-cache-total-fetched-for (group &optional no-inhibit)
  "Get total disk space used by the cache for the specified GROUP."
  (unless (equal group "dummy.group")
    (unless gnus-cache-total-fetched-hashtb
868 869
      (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1000)))
    (let* ((entry (gethash group gnus-cache-total-fetched-hashtb)))
870 871 872
      (if entry
	  (apply '+ entry)
	(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
873
	  (+
874 875 876
	   (gnus-cache-update-overview-total-fetched-for group nil)
	   (gnus-cache-update-file-total-fetched-for     group nil)))))))

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
877 878 879
(provide 'gnus-cache)

;;; gnus-cache.el ends here