(require 'gnus)
(require 'gnus-cache)
(require 'nnmail)
(require 'nnvirtual)
(require 'gnus-sum)
(require 'gnus-score)
(require 'gnus-srvr)
(require 'gnus-util)
(eval-when-compile
(if (featurep 'xemacs)
(require 'itimer)
(require 'timer))
(require 'cl))
(eval-and-compile
(autoload 'gnus-server-update-server "gnus-srvr")
(autoload 'gnus-agent-customize-category "gnus-cus")
)
(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
"Where the Gnus agent will store its files."
:group 'gnus-agent
:type 'directory)
(defcustom gnus-agent-plugged-hook nil
"Hook run when plugging into the network."
:group 'gnus-agent
:type 'hook)
(defcustom gnus-agent-unplugged-hook nil
"Hook run when unplugging from the network."
:group 'gnus-agent
:type 'hook)
(defcustom gnus-agent-fetched-hook nil
"Hook run when finished fetching articles."
:version "22.1"
:group 'gnus-agent
:type 'hook)
(defcustom gnus-agent-handle-level gnus-level-subscribed
"Groups on levels higher than this variable will be ignored by the Agent."
:group 'gnus-agent
:type 'integer)
(defcustom gnus-agent-expire-days 7
"Read articles older than this will be expired.
If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'."
:group 'gnus-agent
:type '(number :tag "days"))
(defcustom gnus-agent-expire-all nil
"If non-nil, also expire unread, ticked and dormant articles.
If nil, only read articles will be expired."
:group 'gnus-agent
:type 'boolean)
(defcustom gnus-agent-group-mode-hook nil
"Hook run in Agent group minor modes."
:group 'gnus-agent
:type 'hook)
(when (featurep 'xemacs)
(add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add))
(defcustom gnus-agent-summary-mode-hook nil
"Hook run in Agent summary minor modes."
:group 'gnus-agent
:type 'hook)
(when (featurep 'xemacs)
(add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add))
(defcustom gnus-agent-server-mode-hook nil
"Hook run in Agent summary minor modes."
:group 'gnus-agent
:type 'hook)
(when (featurep 'xemacs)
(add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add))
(defcustom gnus-agent-confirmation-function 'y-or-n-p
"Function to confirm when error happens."
:version "21.1"
:group 'gnus-agent
:type 'function)
(defcustom gnus-agent-synchronize-flags t
"Indicate if flags are synchronized when you plug in.
If this is `ask' the hook will query the user."
:version "21.1"
:type '(choice (const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "Ask" ask))
:group 'gnus-agent)
(defcustom gnus-agent-go-online 'ask
"Indicate if offline servers go online when you plug in.
If this is `ask' the hook will query the user."
:version "21.3"
:type '(choice (const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "Ask" ask))
:group 'gnus-agent)
(defcustom gnus-agent-mark-unread-after-downloaded t
"Indicate whether to mark articles unread after downloaded."
:version "21.1"
:type 'boolean
:group 'gnus-agent)
(defcustom gnus-agent-download-marks '(download)
"Marks for downloading."
:version "21.1"
:type '(repeat (symbol :tag "Mark"))
:group 'gnus-agent)
(defcustom gnus-agent-consider-all-articles nil
"When non-nil, the agent will let the agent predicate decide
whether articles need to be downloaded or not, for all articles. When
nil, the default, the agent will only let the predicate decide
whether unread articles are downloaded or not. If you enable this,
groups with large active ranges may open slower and you may also want
to look into the agent expiry settings to block the expiration of
read articles as they would just be downloaded again."
:version "22.1"
:type 'boolean
:group 'gnus-agent)
(defcustom gnus-agent-max-fetch-size 10000000 "Chunk size for `gnus-agent-fetch-session'.
The function will split its article fetches into chunks smaller than
this limit."
:version "22.1"
:group 'gnus-agent
:type 'integer)
(defcustom gnus-agent-enable-expiration 'ENABLE
"The default expiration state for each group.
When set to ENABLE, the default, `gnus-agent-expire' will expire old
contents from a group's local storage. This value may be overridden
to disable expiration in specific categories, topics, and groups. Of
course, you could change gnus-agent-enable-expiration to DISABLE then
enable expiration per categories, topics, and groups."
:version "22.1"
:group 'gnus-agent
:type '(radio (const :format "Enable " ENABLE)
(const :format "Disable " DISABLE)))
(defcustom gnus-agent-expire-unagentized-dirs t
"*Whether expiration should expire in unagentized directories.
Have gnus-agent-expire scan the directories under
\(gnus-agent-directory) for groups that are no longer agentized.
When found, offer to remove them."
:version "22.1"
:type 'boolean
:group 'gnus-agent)
(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap)
"Initially, all servers from these methods are agentized.
The user may remove or add servers using the Server buffer.
See Info node `(gnus)Server Buffer'."
:version "22.1"
:type '(repeat symbol)
:group 'gnus-agent)
(defcustom gnus-agent-queue-mail t
"Whether and when outgoing mail should be queued by the agent.
When `always', always queue outgoing mail. When nil, never
queue. Otherwise, queue if and only if unplugged."
:version "22.1"
:group 'gnus-agent
:type '(radio (const :format "Always" always)
(const :format "Never" nil)
(const :format "When unplugged" t)))
(defcustom gnus-agent-prompt-send-queue nil
"If non-nil, `gnus-group-send-queue' will prompt if called when
unplugged."
:version "22.1"
:group 'gnus-agent
:type 'boolean)
(defcustom gnus-agent-article-alist-save-format 1
"Indicates whether to use compression(2), versus no
compression(1), when writing agentview files. The compressed
files do save space but load times are 6-7 times higher. A group
must be opened then closed for the agentview to be updated using
the new format."
:version "22.1"
:group 'gnus-agent
:type '(radio (const :format "Compressed" 2)
(const :format "Uncompressed" 1)))
(defvar gnus-agent-history-buffers nil)
(defvar gnus-agent-buffer-alist nil)
(defvar gnus-agent-article-alist nil
"An assoc list identifying the articles whose headers have been fetched.
If successfully fetched, these headers will be stored in the group's overview
file. The key of each assoc pair is the article ID, the value of each assoc
pair is a flag indicating whether the identified article has been downloaded
\(gnus-agent-fetch-articles sets the value to the day of the download).
NOTES:
1) The last element of this list can not be expired as some
routines (for example, get-agent-fetch-headers) use the last
value to track which articles have had their headers retrieved.
2) The function `gnus-agent-regenerate' may destructively modify the value.")
(defvar gnus-agent-group-alist nil)
(defvar gnus-category-alist nil)
(defvar gnus-agent-current-history nil)
(defvar gnus-agent-overview-buffer nil)
(defvar gnus-category-predicate-cache nil)
(defvar gnus-category-group-cache nil)
(defvar gnus-agent-spam-hashtb nil)
(defvar gnus-agent-file-name nil)
(defvar gnus-agent-send-mail-function nil)
(defvar gnus-agent-file-coding-system 'raw-text)
(defvar gnus-agent-file-loading-cache nil)
(defvar gnus-headers)
(defvar gnus-score)
(defun gnus-open-agent ()
(setq gnus-agent t)
(gnus-agent-read-servers)
(gnus-category-read)
(gnus-agent-create-buffer)
(add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
(add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
(add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
(defun gnus-agent-create-buffer ()
(if (gnus-buffer-live-p gnus-agent-overview-buffer)
t
(setq gnus-agent-overview-buffer
(gnus-get-buffer-create " *Gnus agent overview*"))
(with-current-buffer gnus-agent-overview-buffer
(mm-enable-multibyte))
nil))
(gnus-add-shutdown 'gnus-close-agent 'gnus)
(defun gnus-close-agent ()
(setq gnus-category-predicate-cache nil
gnus-category-group-cache nil
gnus-agent-spam-hashtb nil)
(gnus-kill-buffer gnus-agent-overview-buffer))
(defun gnus-agent-read-file (file)
"Load FILE and do a `read' there."
(with-temp-buffer
(ignore-errors
(nnheader-insert-file-contents file)
(goto-char (point-min))
(read (current-buffer)))))
(defsubst gnus-agent-method ()
(concat (symbol-name (car gnus-command-method)) "/"
(if (equal (cadr gnus-command-method) "")
"unnamed"
(cadr gnus-command-method))))
(defsubst gnus-agent-directory ()
"The name of the Gnus agent directory."
(nnheader-concat gnus-agent-directory
(nnheader-translate-file-chars (gnus-agent-method)) "/"))
(defun gnus-agent-lib-file (file)
"The full name of the Gnus agent library FILE."
(expand-file-name file
(file-name-as-directory
(expand-file-name "agent.lib" (gnus-agent-directory)))))
(defun gnus-agent-cat-set-property (category property value)
(if value
(setcdr (or (assq property category)
(let ((cell (cons property nil)))
(setcdr category (cons cell (cdr category)))
cell)) value)
(let ((category category))
(while (cond ((eq property (caadr category))
(setcdr category (cddr category))
nil)
(t
(setq category (cdr category)))))))
category)
(eval-when-compile
(defmacro gnus-agent-cat-defaccessor (name prop-name)
"Define accessor and setter methods for manipulating a list of the form
\(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)).
Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be
manipulated as follows:
(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--) (list category) (list --value--temp--) (let* ((category --category--temp--) (value --value--temp--))
(list (quote gnus-agent-cat-set-property)
category
(quote (quote ,prop-name))
value))
(list (quote ,name) --category--temp--) )))))
)
(defmacro gnus-agent-cat-name (category)
`(car ,category))
(gnus-agent-cat-defaccessor
gnus-agent-cat-days-until-old agent-days-until-old)
(gnus-agent-cat-defaccessor
gnus-agent-cat-enable-expiration agent-enable-expiration)
(gnus-agent-cat-defaccessor
gnus-agent-cat-groups agent-groups)
(gnus-agent-cat-defaccessor
gnus-agent-cat-high-score agent-high-score)
(gnus-agent-cat-defaccessor
gnus-agent-cat-length-when-long agent-long-article)
(gnus-agent-cat-defaccessor
gnus-agent-cat-length-when-short agent-short-article)
(gnus-agent-cat-defaccessor
gnus-agent-cat-low-score agent-low-score)
(gnus-agent-cat-defaccessor
gnus-agent-cat-predicate agent-predicate)
(gnus-agent-cat-defaccessor
gnus-agent-cat-score-file agent-score)
(gnus-agent-cat-defaccessor
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces)
(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--))))
)
(defun gnus-agent-set-cat-groups (category groups)
(unless (eq groups 'ignore)
(let ((new-g groups)
(old-g (gnus-agent-cat-groups category)))
(cond ((eq new-g old-g)
nil
)
((eq new-g (cdr old-g))
(setcdr (or (assq 'agent-groups category)
(let ((cell (cons 'agent-groups nil)))
(setcdr category (cons cell (cdr category)))
cell)) new-g))
(t
(let ((groups groups))
(while groups
(let* ((group (pop groups))
(old-category (gnus-group-category group)))
(if (eq category old-category)
nil
(setf (gnus-agent-cat-groups old-category)
(delete group (gnus-agent-cat-groups
old-category))))))
(setq gnus-category-group-cache nil))
(setcdr (or (assq 'agent-groups category)
(let ((cell (cons 'agent-groups nil)))
(setcdr category (cons cell (cdr category)))
cell)) groups))))))
(defsubst gnus-agent-cat-make (name &optional default-agent-predicate)
(list name `(agent-predicate . ,(or default-agent-predicate 'false))))
(defun gnus-agent-start-fetch ()
"Initialize data structures for efficient fetching."
(gnus-agent-create-buffer))
(defun gnus-agent-stop-fetch ()
"Save all data structures and clean up."
(setq gnus-agent-spam-hashtb nil)
(save-excursion
(set-buffer nntp-server-buffer)
(widen)))
(defmacro gnus-agent-with-fetch (&rest forms)
"Do FORMS safely."
`(unwind-protect
(let ((gnus-agent-fetching t))
(gnus-agent-start-fetch)
,@forms)
(gnus-agent-stop-fetch)))
(put 'gnus-agent-with-fetch 'lisp-indent-function 0)
(put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
(defmacro gnus-agent-append-to-list (tail value)
`(setq ,tail (setcdr ,tail (cons ,value nil))))
(defmacro gnus-agent-message (level &rest args)
`(if (<= ,level gnus-verbose)
(message ,@args)))
(defvar gnus-agent-mode-hook nil
"Hook run when installing agent mode.")
(defvar gnus-agent-mode nil)
(defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
(defun gnus-agent-mode ()
"Minor mode for providing a agent support in Gnus buffers."
(let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
(symbol-name major-mode))
(match-string 1 (symbol-name major-mode))))
(mode (intern (format "gnus-agent-%s-mode" buffer))))
(set (make-local-variable 'gnus-agent-mode) t)
(set mode nil)
(set (make-local-variable mode) t)
(when (gnus-visual-p 'agent-menu 'menu)
(funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
(unless (assq 'gnus-agent-mode minor-mode-alist)
(push gnus-agent-mode-status minor-mode-alist))
(unless (assq mode minor-mode-map-alist)
(push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
buffer))))
minor-mode-map-alist))
(when (eq major-mode 'gnus-group-mode)
(let ((init-plugged gnus-plugged)
(gnus-agent-go-online nil))
(setq gnus-plugged :unknown)
(gnus-agent-toggle-plugged init-plugged)))
(gnus-run-hooks 'gnus-agent-mode-hook
(intern (format "gnus-agent-%s-mode-hook" buffer)))))
(defvar gnus-agent-group-mode-map (make-sparse-keymap))
(gnus-define-keys gnus-agent-group-mode-map
"Ju" gnus-agent-fetch-groups
"Jc" gnus-enter-category-buffer
"Jj" gnus-agent-toggle-plugged
"Js" gnus-agent-fetch-session
"JY" gnus-agent-synchronize-flags
"JS" gnus-group-send-queue
"Ja" gnus-agent-add-group
"Jr" gnus-agent-remove-group
"Jo" gnus-agent-toggle-group-plugged)
(defun gnus-agent-group-make-menu-bar ()
(unless (boundp 'gnus-agent-group-menu)
(easy-menu-define
gnus-agent-group-menu gnus-agent-group-mode-map ""
'("Agent"
["Toggle plugged" gnus-agent-toggle-plugged t]
["Toggle group plugged" gnus-agent-toggle-group-plugged t]
["List categories" gnus-enter-category-buffer t]
["Add (current) group to category" gnus-agent-add-group t]
["Remove (current) group from category" gnus-agent-remove-group t]
["Send queue" gnus-group-send-queue gnus-plugged]
("Fetch"
["All" gnus-agent-fetch-session gnus-plugged]
["Group" gnus-agent-fetch-group gnus-plugged])
["Synchronize flags" gnus-agent-synchronize-flags t]
))))
(defvar gnus-agent-summary-mode-map (make-sparse-keymap))
(gnus-define-keys gnus-agent-summary-mode-map
"Jj" gnus-agent-toggle-plugged
"Ju" gnus-agent-summary-fetch-group
"JS" gnus-agent-fetch-group
"Js" gnus-agent-summary-fetch-series
"J#" gnus-agent-mark-article
"J\M-#" gnus-agent-unmark-article
"@" gnus-agent-toggle-mark
"Jc" gnus-agent-catchup)
(defun gnus-agent-summary-make-menu-bar ()
(unless (boundp 'gnus-agent-summary-menu)
(easy-menu-define
gnus-agent-summary-menu gnus-agent-summary-mode-map ""
'("Agent"
["Toggle plugged" gnus-agent-toggle-plugged t]
["Mark as downloadable" gnus-agent-mark-article t]
["Unmark as downloadable" gnus-agent-unmark-article t]
["Toggle mark" gnus-agent-toggle-mark t]
["Fetch downloadable" gnus-agent-summary-fetch-group t]
["Catchup undownloaded" gnus-agent-catchup t]))))
(defvar gnus-agent-server-mode-map (make-sparse-keymap))
(gnus-define-keys gnus-agent-server-mode-map
"Jj" gnus-agent-toggle-plugged
"Ja" gnus-agent-add-server
"Jr" gnus-agent-remove-server)
(defun gnus-agent-server-make-menu-bar ()
(unless (boundp 'gnus-agent-server-menu)
(easy-menu-define
gnus-agent-server-menu gnus-agent-server-mode-map ""
'("Agent"
["Toggle plugged" gnus-agent-toggle-plugged t]
["Add" gnus-agent-add-server t]
["Remove" gnus-agent-remove-server t]))))
(defun gnus-agent-make-mode-line-string (string mouse-button mouse-func)
(if (and (fboundp 'propertize)
(fboundp 'make-mode-line-mouse-map))
(propertize string 'local-map
(make-mode-line-mouse-map mouse-button mouse-func)
'mouse-face
(cond ((and (featurep 'xemacs)
(find-face 'modeline))
'modeline)
((facep 'mode-line-highlight) 'mode-line-highlight)
((facep 'mode-line) 'mode-line)) )
string))
(defun gnus-agent-toggle-plugged (set-to)
"Toggle whether Gnus is unplugged or not."
(interactive (list (not gnus-plugged)))
(cond ((eq set-to gnus-plugged)
nil)
(set-to
(setq gnus-plugged set-to)
(gnus-run-hooks 'gnus-agent-plugged-hook)
(setcar (cdr gnus-agent-mode-status)
(gnus-agent-make-mode-line-string " Plugged"
'mouse-2
'gnus-agent-toggle-plugged))
(gnus-agent-go-online gnus-agent-go-online)
(gnus-agent-possibly-synchronize-flags))
(t
(gnus-agent-close-connections)
(setq gnus-plugged set-to)
(gnus-run-hooks 'gnus-agent-unplugged-hook)
(setcar (cdr gnus-agent-mode-status)
(gnus-agent-make-mode-line-string " Unplugged"
'mouse-2
'gnus-agent-toggle-plugged))))
(set-buffer-modified-p t))
(defmacro gnus-agent-while-plugged (&rest body)
`(let ((original-gnus-plugged gnus-plugged))
(unwind-protect
(progn (gnus-agent-toggle-plugged t)
,@body)
(gnus-agent-toggle-plugged original-gnus-plugged))))
(put 'gnus-agent-while-plugged 'lisp-indent-function 0)
(put 'gnus-agent-while-plugged 'edebug-form-spec '(body))
(defun gnus-agent-close-connections ()
"Close all methods covered by the Gnus agent."
(let ((methods (gnus-agent-covered-methods)))
(while methods
(gnus-close-server (pop methods)))))
(defun gnus-unplugged ()
"Start Gnus unplugged."
(interactive)
(setq gnus-plugged nil)
(gnus))
(defun gnus-plugged ()
"Start Gnus plugged."
(interactive)
(setq gnus-plugged t)
(gnus))
(defun gnus-slave-unplugged (&optional arg)
"Read news as a slave unplugged."
(interactive "P")
(setq gnus-plugged nil)
(gnus arg nil 'slave))
(defun gnus-agentize ()
"Allow Gnus to be an offline newsreader.
The gnus-agentize function is now called internally by gnus when
gnus-agent is set. If you wish to avoid calling gnus-agentize,
customize gnus-agent to nil.
This will modify the `gnus-setup-news-hook', and
`message-send-mail-real-function' variables, and install the Gnus agent
minor mode in all Gnus buffers."
(interactive)
(gnus-open-agent)
(add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
(unless gnus-agent-send-mail-function
(setq gnus-agent-send-mail-function
(or message-send-mail-real-function
(function (lambda () (funcall message-send-mail-function))))
message-send-mail-real-function 'gnus-agent-send-mail))
(unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers"))
(gnus-message 3 "First time agent user, agentizing remote groups...")
(mapc
(lambda (server-or-method)
(let ((method (gnus-server-to-method server-or-method)))
(when (memq (car method)
gnus-agent-auto-agentize-methods)
(push (gnus-method-to-server method)
gnus-agent-covered-methods)
(setq gnus-agent-method-p-cache nil))))
(cons gnus-select-method gnus-secondary-select-methods))
(gnus-agent-write-servers)))
(defun gnus-agent-queue-setup (&optional group-name)
"Make sure the queue group exists.
Optional arg GROUP-NAME allows to specify another group."
(unless (gnus-gethash (format "nndraft:%s" (or group-name "queue"))
gnus-newsrc-hashtb)
(gnus-request-create-group (or group-name "queue") '(nndraft ""))
(let ((gnus-level-default-subscribed 1))
(gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
nil '(nndraft "")))
(gnus-group-set-parameter
(format "nndraft:%s" (or group-name "queue"))
'gnus-dummy '((gnus-draft-mode)))))
(defun gnus-agent-send-mail ()
(if (or (not gnus-agent-queue-mail)
(and gnus-plugged (not (eq gnus-agent-queue-mail 'always))))
(funcall gnus-agent-send-mail-function)
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(gnus-agent-insert-meta-information 'mail)
(gnus-request-accept-article "nndraft:queue" nil t t)))
(defun gnus-agent-insert-meta-information (type &optional method)
"Insert meta-information into the message that says how it's to be posted.
TYPE can be either `mail' or `news'. If the latter, then METHOD can
be a select method."
(save-excursion
(message-remove-header gnus-agent-meta-information-header)
(goto-char (point-min))
(insert gnus-agent-meta-information-header ": "
(symbol-name type) " " (format "%S" method)
"\n")
(forward-char -1)
(while (search-backward "\n" nil t)
(replace-match "\\n" t t))))
(defun gnus-agent-restore-gcc ()
"Restore GCC field from saved header."
(save-excursion
(goto-char (point-min))
(while (re-search-forward
(concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t)
(replace-match "Gcc:" 'fixedcase))))
(defun gnus-agent-any-covered-gcc ()
(save-restriction
(message-narrow-to-headers)
(let* ((gcc (mail-fetch-field "gcc" nil t))
(methods (and gcc
(mapcar 'gnus-inews-group-method
(message-unquote-tokens
(message-tokenize-header
gcc " ,")))))
covered)
(while (and (not covered) methods)
(setq covered (gnus-agent-method-p (car methods))
methods (cdr methods)))
covered)))
(defun gnus-agent-possibly-save-gcc ()
"Save GCC if Gnus is unplugged."
(when (and (not gnus-plugged) (gnus-agent-any-covered-gcc))
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t))
(while (re-search-forward "^gcc:" nil t)
(replace-match (concat gnus-agent-gcc-header ":") 'fixedcase))))))
(defun gnus-agent-possibly-do-gcc ()
"Do GCC if Gnus is plugged."
(when (or gnus-plugged (not (gnus-agent-any-covered-gcc)))
(gnus-inews-do-gcc)))
(defun gnus-agent-fetch-groups (n)
"Put all new articles in the current groups into the Agent."
(interactive "P")
(unless gnus-plugged
(error "Groups can't be fetched when Gnus is unplugged"))
(gnus-group-iterate n 'gnus-agent-fetch-group))
(defun gnus-agent-fetch-group (&optional group)
"Put all new articles in GROUP into the Agent."
(interactive (list (gnus-group-group-name)))
(setq group (or group gnus-newsgroup-name))
(unless group
(error "No group on the current line"))
(gnus-agent-while-plugged
(let ((gnus-command-method (gnus-find-method-for-group group)))
(gnus-agent-with-fetch
(gnus-agent-fetch-group-1 group gnus-command-method)
(gnus-message 5 "Fetching %s...done" group)))))
(defun gnus-agent-add-group (category arg)
"Add the current group to an agent category."
(interactive
(list
(intern
(completing-read
"Add to category: "
(mapcar (lambda (cat) (list (symbol-name (car cat))))
gnus-category-alist)
nil t))
current-prefix-arg))
(let ((cat (assq category gnus-category-alist))
c groups)
(gnus-group-iterate arg
(lambda (group)
(when (gnus-agent-cat-groups (setq c (gnus-group-category group)))
(setf (gnus-agent-cat-groups c)
(delete group (gnus-agent-cat-groups c))))
(push group groups)))
(setf (gnus-agent-cat-groups cat)
(nconc (gnus-agent-cat-groups cat) groups))
(gnus-category-write)))
(defun gnus-agent-remove-group (arg)
"Remove the current group from its agent category, if any."
(interactive "P")
(let (c)
(gnus-group-iterate arg
(lambda (group)
(when (gnus-agent-cat-groups (setq c (gnus-group-category group)))
(setf (gnus-agent-cat-groups c)
(delete group (gnus-agent-cat-groups c))))))
(gnus-category-write)))
(defun gnus-agent-synchronize-flags ()
"Synchronize unplugged flags with servers."
(interactive)
(save-excursion
(dolist (gnus-command-method (gnus-agent-covered-methods))
(when (file-exists-p (gnus-agent-lib-file "flags"))
(gnus-agent-synchronize-flags-server gnus-command-method)))))
(defun gnus-agent-possibly-synchronize-flags ()
"Synchronize flags according to `gnus-agent-synchronize-flags'."
(interactive)
(save-excursion
(dolist (gnus-command-method (gnus-agent-covered-methods))
(when (and (file-exists-p (gnus-agent-lib-file "flags"))
(eq (gnus-server-status gnus-command-method) 'ok))
(gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
(defun gnus-agent-synchronize-flags-server (method)
"Synchronize flags set when unplugged for server."
(let ((gnus-command-method method)
(gnus-agent nil))
(when (file-exists-p (gnus-agent-lib-file "flags"))
(set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
(erase-buffer)
(nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
(cond ((null gnus-plugged)
(gnus-message
1 "You must be plugged to synchronize flags with server %s"
(nth 1 gnus-command-method)))
((null (gnus-check-server gnus-command-method))
(gnus-message
1 "Couldn't open server %s" (nth 1 gnus-command-method)))
(t
(condition-case err
(while t
(let ((bgn (point)))
(eval (read (current-buffer)))
(delete-region bgn (point))))
(end-of-file
(delete-file (gnus-agent-lib-file "flags")))
(error
(let ((file (gnus-agent-lib-file "flags")))
(write-region (point-min) (point-max)
(gnus-agent-lib-file "flags") nil 'silent)
(error "Couldn't set flags from file %s due to %s"
file (error-message-string err)))))))
(kill-buffer nil))))
(defun gnus-agent-possibly-synchronize-flags-server (method)
"Synchronize flags for server according to `gnus-agent-synchronize-flags'."
(when (or (and gnus-agent-synchronize-flags
(not (eq gnus-agent-synchronize-flags 'ask)))
(and (eq gnus-agent-synchronize-flags 'ask)
(gnus-y-or-n-p (format "Synchronize flags on server `%s'? "
(cadr method)))))
(gnus-agent-synchronize-flags-server method)))
(defun gnus-agent-rename-group (old-group new-group)
"Rename fully-qualified OLD-GROUP as NEW-GROUP.
Always updates the agent, even when disabled, as the old agent
files would corrupt gnus when the agent was next enabled.
Depends upon the caller to determine whether group renaming is
supported."
(let* ((old-command-method (gnus-find-method-for-group old-group))
(old-path (directory-file-name
(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)
(gnus-agent-group-pathname new-group)))))
(gnus-rename-file old-path new-path t)
(let* ((old-real-group (gnus-group-real-name old-group))
(new-real-group (gnus-group-real-name new-group))
(old-active (gnus-agent-get-group-info old-command-method old-real-group)))
(gnus-agent-save-group-info old-command-method old-real-group nil)
(gnus-agent-save-group-info new-command-method new-real-group old-active)
(let ((old-local (gnus-agent-get-local old-group
old-real-group old-command-method)))
(gnus-agent-set-local old-group
nil nil
old-real-group old-command-method)
(gnus-agent-set-local new-group
(car old-local) (cdr old-local)
new-real-group new-command-method)))))
(defun gnus-agent-delete-group (group)
"Delete fully-qualified GROUP.
Always updates the agent, even when disabled, as the old agent
files would corrupt gnus when the agent was next enabled.
Depends upon the caller to determine whether group deletion is
supported."
(let* ((command-method (gnus-find-method-for-group group))
(path (directory-file-name
(let (gnus-command-method command-method)
(gnus-agent-group-pathname group)))))
(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)))))
(defun gnus-agent-add-server ()
"Enroll SERVER in the agent program."
(interactive)
(let* ((server (gnus-server-server-name))
(named-server (gnus-server-named-server))
(method (and server
(gnus-server-get-method nil server))))
(unless server
(error "No server on the current line"))
(when (gnus-agent-method-p method)
(error "Server already in the agent program"))
(push named-server gnus-agent-covered-methods)
(setq gnus-agent-method-p-cache nil)
(gnus-server-update-server server)
(gnus-agent-write-servers)
(gnus-message 1 "Entered %s into the Agent" server)))
(defun gnus-agent-remove-server ()
"Remove SERVER from the agent program."
(interactive)
(let* ((server (gnus-server-server-name))
(named-server (gnus-server-named-server)))
(unless server
(error "No server on the current line"))
(unless (member named-server gnus-agent-covered-methods)
(error "Server not in the agent program"))
(setq gnus-agent-covered-methods
(delete named-server gnus-agent-covered-methods)
gnus-agent-method-p-cache nil)
(gnus-server-update-server server)
(gnus-agent-write-servers)
(gnus-message 1 "Removed %s from the agent" server)))
(defun gnus-agent-read-servers ()
"Read the alist of covered servers."
(setq gnus-agent-covered-methods
(gnus-agent-read-file
(nnheader-concat gnus-agent-directory "lib/servers"))
gnus-agent-method-p-cache nil)
(if gnus-server-alist
(gnus-agent-read-servers-validate)))
(defun gnus-agent-read-servers-validate ()
(mapcar (lambda (server-or-method)
(let* ((server (if (stringp server-or-method)
server-or-method
(gnus-method-to-server server-or-method)))
(method (gnus-server-to-method server)))
(if method
(unless (member server gnus-agent-covered-methods)
(push server gnus-agent-covered-methods)
(setq gnus-agent-method-p-cache nil))
(gnus-message 1 "Ignoring disappeared server `%s'" server))))
(prog1 gnus-agent-covered-methods
(setq gnus-agent-covered-methods nil))))
(defun gnus-agent-read-servers-validate-native (native-method)
(setq gnus-agent-covered-methods
(mapcar (lambda (method)
(if (or (not method)
(equal method native-method))
"native"
method)) gnus-agent-covered-methods)))
(defun gnus-agent-write-servers ()
"Write the alist of covered servers."
(gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
(let ((coding-system-for-write nnheader-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
(with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
(prin1 gnus-agent-covered-methods
(current-buffer)))))
(defun gnus-agent-mark-article (n &optional unmark)
"Mark the next N articles as downloadable.
If N is negative, mark backward instead. If UNMARK is non-nil, remove
the mark instead. The difference between N and the actual number of
articles marked is returned."
(interactive "p")
(let ((backward (< n 0))
(n (abs n)))
(while (and
(> n 0)
(progn
(gnus-summary-set-agent-mark
(gnus-summary-article-number) unmark)
(zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
(setq n (1- n)))
(when (/= 0 n)
(gnus-message 7 "No more articles"))
(gnus-summary-recenter)
(gnus-summary-position-point)
n))
(defun gnus-agent-unmark-article (n)
"Remove the downloadable mark from the next N articles.
If N is negative, unmark backward instead. The difference between N and
the actual number of articles unmarked is returned."
(interactive "p")
(gnus-agent-mark-article n t))
(defun gnus-agent-toggle-mark (n)
"Toggle the downloadable mark from the next N articles.
If N is negative, toggle backward instead. The difference between N and
the actual number of articles toggled is returned."
(interactive "p")
(gnus-agent-mark-article n 'toggle))
(defun gnus-summary-set-agent-mark (article &optional unmark)
"Mark ARTICLE as downloadable. If UNMARK is nil, article is marked.
When UNMARK is t, the article is unmarked. For any other value, the
article's mark is toggled."
(let ((unmark (cond ((eq nil unmark)
nil)
((eq t unmark)
t)
(t
(memq article gnus-newsgroup-downloadable)))))
(when (gnus-summary-goto-subject article nil t)
(gnus-summary-update-mark
(if unmark
(progn
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
(gnus-article-mark article))
(setq gnus-newsgroup-downloadable
(gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
gnus-downloadable-mark)
'unread))))
(defun gnus-agent-get-undownloaded-list ()
"Construct list of articles that have not been downloaded."
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
(when (set (make-local-variable 'gnus-newsgroup-agentized)
(gnus-agent-method-p gnus-command-method))
(let* ((alist (gnus-agent-load-alist gnus-newsgroup-name))
(headers (sort (mapcar (lambda (h)
(mail-header-number h))
gnus-newsgroup-headers) '<))
(cached (and gnus-use-cache gnus-newsgroup-cached))
(undownloaded (list nil))
(tail-undownloaded undownloaded)
(unfetched (list nil))
(tail-unfetched unfetched))
(while (and alist headers)
(let ((a (caar alist))
(h (car headers)))
(cond ((< a h)
(setq alist (cdr alist)))
((> a h)
(gnus-agent-append-to-list tail-undownloaded h)
(gnus-agent-append-to-list tail-unfetched h)
(setq headers (cdr headers)))
((cdar alist)
(setq alist (cdr alist))
(setq headers (cdr headers))
nil )
(t
(setq alist (cdr alist))
(setq headers (cdr headers))
(while (and cached (< (car cached) a))
(setq cached (cdr cached)))
(unless (equal a (car cached))
(gnus-agent-append-to-list tail-undownloaded a))))))
(while headers
(let ((num (pop headers)))
(gnus-agent-append-to-list tail-undownloaded num)
(gnus-agent-append-to-list tail-unfetched num)))
(setq gnus-newsgroup-undownloaded (cdr undownloaded)
gnus-newsgroup-unfetched (cdr unfetched))))))
(defun gnus-agent-catchup ()
"Mark as read all unhandled articles.
An article is unhandled if it is neither cached, nor downloaded, nor
downloadable."
(interactive)
(save-excursion
(let ((articles gnus-newsgroup-undownloaded))
(when (or gnus-newsgroup-downloadable
gnus-newsgroup-cached)
(setq articles (gnus-sorted-ndifference
(gnus-sorted-ndifference
(gnus-copy-sequence articles)
gnus-newsgroup-downloadable)
gnus-newsgroup-cached)))
(while articles
(gnus-summary-mark-article
(pop articles) gnus-catchup-mark)))
(gnus-summary-position-point)))
(defun gnus-agent-summary-fetch-series ()
(interactive)
(when gnus-newsgroup-processable
(setq gnus-newsgroup-downloadable
(let* ((dl gnus-newsgroup-downloadable)
(processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
(gnus-newsgroup-downloadable processable))
(gnus-agent-summary-fetch-group)
(mapc #'gnus-summary-remove-process-mark
(gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded))
(gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded))))))
(defun gnus-agent-summary-fetch-group (&optional all)
"Fetch the downloadable articles in the group.
Optional arg ALL, if non-nil, means to fetch all articles."
(interactive "P")
(let ((articles
(if all gnus-newsgroup-articles
gnus-newsgroup-downloadable))
(gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))
fetched-articles)
(gnus-agent-while-plugged
(unless articles
(error "No articles to download"))
(gnus-agent-with-fetch
(setq gnus-newsgroup-undownloaded
(gnus-sorted-ndifference
gnus-newsgroup-undownloaded
(setq fetched-articles
(gnus-agent-fetch-articles
gnus-newsgroup-name articles)))))
(save-excursion
(dolist (article articles)
(let ((was-marked-downloadable
(memq article gnus-newsgroup-downloadable)))
(cond (gnus-agent-mark-unread-after-downloaded
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
(gnus-summary-mark-article article gnus-unread-mark))
(was-marked-downloadable
(gnus-summary-set-agent-mark article t)))
(when (gnus-summary-goto-subject article nil t)
(gnus-summary-update-download-mark article))))))
fetched-articles))
(defun gnus-agent-fetch-selected-article ()
"Fetch the current article as it is selected.
This can be added to `gnus-select-article-hook' or
`gnus-mark-article-hook'."
(let ((gnus-command-method gnus-current-select-method))
(when (and gnus-plugged (gnus-agent-method-p gnus-command-method))
(when (gnus-agent-fetch-articles
gnus-newsgroup-name
(list gnus-current-article))
(setq gnus-newsgroup-undownloaded
(delq gnus-current-article gnus-newsgroup-undownloaded))
(gnus-summary-update-download-mark gnus-current-article)))))
(defun gnus-agent-synchronize-group-flags (group actions server)
"Update a plugged group by performing the indicated actions."
(let* ((gnus-command-method (gnus-server-to-method server))
(info
(or (gnus-get-info group)
(gnus-get-info
(setq group (gnus-group-full-name
group gnus-command-method))))))
(gnus-request-set-mark group actions)
(when info
(dolist (action actions)
(let ((range (nth 0 action))
(what (nth 1 action))
(marks (nth 2 action)))
(dolist (mark marks)
(cond ((eq mark 'read)
(gnus-info-set-read
info
(funcall (if (eq what 'add)
'gnus-range-add
'gnus-remove-from-range)
(gnus-info-read info)
range))
(gnus-get-unread-articles-in-group
info
(gnus-active (gnus-info-group info))))
((memq mark '(tick))
(let ((info-marks (assoc mark (gnus-info-marks info))))
(unless info-marks
(gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info))))
(setcdr info-marks (funcall (if (eq what 'add)
'gnus-range-add
'gnus-remove-from-range)
(cdr info-marks)
range))))))))
(when (gnus-buffer-live-p gnus-group-buffer)
(gnus-group-update-group group t)))
nil))
(defun gnus-agent-save-active (method)
(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)
(gnus-agent-write-active file new)
(erase-buffer)
(nnheader-insert-file-contents file))))
(defun gnus-agent-write-active (file new)
(gnus-make-directory (file-name-directory file))
(let ((nnmail-active-file-coding-system gnus-agent-file-coding-system))
(gnus-write-active-file file new nil)))
(defun gnus-agent-possibly-alter-active (group active &optional info)
"Possibly expand a group's active range to include articles
downloaded into the agent."
(let* ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group))))
(when (gnus-agent-method-p gnus-command-method)
(let* ((local (gnus-agent-get-local group))
(active-min (or (car active) 0))
(active-max (or (cdr active) 0))
(agent-min (or (car local) active-min))
(agent-max (or (cdr local) active-max)))
(when (< agent-min active-min)
(setcar active agent-min))
(when (> agent-max active-max)
(setcdr active agent-max))
(when (and info (< agent-max (- active-min 100)))
(let ((read (gnus-info-read info)))
(gnus-info-set-read
info
(gnus-range-add
read
(list (cons (1+ agent-max)
(1- active-min))))))
(gnus-agent-set-local group agent-min (1- active-min)))))))
(defun gnus-agent-save-group-info (method group active)
"Update a single group's active range in the agent's copy of the server's active file."
(when (gnus-agent-method-p method)
(let* ((gnus-command-method (or method gnus-command-method))
(coding-system-for-write nnheader-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system)
(file (gnus-agent-lib-file "active"))
oactive-min oactive-max)
(gnus-make-directory (file-name-directory file))
(with-temp-file file
(mm-disable-multibyte)
(when (file-exists-p file)
(nnheader-insert-file-contents file)
(goto-char (point-min))
(when (re-search-forward
(concat "^" (regexp-quote group) " ") nil t)
(save-excursion
(setq oactive-max (read (current-buffer)) oactive-min (read (current-buffer)))) (gnus-delete-line)))
(when active
(insert (format "%S %d %d y\n" (intern group)
(max (or oactive-max (cdr active)) (cdr active))
(min (or oactive-min (car active)) (car active))))
(goto-char (point-max))
(while (search-backward "\\." nil t)
(delete-char 1)))))))
(defun gnus-agent-get-group-info (method group)
"Get a single group's active range in the agent's copy of the server's active file."
(when (gnus-agent-method-p method)
(let* ((gnus-command-method (or method gnus-command-method))
(coding-system-for-write nnheader-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system)
(file (gnus-agent-lib-file "active"))
oactive-min oactive-max)
(gnus-make-directory (file-name-directory file))
(with-temp-buffer
(mm-disable-multibyte)
(when (file-exists-p file)
(nnheader-insert-file-contents file)
(goto-char (point-min))
(when (re-search-forward
(concat "^" (regexp-quote group) " ") nil t)
(save-excursion
(setq oactive-max (read (current-buffer)) oactive-min (read (current-buffer))) (cons oactive-min oactive-max))))))))
(defun gnus-agent-group-path (group)
"Translate GROUP into a file name."
(setq group
(nnheader-translate-file-chars
(nnheader-replace-duplicate-chars-in-string
(nnheader-replace-chars-in-string
(gnus-group-real-name (gnus-group-decoded-name group))
?/ ?_)
?. ?_)))
(if (or nnmail-use-long-file-names
(file-directory-p (expand-file-name group (gnus-agent-directory))))
group
(mm-encode-coding-string
(nnheader-replace-chars-in-string group ?. ?/)
nnmail-pathname-coding-system)))
(defun gnus-agent-group-pathname (group)
"Translate GROUP into a file name."
(let ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group))))
(nnmail-group-pathname (gnus-group-real-name
(gnus-group-decoded-name group))
(gnus-agent-directory))))
(defun gnus-agent-get-function (method)
(if (gnus-online method)
(car method)
(require 'nnagent)
'nnagent))
(defun gnus-agent-covered-methods ()
"Return the subset of methods that are covered by the agent."
(delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods)))
(defun gnus-agent-history-buffer ()
(cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
(defun gnus-agent-open-history ()
(save-excursion
(push (cons (gnus-agent-method)
(set-buffer (gnus-get-buffer-create
(format " *Gnus agent %s history*"
(gnus-agent-method)))))
gnus-agent-history-buffers)
(mm-disable-multibyte) (erase-buffer)
(insert "\n")
(let ((file (gnus-agent-lib-file "history")))
(when (file-exists-p file)
(nnheader-insert-file-contents file))
(set (make-local-variable 'gnus-agent-file-name) file))))
(defun gnus-agent-close-history ()
(when (gnus-buffer-live-p gnus-agent-current-history)
(kill-buffer gnus-agent-current-history)
(setq gnus-agent-history-buffers
(delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
gnus-agent-history-buffers))))
(defun gnus-agent-fetch-articles (group articles)
"Fetch ARTICLES from GROUP and put them into the Agent."
(when articles
(gnus-agent-load-alist group)
(let* ((alist gnus-agent-article-alist)
(headers (if (< (length articles) 2) nil gnus-newsgroup-headers))
(selected-sets (list nil))
(current-set-size 0)
article
header-number)
(while (setq article (pop articles))
(while (> article (or (caar alist) (1+ article)))
(setq alist (cdr alist)))
(unless (and (eq article (caar alist))
(cdar alist))
(while (> article
(setq header-number
(let* ((header (car headers)))
(if header
(mail-header-number header)
(1+ article)))))
(setq headers (cdr headers)))
(setcar selected-sets (cons article (car selected-sets)))
(when (< gnus-agent-max-fetch-size
(setq current-set-size
(+ current-set-size
(if (= header-number article)
(let ((char-size (mail-header-chars
(car headers))))
(if (<= char-size 0)
(max (* 65 (mail-header-lines
(car headers)))
1000)
char-size))
0))))
(setcar selected-sets (nreverse (car selected-sets)))
(setq selected-sets (cons nil selected-sets)
current-set-size 0))))
(when (or (cdr selected-sets) (car selected-sets))
(let* ((fetched-articles (list nil))
(tail-fetched-articles fetched-articles)
(dir (gnus-agent-group-pathname group))
(date (time-to-days (current-time)))
(case-fold-search t)
pos crosses id)
(setcar selected-sets (nreverse (car selected-sets)))
(setq selected-sets (nreverse selected-sets))
(gnus-make-directory dir)
(gnus-message 7 "Fetching articles for %s..." group)
(unwind-protect
(while (setq articles (pop selected-sets))
(if (gnus-check-backend-function 'retrieve-articles group)
(setq pos (gnus-retrieve-articles articles group))
(with-temp-buffer
(let (article)
(while (setq article (pop articles))
(gnus-message 10 "Fetching article %s for %s..."
article group)
(when (or
(gnus-backlog-request-article group article
nntp-server-buffer)
(gnus-request-article article group))
(goto-char (point-max))
(push (cons article (point)) pos)
(insert-buffer-substring nntp-server-buffer)))
(copy-to-buffer
nntp-server-buffer (point-min) (point-max))
(setq pos (nreverse pos)))))
(save-excursion
(set-buffer nntp-server-buffer)
(while pos
(narrow-to-region (cdar pos) (or (cdadr pos) (point-max)))
(goto-char (point-min))
(unless (eobp) (when (search-forward "\n\n" nil t)
(when (search-backward "\nXrefs: " nil t)
(goto-char (match-end 0)) (skip-chars-forward "^ ") (skip-chars-forward " ")
(setq crosses nil)
(while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *")
(push (cons (buffer-substring (match-beginning 1)
(match-end 1))
(string-to-number
(buffer-substring (match-beginning 2)
(match-end 2))))
crosses)
(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)
(concat dir (number-to-string (caar pos)))
nil 'silent))
(gnus-agent-append-to-list
tail-fetched-articles (caar pos)))
(widen)
(setq pos (cdr pos)))))
(gnus-agent-save-alist group (cdr fetched-articles) date)
(gnus-message 7 ""))
(cdr fetched-articles))))))
(defun gnus-agent-unfetch-articles (group articles)
"Delete ARTICLES that were fetched from GROUP into the agent."
(when articles
(gnus-agent-load-alist group)
(let* ((alist (cons nil gnus-agent-article-alist))
(articles (sort articles #'<))
(next-possibility alist)
(delete-this (pop articles)))
(while (and (cdr next-possibility) delete-this)
(let ((have-this (caar (cdr next-possibility))))
(cond ((< delete-this have-this)
(setq delete-this (pop articles)))
((= delete-this have-this)
(let ((timestamp (cdar (cdr next-possibility))))
(when timestamp
(let* ((file-name (concat (gnus-agent-group-pathname group)
(number-to-string have-this))))
(delete-file file-name))))
(setcdr next-possibility (cddr next-possibility)))
(t
(setq next-possibility (cdr next-possibility))))))
(setq gnus-agent-article-alist (cdr alist))
(gnus-agent-save-alist group))))
(defun gnus-agent-crosspost (crosses article &optional date)
(setq date (or date t))
(let (gnus-agent-article-alist group alist beg end)
(save-excursion
(set-buffer gnus-agent-overview-buffer)
(when (nnheader-find-nov-line article)
(forward-word 1)
(setq beg (point))
(setq end (progn (forward-line 1) (point)))))
(while crosses
(setq group (caar crosses))
(unless (setq alist (assoc group gnus-agent-group-alist))
(push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
gnus-agent-group-alist))
(setcdr alist (cons (cons (cdar crosses) date) (cdr alist)))
(save-excursion
(set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*"
group)))
(when (= (point-max) (point-min))
(push (cons group (current-buffer)) gnus-agent-buffer-alist)
(ignore-errors
(nnheader-insert-file-contents
(gnus-agent-article-name ".overview" group))))
(nnheader-find-nov-line (string-to-number (cdar crosses)))
(insert (string-to-number (cdar crosses)))
(insert-buffer-substring gnus-agent-overview-buffer beg end)
(gnus-agent-check-overview-buffer))
(setq crosses (cdr crosses)))))
(defun gnus-agent-backup-overview-buffer ()
(when gnus-newsgroup-name
(let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name))
(cnt 0)
name)
(while (file-exists-p
(setq name (concat root "~"
(int-to-string (setq cnt (1+ cnt))) "~"))))
(write-region (point-min) (point-max) name nil 'no-msg)
(gnus-message 1 "Created backup copy of overview in %s." name)))
t)
(defun gnus-agent-check-overview-buffer (&optional buffer)
"Check the overview file given for sanity.
In particular, checks that the file is sorted by article number
and that there are no duplicates."
(let ((prev-num -1)
(backed-up nil))
(save-excursion
(when buffer
(set-buffer buffer))
(save-restriction
(widen)
(goto-char (point-min))
(while (< (point) (point-max))
(let ((p (point))
(cur (condition-case nil
(read (current-buffer))
(error nil))))
(cond
((or (not (integerp cur))
(not (eq (char-after) ?\t)))
(or backed-up
(setq backed-up (gnus-agent-backup-overview-buffer)))
(gnus-message 1
"Overview buffer contains garbage '%s'."
(buffer-substring
p (gnus-point-at-eol))))
((= cur prev-num)
(or backed-up
(setq backed-up (gnus-agent-backup-overview-buffer)))
(gnus-message 1
"Duplicate overview line for %d" cur)
(delete-region p (progn (forward-line 1) (point))))
((< cur prev-num)
(or backed-up
(setq backed-up (gnus-agent-backup-overview-buffer)))
(gnus-message 1 "Overview buffer not sorted!")
(sort-numeric-fields 1 (point-min) (point-max))
(goto-char (point-min))
(setq prev-num -1))
(t
(setq prev-num cur)))
(forward-line 1)))))))
(defun gnus-agent-flush-cache ()
(save-excursion
(while gnus-agent-buffer-alist
(set-buffer (cdar gnus-agent-buffer-alist))
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(write-region (point-min) (point-max)
(gnus-agent-article-name ".overview"
(caar gnus-agent-buffer-alist))
nil 'silent))
(setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist)))
(while gnus-agent-group-alist
(with-temp-file (gnus-agent-article-name
".agentview" (caar gnus-agent-group-alist))
(princ (cdar gnus-agent-group-alist))
(insert "\n")
(princ 1 (current-buffer))
(insert "\n"))
(setq gnus-agent-group-alist (cdr gnus-agent-group-alist)))))
(defun gnus-agent-find-parameter (group symbol)
"Search for GROUPs SYMBOL in the group's parameters, the group's
topic parameters, the group's category, or the customizable
variables. Returns the first non-nil value found."
(or (gnus-group-find-parameter group symbol t)
(gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t)
(symbol-value
(cdr
(assq symbol
'((agent-short-article . gnus-agent-short-article)
(agent-long-article . gnus-agent-long-article)
(agent-low-score . gnus-agent-low-score)
(agent-high-score . gnus-agent-high-score)
(agent-days-until-old . gnus-agent-expire-days)
(agent-enable-expiration
. gnus-agent-enable-expiration)
(agent-predicate . gnus-agent-predicate)))))))
(defun gnus-agent-fetch-headers (group &optional force)
"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."
(let* ((fetch-all (and gnus-agent-consider-all-articles
(not (gnus-predicate-implies-unread
(gnus-agent-find-parameter group
'agent-predicate)))))
(articles (if fetch-all
(gnus-uncompress-range (gnus-active group))
(gnus-list-of-unread-articles group)))
(gnus-decode-encoded-word-function 'identity)
(file (gnus-agent-article-name ".overview" group)))
(unless fetch-all
(dolist (arts (gnus-info-marks (gnus-get-info group)))
(unless (memq (car arts) '(seen recent killed cache))
(setq articles (gnus-range-add articles (cdr arts)))))
(setq articles (sort (gnus-uncompress-sequence articles) '<)))
(let ((articles articles))
(when (and (or gnus-agent-cache
(not gnus-plugged))
(gnus-agent-load-alist group))
(if fetch-all
(setq articles (gnus-agent-uncached-articles articles group))
(let ((low (1+ (caar (last gnus-agent-article-alist))))
(high (cdr (gnus-active group))))
(setq articles (gnus-list-range-intersection
articles (list (cons low high)))))))
(gnus-message
10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
(gnus-compress-sequence articles t))
(save-excursion
(set-buffer nntp-server-buffer)
(if articles
(progn
(gnus-message 7 "Fetching headers for %s..." group)
(gnus-make-directory (nnheader-translate-file-chars
(file-name-directory file) t))
(unless (eq 'nov (gnus-retrieve-headers articles group))
(nnvirtual-convert-headers))
(gnus-agent-check-overview-buffer)
(copy-to-buffer
gnus-agent-overview-buffer (point-min) (point-max))
(gnus-agent-braid-nov group articles file)
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(gnus-agent-check-overview-buffer)
(write-region (point-min) (point-max) file nil 'silent))
(gnus-agent-save-alist group articles nil)
articles)
(ignore-errors
(erase-buffer)
(nnheader-insert-file-contents file)))))
articles))
(defsubst gnus-agent-read-article-number ()
"Reads the article number at point. Returns nil when a valid article number can not be read."
(when (looking-at "[0-9]+\t")
(let ((len (- (match-end 0) (match-beginning 0))))
(cond ((< len 9)
(read (current-buffer)))
((= len 9)
(let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0))))
(num (read (current-buffer)))
(str2 (int-to-string num)))
(when (equal str1 str2)
num)))))))
(defsubst gnus-agent-copy-nov-line (article)
"Copy the indicated ARTICLE from the overview buffer to the nntp server buffer."
(let (art b e)
(set-buffer gnus-agent-overview-buffer)
(while (and (not (eobp))
(or (not (setq art (gnus-agent-read-article-number)))
(< art article)))
(forward-line 1))
(beginning-of-line)
(if (or (eobp)
(not (eq article art)))
(set-buffer nntp-server-buffer)
(setq b (point))
(setq e (progn (forward-line 1) (point)))
(set-buffer nntp-server-buffer)
(insert-buffer-substring gnus-agent-overview-buffer b e))))
(defun gnus-agent-braid-nov (group 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
FILE and places the combined valid headers into
`nntp-server-buffer'. This function can be used, when file
doesn't exist, to valid the overview buffer."
(let (start last)
(set-buffer gnus-agent-overview-buffer)
(goto-char (point-min))
(set-buffer nntp-server-buffer)
(erase-buffer)
(when (file-exists-p file)
(nnheader-insert-file-contents file))
(goto-char (point-max))
(forward-line -1)
(unless (or (= (point-min) (point-max))
(< (setq last (read (current-buffer))) (car articles)))
(when (nnheader-find-nov-line (car articles))
(delete-region (point) (progn (forward-line 1) (point))))
(gnus-agent-copy-nov-line (pop articles))
(ignore-errors
(while articles
(while (let ((art (read (current-buffer))))
(cond ((< art (car articles))
(forward-line 1)
t)
((= art (car articles))
(beginning-of-line)
(delete-region
(point) (progn (forward-line 1) (point)))
nil)
(t
(beginning-of-line)
nil))))
(gnus-agent-copy-nov-line (pop articles)))))
(goto-char (point-max))
(when articles
(when last
(set-buffer gnus-agent-overview-buffer)
(setq start (point))
(set-buffer nntp-server-buffer))
(let ((p (point)))
(insert-buffer-substring gnus-agent-overview-buffer start)
(goto-char p))
(setq last (or last -134217728))
(while (catch 'problems
(let (sort art)
(while (not (eobp))
(setq art (gnus-agent-read-article-number))
(cond ((not art)
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point))))
((< art last)
(setq sort t)
(forward-line 1))
((= art last)
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point))))
(t
(setq last art)
(forward-line 1))))
(when sort
(sort-numeric-fields 1 (point-min) (point-max))
(goto-char (point-min))
(setq last -134217728)
(throw 'problems t))
nil))))))
(eval-when-compile
(defvar gnus-agent-read-agentview))
(defun gnus-agent-load-alist (group)
"Load the article-state alist for GROUP."
(let ((gnus-agent-read-agentview group))
(setq gnus-agent-article-alist
(gnus-cache-file-contents
(gnus-agent-article-name ".agentview" group)
'gnus-agent-file-loading-cache
'gnus-agent-read-agentview))))
(defun gnus-agent-read-agentview (file)
"Load FILE and do a `read' there."
(with-temp-buffer
(condition-case nil
(progn
(nnheader-insert-file-contents file)
(goto-char (point-min))
(let ((alist (read (current-buffer)))
(version (condition-case nil (read (current-buffer))
(end-of-file 0)))
changed-version)
(cond
((= version 0)
(let ((inhibit-quit t)
entry)
(gnus-agent-open-history)
(set-buffer (gnus-agent-history-buffer))
(goto-char (point-min))
(while (not (eobp))
(if (and (looking-at
"[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)")
(string= (match-string 2)
gnus-agent-read-agentview)
(setq entry (assoc (string-to-number (match-string 3)) alist)))
(setcdr entry (string-to-number (match-string 1))))
(forward-line 1))
(gnus-agent-close-history)
(setq changed-version t)))
((= version 1)
(setq changed-version (not (= 1 gnus-agent-article-alist-save-format))))
((= version 2)
(let (uncomp)
(mapcar
(lambda (comp-list)
(let ((state (car comp-list))
(sequence (inline
(gnus-uncompress-range
(cdr comp-list)))))
(mapcar (lambda (article-id)
(setq uncomp (cons (cons article-id state) uncomp)))
sequence)))
alist)
(setq alist (sort uncomp 'car-less-than-car)))
(setq changed-version (not (= 2 gnus-agent-article-alist-save-format)))))
(when changed-version
(let ((gnus-agent-article-alist alist))
(gnus-agent-save-alist gnus-agent-read-agentview)))
alist))
(file-error nil))))
(defun gnus-agent-save-alist (group &optional articles state)
"Save the article-state alist for GROUP."
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(prev (cons nil gnus-agent-article-alist))
(all prev)
print-level print-length item article)
(while (setq article (pop articles))
(while (and (cdr prev)
(< (caadr prev) article))
(setq prev (cdr prev)))
(cond
((not (cdr prev))
(setcdr prev (list (cons article state))))
((> (caadr prev) article)
(setcdr prev (cons (cons article state) (cdr prev))))
((= (caadr prev) article)
(setcdr (cadr prev) state)))
(setq prev (cdr prev)))
(setq gnus-agent-article-alist (cdr all))
(gnus-agent-set-local group
(caar gnus-agent-article-alist)
(caar (last gnus-agent-article-alist)))
(gnus-make-directory (gnus-agent-article-name "" group))
(with-temp-file (gnus-agent-article-name ".agentview" group)
(cond ((eq gnus-agent-article-alist-save-format 1)
(princ gnus-agent-article-alist (current-buffer)))
((eq gnus-agent-article-alist-save-format 2)
(let ((compressed nil))
(mapcar (lambda (pair)
(let* ((article-id (car pair))
(day-of-download (cdr pair))
(comp-list (assq day-of-download compressed)))
(if comp-list
(setcdr comp-list
(cons article-id (cdr comp-list)))
(setq compressed
(cons (list day-of-download article-id)
compressed)))
nil)) gnus-agent-article-alist)
(mapcar (lambda (comp-list)
(setcdr comp-list
(gnus-compress-sequence
(nreverse (cdr comp-list)))))
compressed)
(princ compressed (current-buffer)))))
(insert "\n")
(princ gnus-agent-article-alist-save-format (current-buffer))
(insert "\n"))))
(defvar gnus-agent-article-local nil)
(defvar gnus-agent-file-loading-local nil)
(defun gnus-agent-load-local (&optional method)
"Load the METHOD'S local file. The local file contains min/max
article counts for each of the method's subscribed groups."
(let ((gnus-command-method (or method gnus-command-method)))
(setq gnus-agent-article-local
(gnus-cache-file-contents
(gnus-agent-lib-file "local")
'gnus-agent-file-loading-local
'gnus-agent-read-and-cache-local))))
(defun gnus-agent-read-and-cache-local (file)
"Load and read FILE then bind its contents to
gnus-agent-article-local. If that variable had `dirty' (also known as
modified) original contents, they are first saved to their own file."
(if (and gnus-agent-article-local
(symbol-value (intern "+dirty" gnus-agent-article-local)))
(gnus-agent-save-local))
(gnus-agent-read-local file))
(defun gnus-agent-read-local (file)
"Load FILE and do a `read' there."
(let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
(point-max))))
(line 1))
(with-temp-buffer
(condition-case nil
(let ((nnheader-file-coding-system gnus-agent-file-coding-system))
(nnheader-insert-file-contents file))
(file-error))
(goto-char (point-min))
(while (= (following-char) ?\ (forward-line 1)
(setq line (1+ line)))
(while (not (eobp))
(condition-case err
(let (group
min
max
(cur (current-buffer))
(obarray my-obarray))
(setq group (read cur)
min (read cur)
max (read cur))
(when (stringp group)
(setq group (intern group my-obarray)))
(set group (cons (+ 0 min) (+ 0 max))))
(error
(gnus-message 3 "Warning - invalid agent local: %s on line %d: %s"
file line (error-message-string err))))
(forward-line 1)
(setq line (1+ line))))
(set (intern "+dirty" my-obarray) nil)
(set (intern "+method" my-obarray) gnus-command-method)
my-obarray))
(defun gnus-agent-save-local (&optional force)
"Save gnus-agent-article-local under it method's agent.lib directory."
(let ((my-obarray gnus-agent-article-local))
(when (and my-obarray
(or force (symbol-value (intern "+dirty" my-obarray))))
(let* ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
(dest (gnus-agent-lib-file "local")))
(gnus-make-directory (gnus-agent-lib-file ""))
(let ((buffer-file-coding-system gnus-agent-file-coding-system))
(with-temp-file dest
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
(file-name-coding-system nnmail-pathname-coding-system)
print-level print-length item article
(standard-output (current-buffer)))
(mapatoms (lambda (symbol)
(cond ((not (boundp symbol))
nil)
((member (symbol-name symbol) '("+dirty" "+method"))
nil)
(t
(let ((range (symbol-value symbol)))
(when range
(prin1 symbol)
(princ " ")
(princ (car range))
(princ " ")
(princ (cdr range))
(princ "\n"))))))
my-obarray))))))))
(defun gnus-agent-get-local (group &optional gmane method)
(let* ((gmane (or gmane (gnus-group-real-name group)))
(gnus-command-method (or method (gnus-find-method-for-group group)))
(local (gnus-agent-load-local))
(symb (intern gmane local))
(minmax (and (boundp symb) (symbol-value symb))))
(unless minmax
(let* ((gnus-agent-article-alist gnus-agent-article-alist)
(gnus-agent-file-loading-cache gnus-agent-file-loading-cache)
(alist (gnus-agent-load-alist group)))
(when alist
(setq minmax
(cons (caar alist)
(caar (last alist))))
(gnus-agent-set-local group (car minmax) (cdr minmax)
gmane gnus-command-method local))))
minmax))
(defun gnus-agent-set-local (group min max &optional gmane method local)
(let* ((gmane (or gmane (gnus-group-real-name group)))
(gnus-command-method (or method (gnus-find-method-for-group group)))
(local (or local (gnus-agent-load-local)))
(symb (intern gmane local))
(minmax (and (boundp symb) (symbol-value symb))))
(if (cond ((and minmax
(or (not (eq min (car minmax)))
(not (eq max (cdr minmax))))
min
max)
(setcar minmax min)
(setcdr minmax max)
t)
(minmax
nil)
((and min max)
(set symb (cons min max))
t)
(t
(unintern symb local)))
(set (intern "+dirty" local) t))))
(defun gnus-agent-article-name (article group)
(expand-file-name article
(file-name-as-directory
(gnus-agent-group-pathname group))))
(defun gnus-agent-batch-confirmation (msg)
"Show error message and return t."
(gnus-message 1 msg)
t)
(defun gnus-agent-batch-fetch ()
"Start Gnus and fetch session."
(interactive)
(gnus)
(let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
(gnus-agent-fetch-session))
(gnus-group-exit))
(defun gnus-agent-fetch-session ()
"Fetch all articles and headers that are eligible for fetching."
(interactive)
(unless gnus-agent-covered-methods
(error "No servers are covered by the Gnus agent"))
(unless gnus-plugged
(error "Can't fetch articles while Gnus is unplugged"))
(let ((methods (gnus-agent-covered-methods))
groups group gnus-command-method)
(save-excursion
(while methods
(setq gnus-command-method (car methods))
(when (and (or (gnus-server-opened gnus-command-method)
(gnus-open-server gnus-command-method))
(gnus-online gnus-command-method))
(setq groups (gnus-groups-from-server (car methods)))
(gnus-agent-with-fetch
(while (setq group (pop groups))
(when (<= (gnus-group-level group)
gnus-agent-handle-level)
(if (or debug-on-error debug-on-quit)
(gnus-agent-fetch-group-1
group gnus-command-method)
(condition-case err
(gnus-agent-fetch-group-1
group gnus-command-method)
(error
(unless (funcall gnus-agent-confirmation-function
(format "Error %s while fetching session. Should gnus continue? "
(error-message-string err)))
(error "Cannot fetch articles into the Gnus agent")))
(quit
(gnus-agent-regenerate-group group)
(unless (funcall gnus-agent-confirmation-function
(format
"%s while fetching session. Should gnus continue? "
(error-message-string err)))
(signal 'quit
"Cannot fetch articles into the Gnus agent")))))))))
(setq methods (cdr methods)))
(gnus-run-hooks 'gnus-agent-fetched-hook)
(gnus-message 6 "Finished fetching articles into the Gnus agent"))))
(defun gnus-agent-fetch-group-1 (group method)
"Fetch GROUP."
(let ((gnus-command-method method)
(gnus-newsgroup-name group)
(gnus-newsgroup-dependencies gnus-newsgroup-dependencies)
(gnus-newsgroup-headers gnus-newsgroup-headers)
(gnus-newsgroup-scored gnus-newsgroup-scored)
(gnus-use-cache gnus-use-cache)
(gnus-summary-expunge-below gnus-summary-expunge-below)
(gnus-summary-mark-below gnus-summary-mark-below)
(gnus-orphan-score gnus-orphan-score)
gnus-headers
gnus-score
articles arts
category predicate info marks score-param
)
(unless (gnus-check-group group)
(error "Can't open server for %s" group))
(when (or gnus-newsgroup-active
(gnus-active group)
(gnus-activate-group group))
(let ((marked-articles gnus-newsgroup-downloadable))
(unless gnus-newsgroup-active
(dolist (mark gnus-agent-download-marks)
(let ((arts (cdr (assq mark (gnus-info-marks
(setq info (gnus-get-info group)))))))
(when arts
(setq marked-articles (nconc (gnus-uncompress-range arts)
marked-articles))
))))
(setq marked-articles (sort marked-articles '<))
(setq articles (gnus-agent-fetch-headers group))
(setq articles (sort (append marked-articles articles) '<))
(when articles
(setq gnus-newsgroup-dependencies
(or gnus-newsgroup-dependencies
(make-vector (length articles) 0)))
(setq gnus-newsgroup-headers
(or gnus-newsgroup-headers
(gnus-get-newsgroup-headers-xover articles nil nil
group)))
(gnus-agent-create-buffer)
(setq category (gnus-group-category group))
(setq predicate
(gnus-get-predicate
(gnus-agent-find-parameter group 'agent-predicate)))
(unless (memq predicate '(gnus-agent-true gnus-agent-false))
(let ((score-param
(gnus-agent-find-parameter group 'agent-score-file)))
(cond
((not score-param))
((eq score-param 'file)
(setq score-param (gnus-all-score-files group)))
((stringp (car score-param)))
(t
(setq score-param (list (list score-param)))))
(when score-param
(gnus-score-headers score-param))))
(unless (and (eq predicate 'gnus-agent-false)
(not marked-articles))
(let ((arts (list nil)))
(let ((arts-tail arts)
(alist (gnus-agent-load-alist group))
(marked-articles marked-articles)
(gnus-newsgroup-headers gnus-newsgroup-headers))
(while (setq gnus-headers (pop gnus-newsgroup-headers))
(let ((num (mail-header-number gnus-headers)))
(while (and alist
(> num (caar alist)))
(setq alist (cdr alist)))
(unless (and (eq num (caar alist))
(cdar alist))
(while (and marked-articles
(> num (car marked-articles)))
(setq marked-articles
(cdr marked-articles)))
(when (or (eq num (car marked-articles))
(let ((gnus-score
(or (cdr
(assq num gnus-newsgroup-scored))
gnus-summary-default-score))
(gnus-agent-long-article
(gnus-agent-find-parameter
group 'agent-long-article))
(gnus-agent-short-article
(gnus-agent-find-parameter
group 'agent-short-article))
(gnus-agent-low-score
(gnus-agent-find-parameter
group 'agent-low-score))
(gnus-agent-high-score
(gnus-agent-find-parameter
group 'agent-high-score))
(gnus-agent-expire-days
(gnus-agent-find-parameter
group 'agent-days-until-old)))
(funcall predicate)))
(gnus-agent-append-to-list arts-tail num))))))
(let (fetched-articles)
(setq gnus-newsgroup-undownloaded
(gnus-sorted-ndifference
gnus-newsgroup-undownloaded
(setq fetched-articles
(if (cdr arts)
(gnus-agent-fetch-articles group (cdr arts))
nil))))
(let ((unfetched-articles
(gnus-sorted-ndifference (cdr arts) fetched-articles)))
(if gnus-newsgroup-active
(progn
(dolist (article marked-articles)
(gnus-summary-set-agent-mark article t))
(dolist (article fetched-articles)
(when gnus-agent-mark-unread-after-downloaded
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
(gnus-summary-mark-article
article gnus-unread-mark))
(when (gnus-summary-goto-subject article nil t)
(gnus-summary-update-download-mark article)))
(dolist (article unfetched-articles)
(gnus-summary-mark-article
article gnus-canceled-mark)))
(dolist (mark gnus-agent-download-marks)
(when (eq mark 'download)
(let ((marked-arts
(assq mark (gnus-info-marks
(setq info (gnus-get-info group))))))
(when (cdr marked-arts)
(setq marks
(delq marked-arts (gnus-info-marks info)))
(gnus-info-set-marks info marks)))))
(let ((read (gnus-info-read
(or info (setq info (gnus-get-info group))))))
(gnus-info-set-read
info (gnus-add-to-range read unfetched-articles)))
(gnus-group-update-group group t)
(sit-for 0)
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
(gnus-prin1-to-string info)
")"))))))))))))
(defvar gnus-category-mode-hook nil
"Hook run in `gnus-category-mode' buffers.")
(defvar gnus-category-line-format " %(%20c%): %g\n"
"Format of category lines.
Valid specifiers include:
%c Topic name (string)
%g The number of groups in the topic (integer)
General format specifiers can also be used. See Info node
`(gnus)Formatting Variables'.")
(defvar gnus-category-mode-line-format "Gnus: %%b"
"The format specification for the category mode line.")
(defvar gnus-agent-predicate 'false
"The selection predicate used when no other source is available.")
(defvar gnus-agent-short-article 100
"Articles that have fewer lines than this are short.")
(defvar gnus-agent-long-article 200
"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.")
(defvar gnus-category-buffer "*Agent Category*")
(defvar gnus-category-line-format-alist
`((?c gnus-tmp-name ?s)
(?g gnus-tmp-groups ?d)))
(defvar gnus-category-mode-line-format-alist
`((?u user-defined ?s)))
(defvar gnus-category-line-format-spec nil)
(defvar gnus-category-mode-line-format-spec nil)
(defvar gnus-category-mode-map nil)
(put 'gnus-category-mode 'mode-class 'special)
(unless gnus-category-mode-map
(setq gnus-category-mode-map (make-sparse-keymap))
(suppress-keymap gnus-category-mode-map)
(gnus-define-keys gnus-category-mode-map
"q" gnus-category-exit
"k" gnus-category-kill
"c" gnus-category-copy
"a" gnus-category-add
"e" gnus-agent-customize-category
"p" gnus-category-edit-predicate
"g" gnus-category-edit-groups
"s" gnus-category-edit-score
"l" gnus-category-list
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
(defvar gnus-category-menu-hook nil
"*Hook run after the creation of the menu.")
(defun gnus-category-make-menu-bar ()
(gnus-turn-off-edit-menu 'category)
(unless (boundp 'gnus-category-menu)
(easy-menu-define
gnus-category-menu gnus-category-mode-map ""
'("Categories"
["Add" gnus-category-add t]
["Kill" gnus-category-kill t]
["Copy" gnus-category-copy t]
["Edit category" gnus-agent-customize-category t]
["Edit predicate" gnus-category-edit-predicate t]
["Edit score" gnus-category-edit-score t]
["Edit groups" gnus-category-edit-groups t]
["Exit" gnus-category-exit t]))
(gnus-run-hooks 'gnus-category-menu-hook)))
(defun gnus-category-mode ()
"Major mode for listing and editing agent categories.
All normal editing commands are switched off.
\\<gnus-category-mode-map>
For more in-depth information on this mode, read the manual
\(`\\[gnus-info-find-node]').
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))
(defalias 'gnus-category-position-point 'gnus-goto-colon)
(defun gnus-category-insert-line (category)
(let* ((gnus-tmp-name (format "%s" (car category)))
(gnus-tmp-groups (length (gnus-agent-cat-groups category))))
(beginning-of-line)
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(eval gnus-category-line-format-spec))
(list 'gnus-category gnus-tmp-name))))
(defun gnus-enter-category-buffer ()
"Go to the Category buffer."
(interactive)
(gnus-category-setup-buffer)
(gnus-configure-windows 'category)
(gnus-category-prepare))
(defun gnus-category-setup-buffer ()
(unless (get-buffer gnus-category-buffer)
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-category-buffer))
(gnus-category-mode))))
(defun gnus-category-prepare ()
(gnus-set-format 'category-mode)
(gnus-set-format 'category t)
(let ((alist gnus-category-alist)
(buffer-read-only nil))
(erase-buffer)
(while alist
(gnus-category-insert-line (pop alist)))
(goto-char (point-min))
(gnus-category-position-point)))
(defun gnus-category-name ()
(or (intern (get-text-property (gnus-point-at-bol) 'gnus-category))
(error "No category on the current line")))
(defun gnus-category-read ()
"Read the category alist."
(setq gnus-category-alist
(or
(with-temp-buffer
(ignore-errors
(nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories"))
(goto-char (point-min))
(let* ((old-list (read (current-buffer)))
(new-list (ignore-errors (read (current-buffer)))))
(if new-list
new-list
(mapcar
(lambda (c)
(setcdr c
(delq nil
(gnus-mapcar
(lambda (valu symb)
(if valu
(cons symb valu)))
(cdr c)
'(agent-predicate agent-score-file agent-groups))))
c)
old-list)))))
(list (gnus-agent-cat-make 'default 'short)))))
(defun gnus-category-write ()
"Write the category alist."
(setq gnus-category-predicate-cache nil
gnus-category-group-cache nil)
(gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
(with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
(prin1 (mapcar (lambda (c)
(list (car c)
(cdr (assoc 'agent-predicate c))
(cdr (assoc 'agent-score-file c))
(cdr (assoc 'agent-groups c))))
gnus-category-alist)
(current-buffer))
(newline)
(prin1 gnus-category-alist (current-buffer))))
(defun gnus-category-edit-predicate (category)
"Edit the predicate for CATEGORY."
(interactive (list (gnus-category-name)))
(let ((info (assq category gnus-category-alist)))
(gnus-edit-form
(gnus-agent-cat-predicate info)
(format "Editing the select predicate for category %s" category)
`(lambda (predicate)
(gnus-agent-cat-set-property (assq ',category gnus-category-alist)
'agent-predicate predicate)
(gnus-category-write)
(gnus-category-list)))))
(defun gnus-category-edit-score (category)
"Edit the score expression for CATEGORY."
(interactive (list (gnus-category-name)))
(let ((info (assq category gnus-category-alist)))
(gnus-edit-form
(gnus-agent-cat-score-file info)
(format "Editing the score expression for category %s" category)
`(lambda (score-file)
(gnus-agent-cat-set-property (assq ',category gnus-category-alist)
'agent-score-file score-file)
(gnus-category-write)
(gnus-category-list)))))
(defun gnus-category-edit-groups (category)
"Edit the group list for CATEGORY."
(interactive (list (gnus-category-name)))
(let ((info (assq category gnus-category-alist)))
(gnus-edit-form
(gnus-agent-cat-groups info)
(format "Editing the group list for category %s" category)
`(lambda (groups)
(gnus-agent-set-cat-groups (assq ',category gnus-category-alist)
groups)
(gnus-category-write)
(gnus-category-list)))))
(defun gnus-category-kill (category)
"Kill the current category."
(interactive (list (gnus-category-name)))
(let ((info (assq category gnus-category-alist))
(buffer-read-only nil))
(gnus-delete-line)
(setq gnus-category-alist (delq info gnus-category-alist))
(gnus-category-write)))
(defun gnus-category-copy (category to)
"Copy the current category."
(interactive (list (gnus-category-name) (intern (read-string "New name: "))))
(let ((info (assq category gnus-category-alist)))
(push (let ((newcat (gnus-copy-sequence info)))
(setf (gnus-agent-cat-name newcat) to)
(setf (gnus-agent-cat-groups newcat) nil)
newcat)
gnus-category-alist)
(gnus-category-write)
(gnus-category-list)))
(defun gnus-category-add (category)
"Create a new category."
(interactive "SCategory name: ")
(when (assq category gnus-category-alist)
(error "Category %s already exists" category))
(push (gnus-agent-cat-make category)
gnus-category-alist)
(gnus-category-write)
(gnus-category-list))
(defun gnus-category-list ()
"List all categories."
(interactive)
(gnus-category-prepare))
(defun gnus-category-exit ()
"Return to the group buffer."
(interactive)
(kill-buffer (current-buffer))
(gnus-configure-windows 'group t))
(defvar gnus-category-not (list '! 'not (intern (format "%c" 172))))
(defvar gnus-category-predicate-alist
'((spam . gnus-agent-spam-p)
(short . gnus-agent-short-p)
(long . gnus-agent-long-p)
(low . gnus-agent-low-scored-p)
(high . gnus-agent-high-scored-p)
(read . gnus-agent-read-p)
(true . gnus-agent-true)
(false . gnus-agent-false))
"Mapping from short score predicate symbols to predicate functions.")
(defun gnus-agent-spam-p ()
"Say whether an article is spam or not."
(unless gnus-agent-spam-hashtb
(setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000)))
(if (not (equal (mail-header-references gnus-headers) ""))
nil
(let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
(prog1
(gnus-gethash string gnus-agent-spam-hashtb)
(gnus-sethash string t gnus-agent-spam-hashtb)))))
(defun gnus-agent-short-p ()
"Say whether an article is short or not."
(< (mail-header-lines gnus-headers) gnus-agent-short-article))
(defun gnus-agent-long-p ()
"Say whether an article is long or not."
(> (mail-header-lines gnus-headers) gnus-agent-long-article))
(defun gnus-agent-low-scored-p ()
"Say whether an article has a low score or not."
(< gnus-score gnus-agent-low-score))
(defun gnus-agent-high-scored-p ()
"Say whether an article has a high score or not."
(> gnus-score gnus-agent-high-score))
(defun gnus-agent-read-p ()
"Say whether an article is read or not."
(gnus-member-of-range (mail-header-number gnus-headers)
(gnus-info-read (gnus-get-info gnus-newsgroup-name))))
(defun gnus-category-make-function (predicate)
"Make a function from PREDICATE."
(let ((func (gnus-category-make-function-1 predicate)))
(if (and (= (length func) 1)
(symbolp (car func)))
(car func)
(gnus-byte-compile `(lambda () ,func)))))
(defun gnus-agent-true ()
"Return t."
t)
(defun gnus-agent-false ()
"Return nil."
nil)
(defun gnus-category-make-function-1 (predicate)
"Make a function from PREDICATE."
(cond
((or (symbolp predicate)
(functionp predicate))
`(,(or (cdr (assq predicate gnus-category-predicate-alist))
predicate)))
((consp predicate)
`(,(cond
((memq (car predicate) '(& and))
'and)
((memq (car predicate) '(| or))
'or)
((memq (car predicate) gnus-category-not)
'not))
,@(mapcar 'gnus-category-make-function-1 (cdr predicate))))
(t
(error "Unknown predicate type: %s" predicate))))
(defun gnus-get-predicate (predicate)
"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))))
func)))
(defun gnus-predicate-implies-unread (predicate)
"Say whether PREDICATE implies unread articles only.
It is okay to miss some cases, but there must be no false positives.
That is, if this predicate returns true, then indeed the predicate must
return only unread articles."
(eq t (gnus-function-implies-unread-1
(gnus-category-make-function-1 predicate))))
(defun gnus-function-implies-unread-1 (function)
"Recursively evaluate a predicate function to determine whether it can select
any read articles. Returns t if the function is known to never
return read articles, nil when it is known to always return read
articles, and t_nil when the function may return both read and unread
articles."
(let ((func (car function))
(args (mapcar 'gnus-function-implies-unread-1 (cdr function))))
(cond ((eq func 'and)
(cond ((memq t args) t)
((memq 't_nil args) 't_nil)))
((eq func 'or)
(cond ((memq nil args) nil)
((memq 't_nil args) 't_nil)
(t t)))
((eq func 'not)
(cond ((eq (car args) 't_nil) (car args))
(t (not (car args)))))
((eq func 'gnus-agent-read-p)
nil) ((eq func 'gnus-agent-false)
t) ((eq func 'gnus-agent-true)
nil) ((catch 'found-match
(let ((alist gnus-category-predicate-alist))
(while alist
(if (eq func (cdar alist))
(throw 'found-match t)
(setq alist (cdr alist))))))
't_nil) (t
(error "Unknown predicate function: %s" function)))))
(defun gnus-group-category (group)
"Return the category GROUP belongs to."
(unless gnus-category-group-cache
(setq gnus-category-group-cache (gnus-make-hashtable 1000))
(let ((cs gnus-category-alist)
groups cat)
(while (setq cat (pop cs))
(setq groups (gnus-agent-cat-groups cat))
(while groups
(gnus-sethash (pop groups) cat gnus-category-group-cache)))))
(or (gnus-gethash group gnus-category-group-cache)
(assq 'default gnus-category-alist)))
(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
take ARTICLES, and FORCE parameters as well.
The articles on which the expiration process runs are selected as follows:
if ARTICLES is null, all read and unmarked articles.
if ARTICLES is t, all articles.
if ARTICLES is a list, just those articles.
FORCE is equivalent to setting the expiration predicates to true."
(interactive
(list (let ((def (or (gnus-group-group-name)
gnus-newsgroup-name)))
(let ((select (read-string (if def
(concat "Group Name ("
def "): ")
"Group Name: "))))
(if (and (equal "" select)
def)
def
select)))))
(if (not group)
(gnus-agent-expire articles group force)
(let ( (gnus-agent-expire-stats (list 0 0 0.0)))
(if (or (not (eq articles t))
(yes-or-no-p
(concat "Are you sure that you want to "
"expire all articles in " group "? ")))
(let ((gnus-command-method (gnus-find-method-for-group group))
(overview (gnus-get-buffer-create " *expire overview*"))
orig)
(unwind-protect
(let ((active-file (gnus-agent-lib-file "active")))
(when (file-exists-p active-file)
(with-temp-buffer
(nnheader-insert-file-contents active-file)
(gnus-active-to-gnus-format
gnus-command-method
(setq orig (gnus-make-hashtable
(count-lines (point-min) (point-max))))))
(save-excursion
(gnus-agent-expire-group-1
group overview (gnus-gethash-safe group orig)
articles force))))
(kill-buffer overview))))
(gnus-message 4 (gnus-agent-expire-done-message)))))
(defun gnus-agent-expire-group-1 (group overview active articles force)
(let ((dir (gnus-agent-group-pathname group)))
(when (boundp 'gnus-agent-expire-current-dirs)
(set 'gnus-agent-expire-current-dirs
(cons dir
(symbol-value 'gnus-agent-expire-current-dirs))))
(if (and (not force)
(eq 'DISABLE (gnus-agent-find-parameter group
'agent-enable-expiration)))
(gnus-message 5 "Expiry skipping over %s" group)
(gnus-message 5 "Expiring articles in %s" group)
(gnus-agent-load-alist group)
(let* ((bytes-freed 0)
(files-deleted 0)
(nov-entries-deleted 0)
(info (gnus-get-info group))
(alist gnus-agent-article-alist)
(day (- (time-to-days (current-time))
(gnus-agent-find-parameter group 'agent-days-until-old)))
(specials (if (and alist
(not force))
(list (caar (last alist)))))
(unreads (cond (gnus-agent-expire-all
nil)
((eq articles t)
nil)
((not articles)
(ignore-errors
(gnus-agent-unread-articles group)))
(t
(gnus-sorted-difference
(gnus-uncompress-range
(cons (caar alist)
(caar (last alist))))
(sort articles '<)))))
(marked (cond (gnus-agent-expire-all
nil)
((eq articles t)
nil)
(articles
nil)
(t
(nconc
(gnus-uncompress-range
(cdr (assq 'tick (gnus-info-marks info))))
(gnus-uncompress-range
(cdr (assq 'dormant
(gnus-info-marks info))))))))
(nov-file (concat dir ".overview"))
(cnt 0)
(completed -1)
dlist
type)
(setq dlist (mapcar (lambda (e)
(list (car e) (cdr e) nil nil)) alist))
(setq dlist (nconc dlist
(mapcar (lambda (e)
(list e nil 'unread nil))
unreads)))
(setq dlist (nconc dlist
(mapcar (lambda (e)
(list e nil 'marked nil))
marked)))
(setq dlist (nconc dlist
(mapcar (lambda (e)
(list e nil 'special nil))
specials)))
(set-buffer overview)
(erase-buffer)
(buffer-disable-undo)
(when (file-exists-p nov-file)
(gnus-message 7 "gnus-agent-expire: Loading overview...")
(nnheader-insert-file-contents nov-file)
(goto-char (point-min))
(let (p)
(while (< (setq p (point)) (point-max))
(condition-case nil
(push (list (+ 0 (read (current-buffer))) nil nil
(set-marker (make-marker) p))
dlist)
(error
(gnus-message 1 "gnus-agent-expire: read error \
occurred when reading expression at %s in %s. Skipping to next \
line." (point) nov-file)))
(forward-line 1)))
(gnus-message
7 "gnus-agent-expire: Loading overview... Done"))
(set-buffer-modified-p nil)
(gnus-message 7 "gnus-agent-expire: Sorting entries... ")
(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))))))))
(gnus-message 7 "gnus-agent-expire: Sorting entries... Done")
(gnus-message 7 "gnus-agent-expire: Merging entries... ")
(let ((dlist dlist))
(while (cdr dlist) (if (eq (caar dlist) (caadr dlist))
(let ((first (cdr (car dlist)))
(secnd (cdr (cadr dlist))))
(setcar first (or (car first)
(car secnd))) (setq first (cdr first)
secnd (cdr secnd))
(setcar first (or (car first)
(car secnd))) (setq first (cdr first)
secnd (cdr secnd))
(setcar first (or (car first)
(car secnd)))
(setcdr dlist (cddr dlist)))
(setq dlist (cdr dlist)))))
(gnus-message 7 "gnus-agent-expire: Merging entries... Done")
(let* ((len (float (length dlist)))
(alist (list nil))
(tail-alist alist))
(while dlist
(let ((new-completed (truncate (* 100.0
(/ (setq cnt (1+ cnt))
len))))
message-log-max)
(when (> new-completed completed)
(setq completed new-completed)
(gnus-message 7 "%3d%% completed..." completed)))
(let* ((entry (car dlist))
(article-number (nth 0 entry))
(fetch-date (nth 1 entry))
(keep (nth 2 entry))
(marker (nth 3 entry)))
(cond
(keep
(gnus-agent-message 10
"gnus-agent-expire: %s:%d: Kept %s article%s."
group article-number keep (if fetch-date " and file" ""))
(when fetch-date
(unless (file-exists-p
(concat dir (number-to-string
article-number)))
(setf (nth 1 entry) nil)
(gnus-agent-message 3 "gnus-agent-expire cleared \
download flag on %s:%d as the cached article file is missing."
group (caar dlist)))
(unless marker
(gnus-message 1 "gnus-agent-expire detected a \
missing NOV entry. Run gnus-agent-regenerate-group to restore it.")))
(gnus-agent-append-to-list
tail-alist
(cons article-number fetch-date)))
((setq type
(cond
((not (integerp fetch-date))
'read) ((not (file-exists-p
(concat dir (number-to-string
article-number))))
(setf (nth 1 entry) nil)
'externally-expired)
((< fetch-date day)
'expired)
(force
'forced)))
(let ((actions nil))
(when (memq type '(forced expired))
(ignore-errors (let* ((file-name (nnheader-concat dir (number-to-string
article-number)))
(size (float (nth 7 (file-attributes file-name)))))
(incf bytes-freed size)
(incf files-deleted)
(delete-file file-name))
(push "expired cached article" actions))
(setf (nth 1 entry) nil)
)
(when marker
(push "NOV entry removed" actions)
(goto-char marker)
(incf nov-entries-deleted)
(let ((from (gnus-point-at-bol))
(to (progn (forward-line 1) (point))))
(incf bytes-freed (- to from))
(delete-region from to)))
(if (and gnus-agent-consider-all-articles
(>= article-number (car active)))
(gnus-agent-append-to-list
tail-alist (cons article-number fetch-date))
(push (format "Removed %s article number from \
article alist" type) actions))
(when actions
(gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s"
group article-number
(mapconcat 'identity actions ", ")))))
(t
(gnus-agent-message
10 "gnus-agent-expire: %s:%d: Article kept as \
expiration tests failed." group article-number)
(gnus-agent-append-to-list
tail-alist (cons article-number fetch-date)))
)
(when marker
(set-marker marker nil))
(setq dlist (cdr dlist))))
(setq alist (cdr alist))
(let ((inhibit-quit t))
(unless (equal alist gnus-agent-article-alist)
(setq gnus-agent-article-alist alist)
(gnus-agent-save-alist group))
(when (buffer-modified-p)
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(gnus-make-directory dir)
(write-region (point-min) (point-max) nov-file nil
'silent)
(set-buffer-modified-p nil)))
(when (eq articles t)
(gnus-summary-update-info))))
(when (boundp 'gnus-agent-expire-stats)
(let ((stats (symbol-value '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 (&optional articles group force)
"Expire all old articles.
If you want to force expiring of certain articles, this function can
take ARTICLES, GROUP and FORCE parameters as well.
The articles on which the expiration process runs are selected as follows:
if ARTICLES is null, all read and unmarked articles.
if ARTICLES is t, all articles.
if ARTICLES is a list, just those articles.
Setting GROUP will limit expiration to that group.
FORCE is equivalent to setting the expiration predicates to true."
(interactive)
(if group
(gnus-agent-expire-group group articles force)
(if (or (not (eq articles t))
(yes-or-no-p "Are you sure that you want to expire all \
articles in every agentized group? "))
(let ((methods (gnus-agent-covered-methods))
(gnus-agent-expire-current-dirs nil)
(gnus-agent-expire-stats (list 0 0 0.0))
gnus-command-method overview orig)
(setq overview (gnus-get-buffer-create " *expire overview*"))
(unwind-protect
(while (setq gnus-command-method (pop methods))
(let ((active-file (gnus-agent-lib-file "active")))
(when (file-exists-p active-file)
(with-temp-buffer
(nnheader-insert-file-contents active-file)
(gnus-active-to-gnus-format
gnus-command-method
(setq orig (gnus-make-hashtable
(count-lines (point-min) (point-max))))))
(dolist (expiring-group (gnus-groups-from-server
gnus-command-method))
(let* ((active
(gnus-gethash-safe expiring-group orig)))
(when active
(save-excursion
(gnus-agent-expire-group-1
expiring-group overview active articles force))))))))
(kill-buffer overview))
(gnus-agent-expire-unagentized-dirs)
(gnus-message 4 (gnus-agent-expire-done-message))))))
(defun gnus-agent-expire-done-message ()
(if (and (> gnus-verbose 4)
(boundp 'gnus-agent-expire-stats))
(let* ((stats (symbol-value 'gnus-agent-expire-stats))
(size (nth 2 stats))
(units '(B KB MB GB)))
(while (and (> size 1024.0)
(cdr units))
(setq size (/ size 1024.0)
units (cdr units)))
(format "Expiry recovered %d NOV entries, deleted %d files,\
and freed %f %s."
(nth 0 stats)
(nth 1 stats)
size (car units)))
"Expiry...done"))
(defun gnus-agent-expire-unagentized-dirs ()
(when (and gnus-agent-expire-unagentized-dirs
(boundp 'gnus-agent-expire-current-dirs))
(let* ((keep (gnus-make-hashtable))
(gnus-agent-expire-current-dirs
(symbol-value 'gnus-agent-expire-current-dirs))
dir)
(gnus-sethash gnus-agent-directory t keep)
(while gnus-agent-expire-current-dirs
(setq dir (pop gnus-agent-expire-current-dirs))
(when (and (stringp dir)
(file-directory-p dir))
(while (not (gnus-gethash dir keep))
(gnus-sethash dir t keep)
(setq dir (file-name-directory (directory-file-name dir))))))
(let* (to-remove
checker
(checker
(function
(lambda (d)
"Given a directory, check it and its subdirectories for
membership in the keep hash. If it isn't found, add
it to to-remove."
(let ((files (directory-files d))
file)
(while (setq file (pop files))
(cond ((equal file ".") nil)
((equal file "..") nil)
((equal file ".overview")
(let ((d (file-name-as-directory d))
r)
(while (not (gnus-gethash
(setq d (file-name-directory d)) keep))
(setq r d
d (directory-file-name d)))
(if (and r
(not (member r to-remove)))
(push r to-remove))))
((file-directory-p (setq file (nnheader-concat d file)))
(funcall checker file)))))))))
(funcall checker (expand-file-name gnus-agent-directory))
(when (and to-remove
(or gnus-expert-user
(gnus-y-or-n-p
"gnus-agent-expire has identified local directories that are\
not currently required by any agentized group. Do you wish to consider\
deleting them?")))
(while to-remove
(let ((dir (pop to-remove)))
(if (gnus-y-or-n-p (format "Delete %s? " dir))
(let* (delete-recursive
(delete-recursive
(function
(lambda (f-or-d)
(ignore-errors
(if (file-directory-p f-or-d)
(condition-case nil
(delete-directory f-or-d)
(file-error
(mapcar (lambda (f)
(or (member f '("." ".."))
(funcall delete-recursive
(nnheader-concat
f-or-d f))))
(directory-files f-or-d))
(delete-directory f-or-d)))
(delete-file f-or-d)))))))
(funcall delete-recursive dir))))))))))
(defun gnus-agent-batch ()
"Start Gnus, send queue and fetch session."
(interactive)
(let ((init-file-user "")
(gnus-always-read-dribble-file t))
(gnus))
(let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
(gnus-group-send-queue)
(gnus-agent-fetch-session)))
(defun gnus-agent-unread-articles (group)
(let* ((read (gnus-info-read (gnus-get-info group)))
(known (gnus-agent-load-alist group))
(unread (list nil))
(tail-unread unread))
(while (and known read)
(let ((candidate (car (pop known))))
(while (let* ((range (car read))
(min (if (numberp range) range (car range)))
(max (if (numberp range) range (cdr range))))
(cond ((or (not min)
(< candidate min))
(gnus-agent-append-to-list tail-unread candidate)
nil)
((> candidate max)
(setq read (cdr read))
t))))))
(while known
(gnus-agent-append-to-list tail-unread (car (pop known))))
(cdr unread)))
(defun gnus-agent-uncached-articles (articles group &optional cached-header)
"Restrict ARTICLES to numbers already fetched.
Returns a sublist of ARTICLES that excludes those article ids in GROUP
that have already been fetched.
If CACHED-HEADER is nil, articles are only excluded if the article itself
has been fetched."
(if (and (or gnus-agent-cache (not gnus-plugged))
(gnus-agent-load-alist group))
(let* ((ref gnus-agent-article-alist)
(arts articles)
(uncached (list nil))
(tail-uncached uncached))
(while (and ref arts)
(let ((v1 (car arts))
(v2 (caar ref)))
(cond ((< v1 v2) (gnus-agent-append-to-list tail-uncached v1)
(setq arts (cdr arts)))
((= v1 v2)
(unless (or cached-header (cdar ref)) (gnus-agent-append-to-list tail-uncached v1))
(setq arts (cdr arts))
(setq ref (cdr ref)))
(t (setq ref (cdr ref))))))
(while arts
(gnus-agent-append-to-list tail-uncached (pop arts)))
(cdr uncached))
articles))
(defun gnus-agent-retrieve-headers (articles group &optional fetch-old)
(save-excursion
(gnus-agent-create-buffer)
(let ((gnus-decode-encoded-word-function 'identity)
(file (gnus-agent-article-name ".overview" group))
cached-articles uncached-articles)
(gnus-make-directory (nnheader-translate-file-chars
(file-name-directory file) t))
(when (file-exists-p file)
(with-current-buffer gnus-agent-overview-buffer
(erase-buffer)
(let ((nnheader-file-coding-system
gnus-agent-file-coding-system))
(nnheader-insert-nov-file file (car articles)))))
(if (setq uncached-articles (gnus-agent-uncached-articles articles group
t))
(progn
(set-buffer nntp-server-buffer)
(erase-buffer)
(cond ((not (eq 'nov (let (gnus-agent) (gnus-retrieve-headers
uncached-articles group fetch-old))))
(nnvirtual-convert-headers))
((eq 'nntp (car gnus-current-select-method))
(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))))
(max (car (last articles))))
(goto-char (point-min))
(let ((pm (point-max))
art)
(while (< (point) pm)
(when (setq art (gnus-agent-read-article-number))
(gnus-agent-append-to-list tail-fetched-articles art))
(forward-line 1)))
(setq fetched-articles (gnus-list-range-intersection
(cdr fetched-articles)
(cons min max)))
(if (car tail-fetched-articles)
(setq uncached-articles
(gnus-list-range-intersection
uncached-articles
(cons (car uncached-articles)
(car tail-fetched-articles)))))
(setq uncached-articles
(gnus-sorted-nunion fetched-articles
uncached-articles))
)))
(set-buffer gnus-agent-overview-buffer)
(erase-buffer)
(set-buffer nntp-server-buffer)
(copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
(when uncached-articles
(gnus-agent-braid-nov group uncached-articles file))
(set-buffer nntp-server-buffer)
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(gnus-agent-check-overview-buffer)
(write-region (point-min) (point-max) file nil 'silent))
(gnus-agent-load-alist group)
(gnus-agent-save-alist group uncached-articles nil)
)
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring gnus-agent-overview-buffer)))
(if (and fetch-old
(not (numberp fetch-old)))
t (nnheader-nov-delete-outside-range
(if fetch-old (max 1 (- (car articles) fetch-old))
(car articles))
(car (last articles)))
t)
'nov))
(defun gnus-agent-request-article (article group)
"Retrieve ARTICLE in GROUP from the agent cache."
(when (and gnus-agent
(or gnus-agent-cache
(not gnus-plugged))
(numberp article))
(let* ((gnus-command-method (gnus-find-method-for-group group))
(file (gnus-agent-article-name (number-to-string article) group))
(buffer-read-only nil))
(when (and (file-exists-p file)
(> (nth 7 (file-attributes file)) 0))
(erase-buffer)
(gnus-kill-all-overlays)
(let ((coding-system-for-read gnus-cache-coding-system))
(insert-file-contents file))
t))))
(defun gnus-agent-regenerate-group (group &optional reread)
"Regenerate GROUP.
If REREAD is t, all articles in the .overview are marked as unread.
If REREAD is a list, the specified articles will be marked as unread.
In addition, their NOV entries in .overview will be refreshed using
the articles' current headers.
If REREAD is not nil, downloaded articles are marked as unread."
(interactive
(list (let ((def (or (gnus-group-group-name)
gnus-newsgroup-name)))
(let ((select (read-string (if def
(concat "Group Name ("
def "): ")
"Group Name: "))))
(if (and (equal "" select)
def)
def
select)))
(catch 'mark
(while (let (c
(cursor-in-echo-area t)
(echo-keystrokes 0))
(message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ")
(setq c (read-char-exclusive))
(cond ((or (eq c ?\r) (eq c ?n) (eq c ?N))
(throw 'mark nil))
((or (eq c ?a) (eq c ?A))
(throw 'mark t))
((or (eq c ?d) (eq c ?D))
(throw 'mark 'some)))
(gnus-message 3 "Ignoring unexpected input")
(sit-for 1)
t)))))
(when group
(gnus-message 5 "Regenerating in %s" group)
(let* ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group)))
(file (gnus-agent-article-name ".overview" group))
(dir (file-name-directory file))
point
(downloaded (if (file-exists-p dir)
(sort (delq nil (mapcar (lambda (name)
(and (not (file-directory-p (nnheader-concat dir name)))
(string-to-number name)))
(directory-files dir nil "^[0-9]+$" t)))
'>)
(progn (gnus-make-directory dir) nil)))
dl nov-arts
alist header
regenerated)
(mm-with-unibyte-buffer
(if (file-exists-p file)
(let ((nnheader-file-coding-system
gnus-agent-file-coding-system))
(nnheader-insert-file-contents file)))
(set-buffer-modified-p nil)
(let ((load t))
(while load
(setq load nil)
(goto-char (point-min))
(while (< (point) (point-max))
(cond ((and (looking-at "[0-9]+\t")
(<= (- (match-end 0) (match-beginning 0)) 9))
(push (read (current-buffer)) nov-arts)
(forward-line 1)
(let ((l1 (car nov-arts))
(l2 (cadr nov-arts)))
(cond ((and (listp reread) (memq l1 reread))
(gnus-delete-line)
(setq nov-arts (cdr nov-arts))
(gnus-message 4 "gnus-agent-regenerate-group: NOV\
entry of article %s deleted." l1))
((not l2)
nil)
((< l1 l2)
(gnus-message 3 "gnus-agent-regenerate-group: NOV\
entries are NOT in ascending order.")
(setq load t))
((= l1 l2)
(forward-line -1)
(gnus-message 4 "gnus-agent-regenerate-group: NOV\
entries contained duplicate of article %s. Duplicate deleted." l1)
(gnus-delete-line)
(setq nov-arts (cdr nov-arts))))))
(t
(gnus-message 1 "gnus-agent-regenerate-group: NOV\
entries contained line that did not begin with an article number. Deleted\
line.")
(gnus-delete-line))))
(when load
(gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\
entries into ascending order.")
(sort-numeric-fields 1 (point-min) (point-max))
(setq nov-arts nil))))
(gnus-agent-check-overview-buffer)
(while (or downloaded nov-arts)
(cond ((and downloaded
(or (not nov-arts)
(> (car downloaded) (car nov-arts))))
(gnus-message 3 "Regenerating NOV %s %d..." group
(car downloaded))
(let ((file (concat dir (number-to-string (car downloaded)))))
(mm-with-unibyte-buffer
(nnheader-insert-file-contents file)
(nnheader-remove-body)
(setq header (nnheader-parse-naked-head)))
(mail-header-set-number header (car downloaded))
(if nov-arts
(let ((key (concat "^" (int-to-string (car nov-arts))
"\t")))
(or (re-search-backward key nil t)
(re-search-forward key))
(forward-line 1))
(goto-char (point-min)))
(nnheader-insert-nov header))
(setq nov-arts (cons (car downloaded) nov-arts)))
((eq (car downloaded) (car nov-arts))
(push (cons (car downloaded)
(time-to-days
(nth 5 (file-attributes
(concat dir (number-to-string
(car downloaded))))))) alist)
(setq downloaded (cdr downloaded))
(setq nov-arts (cdr nov-arts)))
(t
(push (cons (car nov-arts) nil) alist)
(setq nov-arts (cdr nov-arts)))))
(if gnus-agent-consider-all-articles
(let* ((n (cons nil alist))
(merged n)
(o (gnus-agent-load-alist group)))
(while o
(let ((nID (caadr n))
(oID (caar o)))
(cond ((not nID)
(setq n (setcdr n (list (list oID))))
(setq o (cdr o)))
((< oID nID)
(setcdr n (cons (list oID) (cdr n)))
(setq o (cdr o)))
((= oID nID)
(setq o (cdr o))
(setq n (cdr n)))
(t
(setq n (cdr n))))))
(setq alist (cdr merged)))
(let ((n (last alist))
(o (last (gnus-agent-load-alist group))))
(cond ((not o)
nil)
((not n)
(push (cons (caar o) nil) alist))
((< (caar n) (caar o))
(setcdr n (list (car o)))))))
(let ((inhibit-quit t))
(if (setq regenerated (buffer-modified-p))
(let ((coding-system-for-write gnus-agent-file-coding-system))
(write-region (point-min) (point-max) file nil 'silent)))
(setq regenerated (or regenerated
(and reread gnus-agent-article-alist)
(not (equal alist gnus-agent-article-alist))))
(setq gnus-agent-article-alist alist)
(when regenerated
(gnus-agent-save-alist group)
(let ((group (gnus-group-real-name group))
(group-active (or (gnus-active group)
(gnus-activate-group group))))
(gnus-agent-possibly-alter-active group group-active)))))
(when (and reread gnus-agent-article-alist)
(gnus-agent-synchronize-group-flags
group
(list (list
(if (listp reread)
reread
(delq nil (mapcar (function (lambda (c)
(cond ((eq reread t)
(car c))
((cdr c)
(car c)))))
gnus-agent-article-alist)))
'del '(read)))
gnus-command-method)
(when (gnus-buffer-live-p gnus-group-buffer)
(gnus-group-update-group group t)))
(gnus-message 5 "")
regenerated)))
(defun gnus-agent-regenerate (&optional clean reread)
"Regenerate all agent covered files.
If CLEAN, obsolete (ignore)."
(interactive "P")
(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))))
(gnus-message 4 "Regenerating Gnus agent files...done")
regenerated))
(defun gnus-agent-go-online (&optional force)
"Switch servers into online status."
(interactive (list t))
(dolist (server gnus-opened-servers)
(when (eq (nth 1 server) 'offline)
(if (if (eq force 'ask)
(gnus-y-or-n-p
(format "Switch %s:%s into online status? "
(caar server) (cadar server)))
force)
(setcar (nthcdr 1 server) 'close)))))
(defun gnus-agent-toggle-group-plugged (group)
"Toggle the status of the server of the current group."
(interactive (list (gnus-group-group-name)))
(let* ((method (gnus-find-method-for-group group))
(status (cadr (assoc method gnus-opened-servers))))
(if (eq status 'offline)
(gnus-server-set-status method 'closed)
(gnus-close-server method)
(gnus-server-set-status method 'offline))
(message "Turn %s:%s from %s to %s." (car method) (cadr method)
(if (eq status 'offline) 'offline 'online)
(if (eq status 'offline) 'online 'offline))))
(defun gnus-agent-group-covered-p (group)
(gnus-agent-method-p (gnus-group-method group)))
(provide 'gnus-agent)