;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2015 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
(func LIST): Returns VALUE1
(setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1."
`(progn (defmacro ,name (category)
- (list (quote cdr) (list (quote assq)
- (quote (quote ,prop-name)) category)))
-
- (define-setf-method ,name (category)
- (let* ((--category--temp-- (make-symbol "--category--"))
- (--value--temp-- (make-symbol "--value--")))
- (list (list --category--temp--) ; temporary-variables
- (list category) ; value-forms
- (list --value--temp--) ; store-variables
- (let* ((category --category--temp--) ; store-form
- (value --value--temp--))
- (list (quote gnus-agent-cat-set-property)
- category
- (quote (quote ,prop-name))
- value))
- (list (quote ,name) --category--temp--) ; access-form
- )))))
+ (list 'cdr (list 'assq '',prop-name category)))
+
+ (defsetf ,name (category) (value)
+ (list 'gnus-agent-cat-set-property
+ category '',prop-name value))))
)
(defmacro gnus-agent-cat-name (category)
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces)
-;; This form is equivalent to defsetf except that it calls make-symbol
-;; whereas defsetf calls gensym (Using gensym creates a run-time
-;; dependency on the CL library).
-
-(eval-and-compile
- (define-setf-method gnus-agent-cat-groups (category)
- (let* ((--category--temp-- (make-symbol "--category--"))
- (--groups--temp-- (make-symbol "--groups--")))
- (list (list --category--temp--)
- (list category)
- (list --groups--temp--)
- (let* ((category --category--temp--)
- (groups --groups--temp--))
- (list (quote gnus-agent-set-cat-groups) category groups))
- (list (quote gnus-agent-cat-groups) --category--temp--))))
- )
+;; This form may expand to code that uses CL functions at run-time,
+;; but that's OK since those functions will only ever be called from
+;; something like `setf', so only when CL is loaded anyway.
+(defsetf gnus-agent-cat-groups gnus-agent-set-cat-groups)
(defun gnus-agent-set-cat-groups (category groups)
(unless (eq groups 'ignore)
(push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
buffer))))
minor-mode-map-alist))
- (when (eq major-mode 'gnus-group-mode)
+ (when (derived-mode-p 'gnus-group-mode)
(let ((init-plugged gnus-plugged)
(gnus-agent-go-online nil))
;; g-a-t-p does nothing when gnus-plugged isn't changed.
(make-mode-line-mouse-map mouse-button mouse-func)
'mouse-face
(if (and (featurep 'xemacs)
- ;; XEmacs' `facep' only checks for a face
+ ;; XEmacs's `facep' only checks for a face
;; object, not for a face name, so it's useless
;; to check with `facep'.
(find-face 'modeline))
supported."
(let* ((old-command-method (gnus-find-method-for-group old-group))
(old-path (directory-file-name
- (let (gnus-command-method old-command-method)
+ (let ((gnus-command-method old-command-method))
(gnus-agent-group-pathname old-group))))
(new-command-method (gnus-find-method-for-group new-group))
(new-path (directory-file-name
- (let (gnus-command-method new-command-method)
+ (let ((gnus-command-method new-command-method))
(gnus-agent-group-pathname new-group))))
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-rename-file old-path new-path t)
supported."
(let* ((command-method (gnus-find-method-for-group group))
(path (directory-file-name
- (let (gnus-command-method command-method)
+ (let ((gnus-command-method command-method))
(gnus-agent-group-pathname group))))
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-delete-directory path)
(let* ((real-group (gnus-group-real-name group)))
(gnus-agent-save-group-info command-method real-group nil)
-
- (let ((local (gnus-agent-get-local group
- real-group command-method)))
- (gnus-agent-set-local group
- nil nil
- real-group command-method)))))
+ ;; FIXME: Does gnus-agent-get-local have any useful side-effect?
+ (gnus-agent-get-local group real-group command-method)
+ (gnus-agent-set-local group
+ nil nil
+ real-group command-method))))
;;;
;;; Server mode commands
(gnus-group-update-group group t)))
nil))
-(defun gnus-agent-save-active (method)
+(defun gnus-agent-save-active (method &optional groups-p)
+ "Sync the agent's active file with the current buffer.
+Pass non-nil for GROUPS-P if the buffer starts out in groups format.
+Regardless, both the file and the buffer end up in active format
+if METHOD is agentized; otherwise the function is a no-op."
(when (gnus-agent-method-p method)
(let* ((gnus-command-method method)
(new (gnus-make-hashtable (count-lines (point-min) (point-max))))
(file (gnus-agent-lib-file "active")))
- (gnus-active-to-gnus-format nil new)
+ (if groups-p
+ (gnus-groups-to-gnus-format nil new)
+ (gnus-active-to-gnus-format nil new))
(gnus-agent-write-active file new)
(erase-buffer)
(let ((nnheader-file-coding-system gnus-agent-file-coding-system))
(defun gnus-agent-fetch-articles (group articles)
"Fetch ARTICLES from GROUP and put them into the Agent."
- (when articles
+ (when (and articles
+ (gnus-online (gnus-group-method group)))
(gnus-agent-load-alist group)
(let* ((alist gnus-agent-article-alist)
(headers (if (< (length articles) 2) nil gnus-newsgroup-headers))
(dir (gnus-agent-group-pathname group))
(date (time-to-days (current-time)))
(case-fold-search t)
- pos crosses id
+ pos crosses
(file-name-coding-system nnmail-pathname-coding-system))
(setcar selected-sets (nreverse (car selected-sets)))
(goto-char (match-end 0)))
(gnus-agent-crosspost crosses (caar pos) date)))
(goto-char (point-min))
- (if (not (re-search-forward
- "^Message-ID: *<\\([^>\n]+\\)>" nil t))
- (setq id "No-Message-ID-in-article")
- (setq id (buffer-substring
- (match-beginning 1) (match-end 1))))
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(write-region (point-min) (point-max)
. gnus-agent-enable-expiration)
(agent-predicate . gnus-agent-predicate)))))))
-(defun gnus-agent-fetch-headers (group &optional force)
+(defun gnus-agent-fetch-headers (group)
"Fetch interesting headers into the agent. The group's overview
file will be updated to include the headers while a list of available
article numbers will be returned."
;; NOTE: Call g-a-brand-nov even when the file does not
;; exist. As a minimum, it will validate the article
;; numbers already in the buffer.
- (gnus-agent-braid-nov group articles file)
+ (gnus-agent-braid-nov articles file)
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(gnus-agent-check-overview-buffer)
(set-buffer nntp-server-buffer)
(insert-buffer-substring gnus-agent-overview-buffer b e))))
-(defun gnus-agent-braid-nov (group articles file)
+(defun gnus-agent-braid-nov (articles file)
"Merge agent overview data with given file.
Takes unvalidated headers for ARTICLES from
`gnus-agent-overview-buffer' and validated headers from the given
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(prev (cons nil gnus-agent-article-alist))
(all prev)
- print-level print-length item article)
+ print-level print-length article)
(while (setq article (pop articles))
(while (and (cdr prev)
(< (caadr prev) article))
(file-name-coding-system nnmail-pathname-coding-system))
(with-temp-file dest
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
- print-level print-length item article
+ print-level print-length
(standard-output (current-buffer)))
(mapatoms (lambda (symbol)
(cond ((not (boundp symbol))
(gnus-run-hooks 'gnus-agent-fetched-hook)
(gnus-message 6 "Finished fetching articles into the Gnus agent"))))
+(defvar gnus-agent-short-article 500
+ "Articles that have fewer lines than this are short.")
+
+(defvar gnus-agent-long-article 1000
+ "Articles that have more lines than this are long.")
+
+(defvar gnus-agent-low-score 0
+ "Articles that have a score lower than this have a low score.")
+
+(defvar gnus-agent-high-score 0
+ "Articles that have a score higher than this have a high score.")
+
(defun gnus-agent-fetch-group-1 (group method)
"Fetch GROUP."
(let ((gnus-command-method method)
gnus-headers
gnus-score
- articles arts
- category predicate info marks score-param
+ articles
+ predicate info marks
)
(unless (gnus-check-group group)
(error "Can't open server for %s" group))
;; timeout reason. If so, recreate it.
(gnus-agent-create-buffer)
- ;; Figure out how to select articles in this group
- (setq category (gnus-group-category group))
-
(setq predicate
(gnus-get-predicate
(gnus-agent-find-parameter group 'agent-predicate)))
(defvar gnus-agent-predicate 'false
"The selection predicate used when no other source is available.")
-(defvar gnus-agent-short-article 500
- "Articles that have fewer lines than this are short.")
-
-(defvar gnus-agent-long-article 1000
- "Articles that have more lines than this are long.")
-
-(defvar gnus-agent-low-score 0
- "Articles that have a score lower than this have a low score.")
-
-(defvar gnus-agent-high-score 0
- "Articles that have a score higher than this have a high score.")
-
;;; Internal variables.
(defvar gnus-category-buffer "*Agent Category*")
+(defvar gnus-tmp-name)
+(defvar gnus-tmp-groups)
+
(defvar gnus-category-line-format-alist
`((?c gnus-tmp-name ?s)
(?g gnus-tmp-groups ?d)))
(gnus-run-hooks 'gnus-category-menu-hook)))
-(defun gnus-category-mode ()
+(define-derived-mode gnus-category-mode fundamental-mode "Category"
"Major mode for listing and editing agent categories.
All normal editing commands are switched off.
The following commands are available:
\\{gnus-category-mode-map}"
- (interactive)
(when (gnus-visual-p 'category-menu 'menu)
(gnus-category-make-menu-bar))
- (kill-all-local-variables)
(gnus-simplify-mode-line)
- (setq major-mode 'gnus-category-mode)
- (setq mode-name "Category")
(gnus-set-default-directory)
(setq mode-line-process nil)
- (use-local-map gnus-category-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
- (setq buffer-read-only t)
- (gnus-run-mode-hooks 'gnus-category-mode-hook))
+ (setq buffer-read-only t))
(defalias 'gnus-category-position-point 'gnus-goto-colon)
"Return the function implementing PREDICATE."
(or (cdr (assoc predicate gnus-category-predicate-cache))
(let ((func (gnus-category-make-function predicate)))
- (setq gnus-category-predicate-cache
- (nconc gnus-category-predicate-cache
- (list (cons predicate func))))
+ (push (cons predicate func) gnus-category-predicate-cache)
func)))
(defun gnus-predicate-implies-unread (predicate)
(or (gnus-gethash group gnus-category-group-cache)
(assq 'default gnus-category-alist)))
+(defvar gnus-agent-expire-current-dirs)
+(defvar gnus-agent-expire-stats)
+
(defun gnus-agent-expire-group (group &optional articles force)
"Expire all old articles in GROUP.
If you want to force expiring of certain articles, this function can
(if (not group)
(gnus-agent-expire articles group force)
- (let ( ;; Bind gnus-agent-expire-stats to enable tracking of
+ (let (;; Bind gnus-agent-expire-stats to enable tracking of
;; expiration statistics of this single group
(gnus-agent-expire-stats (list 0 0 0.0)))
(if (or (not (eq articles t))
(gnus-agent-with-refreshed-group
group
(when (boundp 'gnus-agent-expire-current-dirs)
- (set 'gnus-agent-expire-current-dirs
- (cons dir
- (symbol-value 'gnus-agent-expire-current-dirs))))
+ (push dir gnus-agent-expire-current-dirs))
(if (and (not force)
(eq 'DISABLE (gnus-agent-find-parameter group
;; only problem is that much of it is spread across multiple
;; entries. Sort then MERGE!!
(gnus-message 7 "gnus-agent-expire: Sorting entries... ")
- ;; If two entries have the same article-number then sort by
- ;; ascending keep_flag.
- (let ((special 0)
- (marked 1)
- (unread 2))
- (setq dlist
- (sort dlist
- (lambda (a b)
- (cond ((< (nth 0 a) (nth 0 b))
- t)
- ((> (nth 0 a) (nth 0 b))
- nil)
- (t
- (let ((a (or (symbol-value (nth 2 a))
- 3))
- (b (or (symbol-value (nth 2 b))
- 3)))
- (<= a b))))))))
+ (setq dlist
+ (sort dlist
+ (lambda (a b)
+ (cond ((< (nth 0 a) (nth 0 b))
+ t)
+ ((> (nth 0 a) (nth 0 b))
+ nil)
+ (t
+ ;; If two entries have the same article-number
+ ;; then sort by ascending keep_flag.
+ (let* ((kf-score '((special . 0)
+ (marked . 1)
+ (unread . 2)))
+ (a (or (cdr (assq (nth 2 a) kf-score))
+ 3))
+ (b (or (cdr (assq (nth 2 b) kf-score))
+ 3)))
+ (<= a b)))))))
(gnus-message 7 "gnus-agent-expire: Sorting entries... Done")
(gnus-message 7 "gnus-agent-expire: Merging entries... ")
(let ((dlist dlist))
(gnus-summary-update-info))))
(when (boundp 'gnus-agent-expire-stats)
- (let ((stats (symbol-value 'gnus-agent-expire-stats)))
+ (let ((stats gnus-agent-expire-stats))
(incf (nth 2 stats) bytes-freed)
(incf (nth 1 stats) files-deleted)
(incf (nth 0 stats) nov-entries-deleted)))
(defun gnus-agent-expire-done-message ()
(if (and (> gnus-verbose 4)
(boundp 'gnus-agent-expire-stats))
- (let* ((stats (symbol-value 'gnus-agent-expire-stats))
+ (let* ((stats gnus-agent-expire-stats)
(size (nth 2 stats))
(units '(B KB MB GB)))
(while (and (> size 1024.0)
(when (and gnus-agent-expire-unagentized-dirs
(boundp 'gnus-agent-expire-current-dirs))
(let* ((keep (gnus-make-hashtable))
- ;; Formally bind gnus-agent-expire-current-dirs so that the
- ;; compiler will not complain about free references.
- (gnus-agent-expire-current-dirs
- (symbol-value 'gnus-agent-expire-current-dirs))
- dir
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-sethash gnus-agent-directory t keep)
- (while gnus-agent-expire-current-dirs
- (setq dir (pop gnus-agent-expire-current-dirs))
+ (dolist (dir gnus-agent-expire-current-dirs)
(when (and (stringp dir)
(file-directory-p dir))
(while (not (gnus-gethash dir keep))
(let ((gnus-decode-encoded-word-function 'identity)
(gnus-decode-encoded-address-function 'identity)
(file (gnus-agent-article-name ".overview" group))
- cached-articles uncached-articles
+ uncached-articles
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-make-directory (nnheader-translate-file-chars
(file-name-directory file) t))
+ (when fetch-old
+ (setq articles (gnus-uncompress-range
+ (cons (if (numberp fetch-old)
+ (max 1 (- (car articles) fetch-old))
+ 1)
+ (car (last articles))))))
+
;; Populate temp buffer with known headers
(when (file-exists-p file)
(with-current-buffer gnus-agent-overview-buffer
(set-buffer nntp-server-buffer)
(let* ((fetched-articles (list nil))
(tail-fetched-articles fetched-articles)
- (min (cond ((numberp fetch-old)
- (max 1 (- (car articles) fetch-old)))
- (fetch-old
- 1)
- (t
- (car articles))))
+ (min (car articles))
(max (car (last articles))))
;; Get the list of articles that were fetched
;; Merge the temp buffer with the known headers (found on
;; disk in FILE) into the nntp-server-buffer
(when uncached-articles
- (gnus-agent-braid-nov group uncached-articles file))
+ (gnus-agent-braid-nov uncached-articles file))
;; Save the new set of known headers to FILE
(set-buffer nntp-server-buffer)
(not (numberp fetch-old)))
t ; Don't remove anything.
(nnheader-nov-delete-outside-range
- (if fetch-old (max 1 (- (car articles) fetch-old))
- (car articles))
+ (car articles)
(car (last articles)))
t)
(gnus-find-method-for-group group)))
(file (gnus-agent-article-name ".overview" group))
(dir (file-name-directory file))
- point
(file-name-coding-system nnmail-pathname-coding-system)
(downloaded (if (file-exists-p dir)
(sort (delq nil (mapcar (lambda (name)
(directory-files dir nil "^[0-9]+$" t)))
'>)
(progn (gnus-make-directory dir) nil)))
- dl nov-arts
+ nov-arts
alist header
regenerated)
regenerated)))
;;;###autoload
-(defun gnus-agent-regenerate (&optional clean reread)
+(defun gnus-agent-regenerate (&optional _clean reread)
"Regenerate all agent covered files.
-If CLEAN, obsolete (ignore)."
- (interactive "P")
+CLEAN is obsolete and ignored."
+ (interactive)
(let (regenerated)
(gnus-message 4 "Regenerating Gnus agent files...")
(dolist (gnus-command-method (gnus-agent-covered-methods))
- (dolist (group (gnus-groups-from-server gnus-command-method))
- (setq regenerated (or (gnus-agent-regenerate-group group reread)
- regenerated))))
+ (dolist (group (gnus-groups-from-server gnus-command-method))
+ (setq regenerated (or (gnus-agent-regenerate-group group reread)
+ regenerated))))
(gnus-message 4 "Regenerating Gnus agent files...done")
regenerated))
(defun gnus-agent-group-covered-p (group)
(gnus-agent-method-p (gnus-group-method group)))
-(defun gnus-agent-update-files-total-fetched-for
- (group delta &optional method path)
+(defun gnus-agent-update-files-total-fetched-for (group delta
+ &optional method path)
"Update, or set, the total disk space used by the articles that the
agent has fetched."
(when gnus-agent-total-fetched-hashtb
(gnus-sethash path (make-list 3 0)
gnus-agent-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system))
- (when (listp delta)
- (if delta
- (let ((sum 0.0)
+ (when (file-exists-p path)
+ (when (listp delta)
+ (if delta
+ (let ((sum 0.0)
+ file)
+ (while (setq file (pop delta))
+ (incf sum (float (or (nth 7 (file-attributes
+ (nnheader-concat
+ path
+ (if (numberp file)
+ (number-to-string file)
+ file)))) 0))))
+ (setq delta sum))
+ (let ((sum (- (nth 2 entry)))
+ (info (directory-files-and-attributes
+ path nil "^-?[0-9]+$" t))
file)
- (while (setq file (pop delta))
- (incf sum (float (or (nth 7 (file-attributes
- (nnheader-concat
- path
- (if (numberp file)
- (number-to-string file)
- file)))) 0))))
- (setq delta sum))
- (let ((sum (- (nth 2 entry)))
- (info (directory-files-and-attributes path nil "^-?[0-9]+$" t))
- file)
- (while (setq file (pop info))
- (incf sum (float (or (nth 8 file) 0))))
- (setq delta sum))))
+ (while (setq file (pop info))
+ (incf sum (float (or (nth 8 file) 0))))
+ (setq delta sum))))
- (setq gnus-agent-need-update-total-fetched-for t)
- (incf (nth 2 entry) delta)))))
+ (setq gnus-agent-need-update-total-fetched-for t)
+ (incf (nth 2 entry) delta))))))
(defun gnus-agent-update-view-total-fetched-for
(group agent-over &optional method path)
projects / gnus / blobdiff