;;; Code:
(eval-when-compile (require 'cl))
-(eval-when-compile (require 'gnus-clfns))
(require 'gnus)
-(require 'gnus-int)
-(require 'gnus-range)
-(require 'gnus-start)
(eval-when-compile
- (if (not (fboundp 'gnus-agent-load-alist))
+ (unless (fboundp 'gnus-agent-load-alist)
(defun gnus-agent-load-alist (group)))
(require 'gnus-sum))
(defvar gnus-cache-buffer nil)
(defvar gnus-cache-active-hashtb nil)
(defvar gnus-cache-active-altered nil)
+(defvar gnus-cache-total-fetched-hashtb nil)
(defvar gnus-cache-write-file-coding-system 'raw-text)
(eval-and-compile
(overview-file (gnus-cache-file-name
(car gnus-cache-buffer) ".overview")))
;; write the overview only if it was modified
- (when (buffer-modified-p buffer)
- (save-excursion
- (set-buffer buffer)
+ (when (and (buffer-live-p buffer) (buffer-modified-p buffer))
+ (with-current-buffer buffer
(if (> (buffer-size) 0)
;; Non-empty overview, write it to a file.
(gnus-write-buffer-as-coding-system
;; 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 nil)))))
+ (error)))
+
+ (gnus-cache-update-overview-total-fetched-for
+ (car gnus-cache-buffer) overview-file)))
;; Kill the buffer -- it's either unmodified or saved.
(gnus-kill-buffer buffer)
(setq gnus-cache-buffer nil))))
(numberp article)
(> article 0) ; This might be a dummy article.
(vectorp headers))
- (let ((number article) file)
+ (let ((number article)
+ file lines-chars)
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
(when (> (buffer-size) 0)
(gnus-write-buffer-as-coding-system
gnus-cache-write-file-coding-system file)
+ (gnus-cache-update-file-total-fetched-for group file)
+ (setq lines-chars (nnheader-get-lines-and-char))
(nnheader-remove-body)
(setq headers (nnheader-parse-naked-head))
(mail-header-set-number headers number)
+ (mail-header-set-lines headers (car lines-chars))
+ (mail-header-set-chars headers (cadr lines-chars))
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-max))
(defun gnus-cache-possibly-remove-articles-1 ()
"Possibly remove some of the removable articles."
(when (gnus-cache-fully-p gnus-newsgroup-name)
- (let ((articles gnus-cache-removable-articles)
- (cache-articles gnus-newsgroup-cached)
- article)
+ (let ((cache-articles gnus-newsgroup-cached))
(gnus-cache-change-buffer gnus-newsgroup-name)
- (while articles
- (when (memq (setq article (pop articles)) cache-articles)
+ (dolist (article gnus-cache-removable-articles)
+ (when (memq article cache-articles)
;; The article was in the cache, so we see whether we are
;; supposed to remove it from the cache.
(gnus-cache-possibly-remove-article
If not given a prefix, use the process marked articles instead.
Returns the list of articles entered."
(interactive "P")
- (let ((articles (gnus-summary-work-articles n))
- article out)
- (while (setq article (pop articles))
+ (let (out)
+ (dolist (article (gnus-summary-work-articles n))
(gnus-summary-remove-process-mark article)
(if (natnump article)
(when (gnus-cache-possibly-enter-article
Returns the list of articles removed."
(interactive "P")
(gnus-cache-change-buffer gnus-newsgroup-name)
- (let ((articles (gnus-summary-work-articles n))
- article out)
- (while articles
- (setq article (pop articles))
+ (let (out)
+ (dolist (article (gnus-summary-work-articles n))
(gnus-summary-remove-process-mark article)
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(when gnus-newsgroup-agentized
(gnus-cache-member-of-class
gnus-cache-remove-articles ticked dormant unread)))
(save-excursion
+ (gnus-cache-update-file-total-fetched-for group file t)
(delete-file file)
+
(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))
- (gnus-delete-line)))
+ (gnus-delete-line)))
(unless (setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached))
(gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb)
(set-buffer cache-buf)
(if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
nil t)
- (setq beg (gnus-point-at-bol)
+ (setq beg (point-at-bol)
end (progn (end-of-line) (point)))
(setq beg nil))
(set-buffer nntp-server-buffer)
(defun gnus-cache-braid-heads (group cached)
(let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
- (save-excursion
- (set-buffer cache-buf)
+ (with-current-buffer cache-buf
(erase-buffer))
(set-buffer nntp-server-buffer)
(goto-char (point-min))
- (while cached
+ (dolist (entry cached)
(while (and (not (eobp))
(looking-at "2.. +\\([0-9]+\\) ")
(< (progn (goto-char (match-beginning 1))
(read (current-buffer)))
- (car cached)))
+ entry))
(search-forward "\n.\n" nil 'move))
(beginning-of-line)
- (save-excursion
- (set-buffer cache-buf)
- (erase-buffer)
- (let ((nnheader-file-coding-system gnus-cache-coding-system))
- (nnheader-insert-file-contents
- (gnus-cache-file-name group (car cached))))
- (goto-char (point-min))
- (insert "220 ")
- (princ (car cached) (current-buffer))
- (insert " Article retrieved.\n")
- (search-forward "\n\n" nil 'move)
- (delete-region (point) (point-max))
- (forward-char -1)
- (insert "."))
- (insert-buffer-substring cache-buf)
- (setq cached (cdr cached)))
+ (set-buffer cache-buf)
+ (erase-buffer)
+ (let ((nnheader-file-coding-system gnus-cache-coding-system))
+ (nnheader-insert-file-contents (gnus-cache-file-name group entry)))
+ (goto-char (point-min))
+ (insert "220 ")
+ (princ (car cached) (current-buffer))
+ (insert " Article retrieved.\n")
+ (search-forward "\n\n" nil 'move)
+ (delete-region (point) (point-max))
+ (forward-char -1)
+ (insert ".")
+ (set-buffer nntp-server-buffer)
+ (insert-buffer-substring cache-buf))
(kill-buffer cache-buf)))
;;;###autoload
(gnus-sethash group (cons (car nums) (gnus-last-element nums))
gnus-cache-active-hashtb))
;; Go through all the other files.
- (while alphs
- (when (and (file-directory-p (car alphs))
+ (dolist (file alphs)
+ (when (and (file-directory-p file)
(not (string-match "^\\."
- (file-name-nondirectory (car alphs)))))
+ (file-name-nondirectory file))))
;; We descend directories.
- (gnus-cache-generate-active (car alphs)))
- (setq alphs (cdr alphs)))
+ (gnus-cache-generate-active file)))
;; Write the new active file.
(when top
(gnus-cache-write-active t)
(gnus-cache-close)
(let ((nnml-generate-active-function 'identity))
(nnml-generate-nov-databases-1 dir))
+
+ (setq gnus-cache-total-fetched-hashtb nil)
+
(gnus-cache-open))
(defun gnus-cache-move-cache (dir)
(or (not gnus-uncacheable-groups)
(not (string-match gnus-uncacheable-groups group)))))))
+;;;###autoload
+(defun gnus-cache-rename-group (old-group new-group)
+ "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. Depends upon the caller to determine whether group renaming is supported."
+ (let ((old-dir (gnus-cache-file-name old-group ""))
+ (new-dir (gnus-cache-file-name new-group "")))
+ (gnus-rename-file old-dir new-dir t))
+
+ (gnus-cache-rename-group-total-fetched-for old-group new-group)
+
+ (let ((no-save gnus-cache-active-hashtb))
+ (unless gnus-cache-active-hashtb
+ (gnus-cache-read-active))
+ (let* ((old-group-hash-value (gnus-gethash old-group gnus-cache-active-hashtb))
+ (new-group-hash-value (gnus-gethash new-group gnus-cache-active-hashtb))
+ (delta (or old-group-hash-value new-group-hash-value)))
+ (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb)
+ (gnus-sethash old-group nil gnus-cache-active-hashtb)
+
+ (if no-save
+ (setq gnus-cache-active-altered delta)
+ (gnus-cache-write-active delta)))))
+
+;;;###autoload
+(defun gnus-cache-delete-group (group)
+ "Delete GROUP. 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."
+ (let ((dir (gnus-cache-file-name group "")))
+ (gnus-delete-file dir))
+
+ (gnus-cache-delete-group-total-fetched-for group)
+
+ (let ((no-save gnus-cache-active-hashtb))
+ (unless gnus-cache-active-hashtb
+ (gnus-cache-read-active))
+ (let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb)))
+ (gnus-sethash group nil gnus-cache-active-hashtb)
+
+ (if no-save
+ (setq gnus-cache-active-altered group-hash-value)
+ (gnus-cache-write-active group-hash-value)))))
+
+(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))
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (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
+ (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
+ (gnus-sethash group (make-vector 2 0)
+ gnus-cache-total-fetched-hashtb)))
+ size)
+
+ (if file
+ (setq size (or (nth 7 (file-attributes file)) 0))
+ (let ((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))
+ (unless (nth 0 attrs)
+ (incf size (float (nth 7 attrs)))))))
+
+ (setq gnus-cache-need-update-total-fetched-for t)
+
+ (incf (nth 1 entry) (if subtract (- size) size))))))
+
+(defun gnus-cache-update-overview-total-fetched-for (group file)
+ (when gnus-cache-total-fetched-hashtb
+ (gnus-cache-with-refreshed-group
+ group
+ (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
+ (gnus-sethash group (make-list 2 0)
+ gnus-cache-total-fetched-hashtb)))
+ (size (or (nth 7 (file-attributes
+ (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
+ (let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb)))
+ (gnus-sethash new-group entry gnus-cache-total-fetched-hashtb)
+ (gnus-sethash old-group nil gnus-cache-total-fetched-hashtb))))
+
+(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
+ (gnus-sethash group nil gnus-cache-total-fetched-hashtb)))
+
+(defun gnus-cache-total-fetched-for (group &optional no-inhibit)
+ "Get total disk space used by the cache for the specified GROUP."
+ (unless gnus-cache-total-fetched-hashtb
+ (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024)))
+
+ (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
+ (if entry
+ (apply '+ entry)
+ (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
+ (+
+ (gnus-cache-update-overview-total-fetched-for group nil)
+ (gnus-cache-update-file-total-fetched-for group nil))))))
+
(provide 'gnus-cache)
;;; gnus-cache.el ends here