|
24358
|
1 ;;; gnus-agent.el --- unplugged support for Gnus
|
|
|
2 ;; Copyright (C) 1997,98 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
|
|
5 ;; This file is part of GNU Emacs.
|
|
|
6
|
|
|
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
8 ;; it under the terms of the GNU General Public License as published by
|
|
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
10 ;; any later version.
|
|
|
11
|
|
|
12 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
15 ;; GNU General Public License for more details.
|
|
|
16
|
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
|
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
20 ;; Boston, MA 02111-1307, USA.
|
|
|
21
|
|
|
22 ;;; Commentary:
|
|
|
23
|
|
|
24 ;;; Code:
|
|
|
25
|
|
|
26 (require 'gnus)
|
|
|
27 (require 'gnus-cache)
|
|
|
28 (require 'nnvirtual)
|
|
|
29 (require 'gnus-sum)
|
|
|
30 (eval-when-compile (require 'cl))
|
|
|
31
|
|
|
32 (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
|
|
|
33 "Where the Gnus agent will store its files."
|
|
|
34 :group 'gnus-agent
|
|
|
35 :type 'directory)
|
|
|
36
|
|
|
37 (defcustom gnus-agent-plugged-hook nil
|
|
|
38 "Hook run when plugging into the network."
|
|
|
39 :group 'gnus-agent
|
|
|
40 :type 'hook)
|
|
|
41
|
|
|
42 (defcustom gnus-agent-unplugged-hook nil
|
|
|
43 "Hook run when unplugging from the network."
|
|
|
44 :group 'gnus-agent
|
|
|
45 :type 'hook)
|
|
|
46
|
|
|
47 (defcustom gnus-agent-handle-level gnus-level-subscribed
|
|
|
48 "Groups on levels higher than this variable will be ignored by the Agent."
|
|
|
49 :group 'gnus-agent
|
|
|
50 :type 'integer)
|
|
|
51
|
|
|
52 (defcustom gnus-agent-expire-days 7
|
|
|
53 "Read articles older than this will be expired."
|
|
|
54 :group 'gnus-agent
|
|
|
55 :type 'integer)
|
|
|
56
|
|
|
57 (defcustom gnus-agent-expire-all nil
|
|
|
58 "If non-nil, also expire unread, ticked and dormant articles.
|
|
|
59 If nil, only read articles will be expired."
|
|
|
60 :group 'gnus-agent
|
|
|
61 :type 'boolean)
|
|
|
62
|
|
|
63 (defcustom gnus-agent-group-mode-hook nil
|
|
|
64 "Hook run in Agent group minor modes."
|
|
|
65 :group 'gnus-agent
|
|
|
66 :type 'hook)
|
|
|
67
|
|
|
68 (defcustom gnus-agent-summary-mode-hook nil
|
|
|
69 "Hook run in Agent summary minor modes."
|
|
|
70 :group 'gnus-agent
|
|
|
71 :type 'hook)
|
|
|
72
|
|
|
73 (defcustom gnus-agent-server-mode-hook nil
|
|
|
74 "Hook run in Agent summary minor modes."
|
|
|
75 :group 'gnus-agent
|
|
|
76 :type 'hook)
|
|
|
77
|
|
|
78 ;;; Internal variables
|
|
|
79
|
|
|
80 (defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information")
|
|
|
81
|
|
|
82 (defvar gnus-agent-history-buffers nil)
|
|
|
83 (defvar gnus-agent-buffer-alist nil)
|
|
|
84 (defvar gnus-agent-article-alist nil)
|
|
|
85 (defvar gnus-agent-group-alist nil)
|
|
|
86 (defvar gnus-agent-covered-methods nil)
|
|
|
87 (defvar gnus-category-alist nil)
|
|
|
88 (defvar gnus-agent-current-history nil)
|
|
|
89 (defvar gnus-agent-overview-buffer nil)
|
|
|
90 (defvar gnus-category-predicate-cache nil)
|
|
|
91 (defvar gnus-category-group-cache nil)
|
|
|
92 (defvar gnus-agent-spam-hashtb nil)
|
|
|
93 (defvar gnus-agent-file-name nil)
|
|
|
94 (defvar gnus-agent-send-mail-function nil)
|
|
|
95 (defvar gnus-agent-file-coding-system 'no-conversion)
|
|
|
96
|
|
|
97 ;; Dynamic variables
|
|
|
98 (defvar gnus-headers)
|
|
|
99 (defvar gnus-score)
|
|
|
100
|
|
|
101 ;;;
|
|
|
102 ;;; Setup
|
|
|
103 ;;;
|
|
|
104
|
|
|
105 (defun gnus-open-agent ()
|
|
|
106 (setq gnus-agent t)
|
|
|
107 (gnus-agent-read-servers)
|
|
|
108 (gnus-category-read)
|
|
|
109 (setq gnus-agent-overview-buffer
|
|
|
110 (gnus-get-buffer-create " *Gnus agent overview*"))
|
|
|
111 (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
|
|
|
112 (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
|
|
|
113 (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
|
|
|
114
|
|
|
115 (gnus-add-shutdown 'gnus-close-agent 'gnus)
|
|
|
116
|
|
|
117 (defun gnus-close-agent ()
|
|
|
118 (setq gnus-agent-covered-methods nil
|
|
|
119 gnus-category-predicate-cache nil
|
|
|
120 gnus-category-group-cache nil
|
|
|
121 gnus-agent-spam-hashtb nil)
|
|
|
122 (gnus-kill-buffer gnus-agent-overview-buffer))
|
|
|
123
|
|
|
124 ;;;
|
|
|
125 ;;; Utility functions
|
|
|
126 ;;;
|
|
|
127
|
|
|
128 (defun gnus-agent-read-file (file)
|
|
|
129 "Load FILE and do a `read' there."
|
|
|
130 (nnheader-temp-write nil
|
|
|
131 (ignore-errors
|
|
|
132 (nnheader-insert-file-contents file)
|
|
|
133 (goto-char (point-min))
|
|
|
134 (read (current-buffer)))))
|
|
|
135
|
|
|
136 (defsubst gnus-agent-method ()
|
|
|
137 (concat (symbol-name (car gnus-command-method)) "/"
|
|
|
138 (if (equal (cadr gnus-command-method) "")
|
|
|
139 "unnamed"
|
|
|
140 (cadr gnus-command-method))))
|
|
|
141
|
|
|
142 (defsubst gnus-agent-directory ()
|
|
|
143 "Path of the Gnus agent directory."
|
|
|
144 (nnheader-concat gnus-agent-directory
|
|
|
145 (nnheader-translate-file-chars (gnus-agent-method)) "/"))
|
|
|
146
|
|
|
147 (defun gnus-agent-lib-file (file)
|
|
|
148 "The full path of the Gnus agent library FILE."
|
|
|
149 (concat (gnus-agent-directory) "agent.lib/" file))
|
|
|
150
|
|
|
151 ;;; Fetching setup functions.
|
|
|
152
|
|
|
153 (defun gnus-agent-start-fetch ()
|
|
|
154 "Initialize data structures for efficient fetching."
|
|
|
155 (gnus-agent-open-history)
|
|
|
156 (setq gnus-agent-current-history (gnus-agent-history-buffer)))
|
|
|
157
|
|
|
158 (defun gnus-agent-stop-fetch ()
|
|
|
159 "Save all data structures and clean up."
|
|
|
160 (gnus-agent-save-history)
|
|
|
161 (gnus-agent-close-history)
|
|
|
162 (setq gnus-agent-spam-hashtb nil)
|
|
|
163 (save-excursion
|
|
|
164 (set-buffer nntp-server-buffer)
|
|
|
165 (widen)))
|
|
|
166
|
|
|
167 (defmacro gnus-agent-with-fetch (&rest forms)
|
|
|
168 "Do FORMS safely."
|
|
|
169 `(unwind-protect
|
|
|
170 (progn
|
|
|
171 (gnus-agent-start-fetch)
|
|
|
172 ,@forms)
|
|
|
173 (gnus-agent-stop-fetch)))
|
|
|
174
|
|
|
175 (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
|
|
|
176 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
|
|
|
177
|
|
|
178 ;;;
|
|
|
179 ;;; Mode infestation
|
|
|
180 ;;;
|
|
|
181
|
|
|
182 (defvar gnus-agent-mode-hook nil
|
|
|
183 "Hook run when installing agent mode.")
|
|
|
184
|
|
|
185 (defvar gnus-agent-mode nil)
|
|
|
186 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
|
|
|
187
|
|
|
188 (defun gnus-agent-mode ()
|
|
|
189 "Minor mode for providing a agent support in Gnus buffers."
|
|
|
190 (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
|
|
|
191 (symbol-name major-mode))
|
|
|
192 (match-string 1 (symbol-name major-mode))))
|
|
|
193 (mode (intern (format "gnus-agent-%s-mode" buffer))))
|
|
|
194 (set (make-local-variable 'gnus-agent-mode) t)
|
|
|
195 (set mode nil)
|
|
|
196 (set (make-local-variable mode) t)
|
|
|
197 ;; Set up the menu.
|
|
|
198 (when (gnus-visual-p 'agent-menu 'menu)
|
|
|
199 (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
|
|
|
200 (unless (assq 'gnus-agent-mode minor-mode-alist)
|
|
|
201 (push gnus-agent-mode-status minor-mode-alist))
|
|
|
202 (unless (assq mode minor-mode-map-alist)
|
|
|
203 (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
|
|
|
204 buffer))))
|
|
|
205 minor-mode-map-alist))
|
|
|
206 (when (eq major-mode 'gnus-group-mode)
|
|
|
207 (gnus-agent-toggle-plugged gnus-plugged))
|
|
|
208 (gnus-run-hooks 'gnus-agent-mode-hook
|
|
|
209 (intern (format "gnus-agent-%s-mode-hook" buffer)))))
|
|
|
210
|
|
|
211 (defvar gnus-agent-group-mode-map (make-sparse-keymap))
|
|
|
212 (gnus-define-keys gnus-agent-group-mode-map
|
|
|
213 "Ju" gnus-agent-fetch-groups
|
|
|
214 "Jc" gnus-enter-category-buffer
|
|
|
215 "Jj" gnus-agent-toggle-plugged
|
|
|
216 "Js" gnus-agent-fetch-session
|
|
|
217 "JS" gnus-group-send-drafts
|
|
|
218 "Ja" gnus-agent-add-group)
|
|
|
219
|
|
|
220 (defun gnus-agent-group-make-menu-bar ()
|
|
|
221 (unless (boundp 'gnus-agent-group-menu)
|
|
|
222 (easy-menu-define
|
|
|
223 gnus-agent-group-menu gnus-agent-group-mode-map ""
|
|
|
224 '("Agent"
|
|
|
225 ["Toggle plugged" gnus-agent-toggle-plugged t]
|
|
|
226 ["List categories" gnus-enter-category-buffer t]
|
|
|
227 ["Send drafts" gnus-group-send-drafts gnus-plugged]
|
|
|
228 ("Fetch"
|
|
|
229 ["All" gnus-agent-fetch-session gnus-plugged]
|
|
|
230 ["Group" gnus-agent-fetch-group gnus-plugged])))))
|
|
|
231
|
|
|
232 (defvar gnus-agent-summary-mode-map (make-sparse-keymap))
|
|
|
233 (gnus-define-keys gnus-agent-summary-mode-map
|
|
|
234 "Jj" gnus-agent-toggle-plugged
|
|
|
235 "J#" gnus-agent-mark-article
|
|
|
236 "J\M-#" gnus-agent-unmark-article
|
|
|
237 "@" gnus-agent-toggle-mark
|
|
|
238 "Jc" gnus-agent-catchup)
|
|
|
239
|
|
|
240 (defun gnus-agent-summary-make-menu-bar ()
|
|
|
241 (unless (boundp 'gnus-agent-summary-menu)
|
|
|
242 (easy-menu-define
|
|
|
243 gnus-agent-summary-menu gnus-agent-summary-mode-map ""
|
|
|
244 '("Agent"
|
|
|
245 ["Toggle plugged" gnus-agent-toggle-plugged t]
|
|
|
246 ["Mark as downloadable" gnus-agent-mark-article t]
|
|
|
247 ["Unmark as downloadable" gnus-agent-unmark-article t]
|
|
|
248 ["Toggle mark" gnus-agent-toggle-mark t]
|
|
|
249 ["Catchup undownloaded" gnus-agent-catchup t]))))
|
|
|
250
|
|
|
251 (defvar gnus-agent-server-mode-map (make-sparse-keymap))
|
|
|
252 (gnus-define-keys gnus-agent-server-mode-map
|
|
|
253 "Jj" gnus-agent-toggle-plugged
|
|
|
254 "Ja" gnus-agent-add-server
|
|
|
255 "Jr" gnus-agent-remove-server)
|
|
|
256
|
|
|
257 (defun gnus-agent-server-make-menu-bar ()
|
|
|
258 (unless (boundp 'gnus-agent-server-menu)
|
|
|
259 (easy-menu-define
|
|
|
260 gnus-agent-server-menu gnus-agent-server-mode-map ""
|
|
|
261 '("Agent"
|
|
|
262 ["Toggle plugged" gnus-agent-toggle-plugged t]
|
|
|
263 ["Add" gnus-agent-add-server t]
|
|
|
264 ["Remove" gnus-agent-remove-server t]))))
|
|
|
265
|
|
|
266 (defun gnus-agent-toggle-plugged (plugged)
|
|
|
267 "Toggle whether Gnus is unplugged or not."
|
|
|
268 (interactive (list (not gnus-plugged)))
|
|
|
269 (if plugged
|
|
|
270 (progn
|
|
|
271 (setq gnus-plugged plugged)
|
|
|
272 (gnus-run-hooks 'gnus-agent-plugged-hook)
|
|
|
273 (setcar (cdr gnus-agent-mode-status) " Plugged"))
|
|
|
274 (gnus-agent-close-connections)
|
|
|
275 (setq gnus-plugged plugged)
|
|
|
276 (gnus-run-hooks 'gnus-agent-unplugged-hook)
|
|
|
277 (setcar (cdr gnus-agent-mode-status) " Unplugged"))
|
|
|
278 (set-buffer-modified-p t))
|
|
|
279
|
|
|
280 (defun gnus-agent-close-connections ()
|
|
|
281 "Close all methods covered by the Gnus agent."
|
|
|
282 (let ((methods gnus-agent-covered-methods))
|
|
|
283 (while methods
|
|
|
284 (gnus-close-server (pop methods)))))
|
|
|
285
|
|
|
286 ;;;###autoload
|
|
|
287 (defun gnus-unplugged ()
|
|
|
288 "Start Gnus unplugged."
|
|
|
289 (interactive)
|
|
|
290 (setq gnus-plugged nil)
|
|
|
291 (gnus))
|
|
|
292
|
|
|
293 ;;;###autoload
|
|
|
294 (defun gnus-plugged ()
|
|
|
295 "Start Gnus plugged."
|
|
|
296 (interactive)
|
|
|
297 (setq gnus-plugged t)
|
|
|
298 (gnus))
|
|
|
299
|
|
|
300 ;;;###autoload
|
|
|
301 (defun gnus-agentize ()
|
|
|
302 "Allow Gnus to be an offline newsreader.
|
|
|
303 The normal usage of this command is to put the following as the
|
|
|
304 last form in your `.gnus.el' file:
|
|
|
305
|
|
|
306 \(gnus-agentize)
|
|
|
307
|
|
|
308 This will modify the `gnus-before-startup-hook', `gnus-post-method',
|
|
|
309 and `message-send-mail-function' variables, and install the Gnus
|
|
|
310 agent minor mode in all Gnus buffers."
|
|
|
311 (interactive)
|
|
|
312 (gnus-open-agent)
|
|
|
313 (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
|
|
|
314 (unless gnus-agent-send-mail-function
|
|
|
315 (setq gnus-agent-send-mail-function message-send-mail-function
|
|
|
316 message-send-mail-function 'gnus-agent-send-mail))
|
|
|
317 (unless gnus-agent-covered-methods
|
|
|
318 (setq gnus-agent-covered-methods (list gnus-select-method))))
|
|
|
319
|
|
|
320 (defun gnus-agent-queue-setup ()
|
|
|
321 "Make sure the queue group exists."
|
|
|
322 (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb)
|
|
|
323 (gnus-request-create-group "queue" '(nndraft ""))
|
|
|
324 (let ((gnus-level-default-subscribed 1))
|
|
|
325 (gnus-subscribe-group "nndraft:queue" nil '(nndraft "")))
|
|
|
326 (gnus-group-set-parameter
|
|
|
327 "nndraft:queue" 'gnus-dummy '((gnus-draft-mode)))))
|
|
|
328
|
|
|
329 (defun gnus-agent-send-mail ()
|
|
|
330 (if gnus-plugged
|
|
|
331 (funcall gnus-agent-send-mail-function)
|
|
|
332 (goto-char (point-min))
|
|
|
333 (re-search-forward
|
|
|
334 (concat "^" (regexp-quote mail-header-separator) "\n"))
|
|
|
335 (replace-match "\n")
|
|
|
336 (gnus-agent-insert-meta-information 'mail)
|
|
|
337 (gnus-request-accept-article "nndraft:queue")))
|
|
|
338
|
|
|
339 (defun gnus-agent-insert-meta-information (type &optional method)
|
|
|
340 "Insert meta-information into the message that says how it's to be posted.
|
|
|
341 TYPE can be either `mail' or `news'. If the latter METHOD can
|
|
|
342 be a select method."
|
|
|
343 (save-excursion
|
|
|
344 (message-remove-header gnus-agent-meta-information-header)
|
|
|
345 (goto-char (point-min))
|
|
|
346 (insert gnus-agent-meta-information-header ": "
|
|
|
347 (symbol-name type) " " (format "%S" method)
|
|
|
348 "\n")
|
|
|
349 (forward-char -1)
|
|
|
350 (while (search-backward "\n" nil t)
|
|
|
351 (replace-match "\\n" t t))))
|
|
|
352
|
|
|
353 ;;;
|
|
|
354 ;;; Group mode commands
|
|
|
355 ;;;
|
|
|
356
|
|
|
357 (defun gnus-agent-fetch-groups (n)
|
|
|
358 "Put all new articles in the current groups into the Agent."
|
|
|
359 (interactive "P")
|
|
|
360 (gnus-group-iterate n 'gnus-agent-fetch-group))
|
|
|
361
|
|
|
362 (defun gnus-agent-fetch-group (group)
|
|
|
363 "Put all new articles in GROUP into the Agent."
|
|
|
364 (interactive (list (gnus-group-group-name)))
|
|
|
365 (unless group
|
|
|
366 (error "No group on the current line"))
|
|
|
367 (let ((gnus-command-method (gnus-find-method-for-group group)))
|
|
|
368 (gnus-agent-with-fetch
|
|
|
369 (gnus-agent-fetch-group-1 group gnus-command-method)
|
|
|
370 (gnus-message 5 "Fetching %s...done" group))))
|
|
|
371
|
|
|
372 (defun gnus-agent-add-group (category arg)
|
|
|
373 "Add the current group to an agent category."
|
|
|
374 (interactive
|
|
|
375 (list
|
|
|
376 (intern
|
|
|
377 (completing-read
|
|
|
378 "Add to category: "
|
|
|
379 (mapcar (lambda (cat) (list (symbol-name (car cat))))
|
|
|
380 gnus-category-alist)
|
|
|
381 nil t))
|
|
|
382 current-prefix-arg))
|
|
|
383 (let ((cat (assq category gnus-category-alist))
|
|
|
384 c groups)
|
|
|
385 (gnus-group-iterate arg
|
|
|
386 (lambda (group)
|
|
|
387 (when (cadddr (setq c (gnus-group-category group)))
|
|
|
388 (setf (cadddr c) (delete group (cadddr c))))
|
|
|
389 (push group groups)))
|
|
|
390 (setf (cadddr cat) (nconc (cadddr cat) groups))
|
|
|
391 (gnus-category-write)))
|
|
|
392
|
|
|
393 ;;;
|
|
|
394 ;;; Server mode commands
|
|
|
395 ;;;
|
|
|
396
|
|
|
397 (defun gnus-agent-add-server (server)
|
|
|
398 "Enroll SERVER in the agent program."
|
|
|
399 (interactive (list (gnus-server-server-name)))
|
|
|
400 (unless server
|
|
|
401 (error "No server on the current line"))
|
|
|
402 (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
|
|
|
403 (when (member method gnus-agent-covered-methods)
|
|
|
404 (error "Server already in the agent program"))
|
|
|
405 (push method gnus-agent-covered-methods)
|
|
|
406 (gnus-agent-write-servers)
|
|
|
407 (message "Entered %s into the Agent" server)))
|
|
|
408
|
|
|
409 (defun gnus-agent-remove-server (server)
|
|
|
410 "Remove SERVER from the agent program."
|
|
|
411 (interactive (list (gnus-server-server-name)))
|
|
|
412 (unless server
|
|
|
413 (error "No server on the current line"))
|
|
|
414 (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
|
|
|
415 (unless (member method gnus-agent-covered-methods)
|
|
|
416 (error "Server not in the agent program"))
|
|
|
417 (setq gnus-agent-covered-methods
|
|
|
418 (delete method gnus-agent-covered-methods))
|
|
|
419 (gnus-agent-write-servers)
|
|
|
420 (message "Removed %s from the agent" server)))
|
|
|
421
|
|
|
422 (defun gnus-agent-read-servers ()
|
|
|
423 "Read the alist of covered servers."
|
|
|
424 (setq gnus-agent-covered-methods
|
|
|
425 (gnus-agent-read-file
|
|
|
426 (nnheader-concat gnus-agent-directory "lib/servers"))))
|
|
|
427
|
|
|
428 (defun gnus-agent-write-servers ()
|
|
|
429 "Write the alist of covered servers."
|
|
|
430 (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/servers")
|
|
|
431 (prin1 gnus-agent-covered-methods (current-buffer))))
|
|
|
432
|
|
|
433 ;;;
|
|
|
434 ;;; Summary commands
|
|
|
435 ;;;
|
|
|
436
|
|
|
437 (defun gnus-agent-mark-article (n &optional unmark)
|
|
|
438 "Mark the next N articles as downloadable.
|
|
|
439 If N is negative, mark backward instead. If UNMARK is non-nil, remove
|
|
|
440 the mark instead. The difference between N and the actual number of
|
|
|
441 articles marked is returned."
|
|
|
442 (interactive "p")
|
|
|
443 (let ((backward (< n 0))
|
|
|
444 (n (abs n)))
|
|
|
445 (while (and
|
|
|
446 (> n 0)
|
|
|
447 (progn
|
|
|
448 (gnus-summary-set-agent-mark
|
|
|
449 (gnus-summary-article-number) unmark)
|
|
|
450 (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
|
|
|
451 (setq n (1- n)))
|
|
|
452 (when (/= 0 n)
|
|
|
453 (gnus-message 7 "No more articles"))
|
|
|
454 (gnus-summary-recenter)
|
|
|
455 (gnus-summary-position-point)
|
|
|
456 n))
|
|
|
457
|
|
|
458 (defun gnus-agent-unmark-article (n)
|
|
|
459 "Remove the downloadable mark from the next N articles.
|
|
|
460 If N is negative, unmark backward instead. The difference between N and
|
|
|
461 the actual number of articles unmarked is returned."
|
|
|
462 (interactive "p")
|
|
|
463 (gnus-agent-mark-article n t))
|
|
|
464
|
|
|
465 (defun gnus-agent-toggle-mark (n)
|
|
|
466 "Toggle the downloadable mark from the next N articles.
|
|
|
467 If N is negative, toggle backward instead. The difference between N and
|
|
|
468 the actual number of articles toggled is returned."
|
|
|
469 (interactive "p")
|
|
|
470 (gnus-agent-mark-article n 'toggle))
|
|
|
471
|
|
|
472 (defun gnus-summary-set-agent-mark (article &optional unmark)
|
|
|
473 "Mark ARTICLE as downloadable."
|
|
|
474 (let ((unmark (if (and (not (null unmark)) (not (eq t unmark)))
|
|
|
475 (memq article gnus-newsgroup-downloadable)
|
|
|
476 unmark)))
|
|
|
477 (if unmark
|
|
|
478 (progn
|
|
|
479 (setq gnus-newsgroup-downloadable
|
|
|
480 (delq article gnus-newsgroup-downloadable))
|
|
|
481 (push article gnus-newsgroup-undownloaded))
|
|
|
482 (setq gnus-newsgroup-undownloaded
|
|
|
483 (delq article gnus-newsgroup-undownloaded))
|
|
|
484 (push article gnus-newsgroup-downloadable))
|
|
|
485 (gnus-summary-update-mark
|
|
|
486 (if unmark gnus-undownloaded-mark gnus-downloadable-mark)
|
|
|
487 'unread)))
|
|
|
488
|
|
|
489 (defun gnus-agent-get-undownloaded-list ()
|
|
|
490 "Mark all unfetched articles as read."
|
|
|
491 (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
|
|
|
492 (when (and (not gnus-plugged)
|
|
|
493 (gnus-agent-method-p gnus-command-method))
|
|
|
494 (gnus-agent-load-alist gnus-newsgroup-name)
|
|
|
495 (let ((articles gnus-newsgroup-unreads)
|
|
|
496 article)
|
|
|
497 (while (setq article (pop articles))
|
|
|
498 (unless (or (cdr (assq article gnus-agent-article-alist))
|
|
|
499 (memq article gnus-newsgroup-downloadable))
|
|
|
500 (push article gnus-newsgroup-undownloaded)))))))
|
|
|
501
|
|
|
502 (defun gnus-agent-catchup ()
|
|
|
503 "Mark all undownloaded articles as read."
|
|
|
504 (interactive)
|
|
|
505 (save-excursion
|
|
|
506 (while gnus-newsgroup-undownloaded
|
|
|
507 (gnus-summary-mark-article
|
|
|
508 (pop gnus-newsgroup-undownloaded) gnus-catchup-mark)))
|
|
|
509 (gnus-summary-position-point))
|
|
|
510
|
|
|
511 ;;;
|
|
|
512 ;;; Internal functions
|
|
|
513 ;;;
|
|
|
514
|
|
|
515 (defun gnus-agent-save-active (method)
|
|
|
516 (when (gnus-agent-method-p method)
|
|
|
517 (let* ((gnus-command-method method)
|
|
|
518 (file (gnus-agent-lib-file "active")))
|
|
|
519 (gnus-make-directory (file-name-directory file))
|
|
|
520 (let ((coding-system-for-write gnus-agent-file-coding-system))
|
|
|
521 (write-region (point-min) (point-max) file nil 'silent))
|
|
|
522 (when (file-exists-p (gnus-agent-lib-file "groups"))
|
|
|
523 (delete-file (gnus-agent-lib-file "groups"))))))
|
|
|
524
|
|
|
525 (defun gnus-agent-save-groups (method)
|
|
|
526 (let* ((gnus-command-method method)
|
|
|
527 (file (gnus-agent-lib-file "groups")))
|
|
|
528 (gnus-make-directory (file-name-directory file))
|
|
|
529 (let ((coding-system-for-write gnus-agent-file-coding-system))
|
|
|
530 (write-region (point-min) (point-max) file nil 'silent))
|
|
|
531 (when (file-exists-p (gnus-agent-lib-file "active"))
|
|
|
532 (delete-file (gnus-agent-lib-file "active")))))
|
|
|
533
|
|
|
534 (defun gnus-agent-save-group-info (method group active)
|
|
|
535 (when (gnus-agent-method-p method)
|
|
|
536 (let* ((gnus-command-method method)
|
|
|
537 (file (if nntp-server-list-active-group
|
|
|
538 (gnus-agent-lib-file "active")
|
|
|
539 (gnus-agent-lib-file "groups"))))
|
|
|
540 (gnus-make-directory (file-name-directory file))
|
|
|
541 (nnheader-temp-write file
|
|
|
542 (when (file-exists-p file)
|
|
|
543 (nnheader-insert-file-contents file))
|
|
|
544 (goto-char (point-min))
|
|
|
545 (if nntp-server-list-active-group
|
|
|
546 (progn
|
|
|
547 (when (re-search-forward
|
|
|
548 (concat "^" (regexp-quote group) " ") nil t)
|
|
|
549 (gnus-delete-line))
|
|
|
550 (insert group " " (number-to-string (cdr active)) " "
|
|
|
551 (number-to-string (car active)) " y\n"))
|
|
|
552 (when (re-search-forward (concat (regexp-quote group) " ") nil t)
|
|
|
553 (gnus-delete-line))
|
|
|
554 (insert-buffer-substring nntp-server-buffer))))))
|
|
|
555
|
|
|
556 (defun gnus-agent-group-path (group)
|
|
|
557 "Translate GROUP into a path."
|
|
|
558 (if nnmail-use-long-file-names
|
|
|
559 (gnus-group-real-name group)
|
|
|
560 (nnheader-replace-chars-in-string
|
|
|
561 (nnheader-translate-file-chars (gnus-group-real-name group))
|
|
|
562 ?. ?/)))
|
|
|
563
|
|
|
564
|
|
|
565
|
|
|
566 (defun gnus-agent-method-p (method)
|
|
|
567 "Say whether METHOD is covered by the agent."
|
|
|
568 (member method gnus-agent-covered-methods))
|
|
|
569
|
|
|
570 (defun gnus-agent-get-function (method)
|
|
|
571 (if (and (not gnus-plugged)
|
|
|
572 (gnus-agent-method-p method))
|
|
|
573 (progn
|
|
|
574 (require 'nnagent)
|
|
|
575 'nnagent)
|
|
|
576 (car method)))
|
|
|
577
|
|
|
578 ;;; History functions
|
|
|
579
|
|
|
580 (defun gnus-agent-history-buffer ()
|
|
|
581 (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
|
|
|
582
|
|
|
583 (defun gnus-agent-open-history ()
|
|
|
584 (save-excursion
|
|
|
585 (push (cons (gnus-agent-method)
|
|
|
586 (set-buffer (gnus-get-buffer-create
|
|
|
587 (format " *Gnus agent %s history*"
|
|
|
588 (gnus-agent-method)))))
|
|
|
589 gnus-agent-history-buffers)
|
|
|
590 (erase-buffer)
|
|
|
591 (insert "\n")
|
|
|
592 (let ((file (gnus-agent-lib-file "history")))
|
|
|
593 (when (file-exists-p file)
|
|
|
594 (insert-file file))
|
|
|
595 (set (make-local-variable 'gnus-agent-file-name) file))))
|
|
|
596
|
|
|
597 (defun gnus-agent-save-history ()
|
|
|
598 (save-excursion
|
|
|
599 (set-buffer gnus-agent-current-history)
|
|
|
600 (gnus-make-directory (file-name-directory gnus-agent-file-name))
|
|
|
601 (let ((coding-system-for-write gnus-agent-file-coding-system))
|
|
|
602 (write-region (1+ (point-min)) (point-max)
|
|
|
603 gnus-agent-file-name nil 'silent))))
|
|
|
604
|
|
|
605 (defun gnus-agent-close-history ()
|
|
|
606 (when (gnus-buffer-live-p gnus-agent-current-history)
|
|
|
607 (kill-buffer gnus-agent-current-history)
|
|
|
608 (setq gnus-agent-history-buffers
|
|
|
609 (delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
|
|
|
610 gnus-agent-history-buffers))))
|
|
|
611
|
|
|
612 (defun gnus-agent-enter-history (id group-arts date)
|
|
|
613 (save-excursion
|
|
|
614 (set-buffer gnus-agent-current-history)
|
|
|
615 (goto-char (point-max))
|
|
|
616 (insert id "\t" (number-to-string date) "\t")
|
|
|
617 (while group-arts
|
|
|
618 (insert (caar group-arts) " " (number-to-string (cdr (pop group-arts)))
|
|
|
619 " "))
|
|
|
620 (insert "\n")))
|
|
|
621
|
|
|
622 (defun gnus-agent-article-in-history-p (id)
|
|
|
623 (save-excursion
|
|
|
624 (set-buffer (gnus-agent-history-buffer))
|
|
|
625 (goto-char (point-min))
|
|
|
626 (search-forward (concat "\n" id "\t") nil t)))
|
|
|
627
|
|
|
628 (defun gnus-agent-history-path (id)
|
|
|
629 (save-excursion
|
|
|
630 (set-buffer (gnus-agent-history-buffer))
|
|
|
631 (goto-char (point-min))
|
|
|
632 (when (search-forward (concat "\n" id "\t") nil t)
|
|
|
633 (let ((method (gnus-agent-method)))
|
|
|
634 (let (paths group)
|
|
|
635 (while (not (numberp (setq group (read (current-buffer)))))
|
|
|
636 (push (concat method "/" group) paths))
|
|
|
637 (nreverse paths))))))
|
|
|
638
|
|
|
639 ;;;
|
|
|
640 ;;; Fetching
|
|
|
641 ;;;
|
|
|
642
|
|
|
643 (defun gnus-agent-fetch-articles (group articles)
|
|
|
644 "Fetch ARTICLES from GROUP and put them into the Agent."
|
|
|
645 (when articles
|
|
|
646 ;; Prune off articles that we have already fetched.
|
|
|
647 (while (and articles
|
|
|
648 (cdr (assq (car articles) gnus-agent-article-alist)))
|
|
|
649 (pop articles))
|
|
|
650 (let ((arts articles))
|
|
|
651 (while (cdr arts)
|
|
|
652 (if (cdr (assq (cadr arts) gnus-agent-article-alist))
|
|
|
653 (setcdr arts (cddr arts))
|
|
|
654 (setq arts (cdr arts)))))
|
|
|
655 (when articles
|
|
|
656 (let ((dir (concat
|
|
|
657 (gnus-agent-directory)
|
|
|
658 (gnus-agent-group-path group) "/"))
|
|
|
659 (date (gnus-time-to-day (current-time)))
|
|
|
660 (case-fold-search t)
|
|
|
661 pos crosses id elem)
|
|
|
662 (gnus-make-directory dir)
|
|
|
663 (gnus-message 7 "Fetching articles for %s..." group)
|
|
|
664 ;; Fetch the articles from the backend.
|
|
|
665 (if (gnus-check-backend-function 'retrieve-articles group)
|
|
|
666 (setq pos (gnus-retrieve-articles articles group))
|
|
|
667 (nnheader-temp-write nil
|
|
|
668 (let (article)
|
|
|
669 (while (setq article (pop articles))
|
|
|
670 (when (gnus-request-article article group)
|
|
|
671 (goto-char (point-max))
|
|
|
672 (push (cons article (point)) pos)
|
|
|
673 (insert-buffer-substring nntp-server-buffer)))
|
|
|
674 (copy-to-buffer nntp-server-buffer (point-min) (point-max))
|
|
|
675 (setq pos (nreverse pos)))))
|
|
|
676 ;; Then save these articles into the Agent.
|
|
|
677 (save-excursion
|
|
|
678 (set-buffer nntp-server-buffer)
|
|
|
679 (while pos
|
|
|
680 (narrow-to-region (cdar pos) (or (cdadr pos) (point-max)))
|
|
|
681 (goto-char (point-min))
|
|
|
682 (when (search-forward "\n\n" nil t)
|
|
|
683 (when (search-backward "\nXrefs: " nil t)
|
|
|
684 ;; Handle crossposting.
|
|
|
685 (skip-chars-forward "^ ")
|
|
|
686 (skip-chars-forward " ")
|
|
|
687 (setq crosses nil)
|
|
|
688 (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +")
|
|
|
689 (push (cons (buffer-substring (match-beginning 1)
|
|
|
690 (match-end 1))
|
|
|
691 (buffer-substring (match-beginning 2)
|
|
|
692 (match-end 2)))
|
|
|
693 crosses)
|
|
|
694 (goto-char (match-end 0)))
|
|
|
695 (gnus-agent-crosspost crosses (caar pos))))
|
|
|
696 (goto-char (point-min))
|
|
|
697 (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t))
|
|
|
698 (setq id "No-Message-ID-in-article")
|
|
|
699 (setq id (buffer-substring (match-beginning 1) (match-end 1))))
|
|
|
700 (let ((coding-system-for-write
|
|
|
701 gnus-agent-file-coding-system))
|
|
|
702 (write-region (point-min) (point-max)
|
|
|
703 (concat dir (number-to-string (caar pos)))
|
|
|
704 nil 'silent))
|
|
|
705 (when (setq elem (assq (caar pos) gnus-agent-article-alist))
|
|
|
706 (setcdr elem t))
|
|
|
707 (gnus-agent-enter-history
|
|
|
708 id (or crosses (list (cons group (caar pos)))) date)
|
|
|
709 (widen)
|
|
|
710 (pop pos)))
|
|
|
711 (gnus-agent-save-alist group)))))
|
|
|
712
|
|
|
713 (defun gnus-agent-crosspost (crosses article)
|
|
|
714 (let (gnus-agent-article-alist group alist beg end)
|
|
|
715 (save-excursion
|
|
|
716 (set-buffer gnus-agent-overview-buffer)
|
|
|
717 (when (nnheader-find-nov-line article)
|
|
|
718 (forward-word 1)
|
|
|
719 (setq beg (point))
|
|
|
720 (setq end (progn (forward-line 1) (point)))))
|
|
|
721 (while crosses
|
|
|
722 (setq group (caar crosses))
|
|
|
723 (unless (setq alist (assoc group gnus-agent-group-alist))
|
|
|
724 (push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
|
|
|
725 gnus-agent-group-alist))
|
|
|
726 (setcdr alist (cons (cons (cdar crosses) t) (cdr alist)))
|
|
|
727 (save-excursion
|
|
|
728 (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*"
|
|
|
729 group)))
|
|
|
730 (when (= (point-max) (point-min))
|
|
|
731 (push (cons group (current-buffer)) gnus-agent-buffer-alist)
|
|
|
732 (ignore-errors
|
|
|
733 (nnheader-insert-file-contents
|
|
|
734 (gnus-agent-article-name ".overview" group))))
|
|
|
735 (nnheader-find-nov-line (string-to-number (cdar crosses)))
|
|
|
736 (insert (string-to-number (cdar crosses)))
|
|
|
737 (insert-buffer-substring gnus-agent-overview-buffer beg end))
|
|
|
738 (pop crosses))))
|
|
|
739
|
|
|
740 (defun gnus-agent-flush-cache ()
|
|
|
741 (save-excursion
|
|
|
742 (while gnus-agent-buffer-alist
|
|
|
743 (set-buffer (cdar gnus-agent-buffer-alist))
|
|
|
744 (let ((coding-system-for-write
|
|
|
745 gnus-agent-file-coding-system))
|
|
|
746 (write-region (point-min) (point-max)
|
|
|
747 (gnus-agent-article-name ".overview"
|
|
|
748 (caar gnus-agent-buffer-alist))
|
|
|
749 nil 'silent))
|
|
|
750 (pop gnus-agent-buffer-alist))
|
|
|
751 (while gnus-agent-group-alist
|
|
|
752 (nnheader-temp-write (caar gnus-agent-group-alist)
|
|
|
753 (princ (cdar gnus-agent-group-alist))
|
|
|
754 (insert "\n"))
|
|
|
755 (pop gnus-agent-group-alist))))
|
|
|
756
|
|
|
757 (defun gnus-agent-fetch-headers (group &optional force)
|
|
|
758 (let ((articles (if (gnus-agent-load-alist group)
|
|
|
759 (gnus-sorted-intersection
|
|
|
760 (gnus-list-of-unread-articles group)
|
|
|
761 (gnus-uncompress-range
|
|
|
762 (cons (1+ (caar (last gnus-agent-article-alist)))
|
|
|
763 (cdr (gnus-active group)))))
|
|
|
764 (gnus-list-of-unread-articles group))))
|
|
|
765 ;; Fetch them.
|
|
|
766 (when articles
|
|
|
767 (gnus-message 7 "Fetching headers for %s..." group)
|
|
|
768 (save-excursion
|
|
|
769 (set-buffer nntp-server-buffer)
|
|
|
770 (unless (eq 'nov (gnus-retrieve-headers articles group))
|
|
|
771 (nnvirtual-convert-headers))
|
|
|
772 ;; Save these headers for later processing.
|
|
|
773 (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
|
|
|
774 (let (file)
|
|
|
775 (when (file-exists-p
|
|
|
776 (setq file (gnus-agent-article-name ".overview" group)))
|
|
|
777 (gnus-agent-braid-nov group articles file))
|
|
|
778 (gnus-make-directory (nnheader-translate-file-chars
|
|
|
779 (file-name-directory file)))
|
|
|
780 (let ((coding-system-for-write
|
|
|
781 gnus-agent-file-coding-system))
|
|
|
782 (write-region (point-min) (point-max) file nil 'silent))
|
|
|
783 (gnus-agent-save-alist group articles nil)
|
|
|
784 (gnus-agent-enter-history
|
|
|
785 "last-header-fetched-for-session"
|
|
|
786 (list (cons group (nth (- (length articles) 1) articles)))
|
|
|
787 (gnus-time-to-day (current-time)))
|
|
|
788 articles)))))
|
|
|
789
|
|
|
790 (defsubst gnus-agent-copy-nov-line (article)
|
|
|
791 (let (b e)
|
|
|
792 (set-buffer gnus-agent-overview-buffer)
|
|
|
793 (setq b (point))
|
|
|
794 (if (eq article (read (current-buffer)))
|
|
|
795 (setq e (progn (forward-line 1) (point)))
|
|
|
796 (progn
|
|
|
797 (beginning-of-line)
|
|
|
798 (setq e b)))
|
|
|
799 (set-buffer nntp-server-buffer)
|
|
|
800 (insert-buffer-substring gnus-agent-overview-buffer b e)))
|
|
|
801
|
|
|
802 (defun gnus-agent-braid-nov (group articles file)
|
|
|
803 (set-buffer gnus-agent-overview-buffer)
|
|
|
804 (goto-char (point-min))
|
|
|
805 (set-buffer nntp-server-buffer)
|
|
|
806 (erase-buffer)
|
|
|
807 (nnheader-insert-file-contents file)
|
|
|
808 (goto-char (point-max))
|
|
|
809 (if (or (= (point-min) (point-max))
|
|
|
810 (progn
|
|
|
811 (forward-line -1)
|
|
|
812 (< (read (current-buffer)) (car articles))))
|
|
|
813 ;; We have only headers that are after the older headers,
|
|
|
814 ;; so we just append them.
|
|
|
815 (progn
|
|
|
816 (goto-char (point-max))
|
|
|
817 (insert-buffer-substring gnus-agent-overview-buffer))
|
|
|
818 ;; We do it the hard way.
|
|
|
819 (nnheader-find-nov-line (car articles))
|
|
|
820 (gnus-agent-copy-nov-line (car articles))
|
|
|
821 (pop articles)
|
|
|
822 (while (and articles
|
|
|
823 (not (eobp)))
|
|
|
824 (while (and (not (eobp))
|
|
|
825 (< (read (current-buffer)) (car articles)))
|
|
|
826 (forward-line 1))
|
|
|
827 (beginning-of-line)
|
|
|
828 (unless (eobp)
|
|
|
829 (gnus-agent-copy-nov-line (car articles))
|
|
|
830 (setq articles (cdr articles))))
|
|
|
831 (when articles
|
|
|
832 (let (b e)
|
|
|
833 (set-buffer gnus-agent-overview-buffer)
|
|
|
834 (setq b (point)
|
|
|
835 e (point-max))
|
|
|
836 (set-buffer nntp-server-buffer)
|
|
|
837 (insert-buffer-substring gnus-agent-overview-buffer b e)))))
|
|
|
838
|
|
|
839 (defun gnus-agent-load-alist (group &optional dir)
|
|
|
840 "Load the article-state alist for GROUP."
|
|
|
841 (setq gnus-agent-article-alist
|
|
|
842 (gnus-agent-read-file
|
|
|
843 (if dir
|
|
|
844 (concat dir ".agentview")
|
|
|
845 (gnus-agent-article-name ".agentview" group)))))
|
|
|
846
|
|
|
847 (defun gnus-agent-save-alist (group &optional articles state dir)
|
|
|
848 "Save the article-state alist for GROUP."
|
|
|
849 (nnheader-temp-write (if dir
|
|
|
850 (concat dir ".agentview")
|
|
|
851 (gnus-agent-article-name ".agentview" group))
|
|
|
852 (princ (setq gnus-agent-article-alist
|
|
|
853 (nconc gnus-agent-article-alist
|
|
|
854 (mapcar (lambda (article) (cons article state))
|
|
|
855 articles)))
|
|
|
856 (current-buffer))
|
|
|
857 (insert "\n")))
|
|
|
858
|
|
|
859 (defun gnus-agent-article-name (article group)
|
|
|
860 (concat (gnus-agent-directory) (gnus-agent-group-path group) "/"
|
|
|
861 (if (stringp article) article (string-to-number article))))
|
|
|
862
|
|
|
863 ;;;###autoload
|
|
|
864 (defun gnus-agent-batch-fetch ()
|
|
|
865 "Start Gnus and fetch session."
|
|
|
866 (interactive)
|
|
|
867 (gnus)
|
|
|
868 (gnus-agent-fetch-session)
|
|
|
869 (gnus-group-exit))
|
|
|
870
|
|
|
871 (defun gnus-agent-fetch-session ()
|
|
|
872 "Fetch all articles and headers that are eligible for fetching."
|
|
|
873 (interactive)
|
|
|
874 (unless gnus-agent-covered-methods
|
|
|
875 (error "No servers are covered by the Gnus agent"))
|
|
|
876 (unless gnus-plugged
|
|
|
877 (error "Can't fetch articles while Gnus is unplugged"))
|
|
|
878 (let ((methods gnus-agent-covered-methods)
|
|
|
879 groups group gnus-command-method)
|
|
|
880 (save-excursion
|
|
|
881 (while methods
|
|
|
882 (setq gnus-command-method (car methods))
|
|
|
883 (when (or (gnus-server-opened gnus-command-method)
|
|
|
884 (gnus-open-server gnus-command-method))
|
|
|
885 (setq groups (gnus-groups-from-server (car methods)))
|
|
|
886 (gnus-agent-with-fetch
|
|
|
887 (while (setq group (pop groups))
|
|
|
888 (when (<= (gnus-group-level group) gnus-agent-handle-level)
|
|
|
889 (gnus-agent-fetch-group-1 group gnus-command-method)))))
|
|
|
890 (pop methods))
|
|
|
891 (gnus-message 6 "Finished fetching articles into the Gnus agent"))))
|
|
|
892
|
|
|
893 (defun gnus-agent-fetch-group-1 (group method)
|
|
|
894 "Fetch GROUP."
|
|
|
895 (let ((gnus-command-method method)
|
|
|
896 gnus-newsgroup-dependencies gnus-newsgroup-headers
|
|
|
897 gnus-newsgroup-scored gnus-headers gnus-score
|
|
|
898 gnus-use-cache articles arts
|
|
|
899 category predicate info marks score-param)
|
|
|
900 ;; Fetch headers.
|
|
|
901 (when (and (or (gnus-active group) (gnus-activate-group group))
|
|
|
902 (setq articles (gnus-agent-fetch-headers group)))
|
|
|
903 ;; Parse them and see which articles we want to fetch.
|
|
|
904 (setq gnus-newsgroup-dependencies
|
|
|
905 (make-vector (length articles) 0))
|
|
|
906 (setq gnus-newsgroup-headers
|
|
|
907 (gnus-get-newsgroup-headers-xover articles nil nil group))
|
|
|
908 (setq category (gnus-group-category group))
|
|
|
909 (setq predicate
|
|
|
910 (gnus-get-predicate
|
|
|
911 (or (gnus-group-get-parameter group 'agent-predicate)
|
|
|
912 (cadr category))))
|
|
|
913 (setq score-param
|
|
|
914 (or (gnus-group-get-parameter group 'agent-score)
|
|
|
915 (caddr category)))
|
|
|
916 (when score-param
|
|
|
917 (gnus-score-headers (list (list score-param))))
|
|
|
918 (setq arts nil)
|
|
|
919 (while (setq gnus-headers (pop gnus-newsgroup-headers))
|
|
|
920 (setq gnus-score
|
|
|
921 (or (cdr (assq (mail-header-number gnus-headers)
|
|
|
922 gnus-newsgroup-scored))
|
|
|
923 gnus-summary-default-score))
|
|
|
924 (when (funcall predicate)
|
|
|
925 (push (mail-header-number gnus-headers)
|
|
|
926 arts)))
|
|
|
927 ;; Fetch the articles.
|
|
|
928 (when arts
|
|
|
929 (gnus-agent-fetch-articles group arts)))
|
|
|
930 ;; Perhaps we have some additional articles to fetch.
|
|
|
931 (setq arts (assq 'download (gnus-info-marks
|
|
|
932 (setq info (gnus-get-info group)))))
|
|
|
933 (when (cdr arts)
|
|
|
934 (gnus-agent-fetch-articles
|
|
|
935 group (gnus-uncompress-range (cdr arts)))
|
|
|
936 (setq marks (delq arts (gnus-info-marks info)))
|
|
|
937 (gnus-info-set-marks info marks))))
|
|
|
938
|
|
|
939 ;;;
|
|
|
940 ;;; Agent Category Mode
|
|
|
941 ;;;
|
|
|
942
|
|
|
943 (defvar gnus-category-mode-hook nil
|
|
|
944 "Hook run in `gnus-category-mode' buffers.")
|
|
|
945
|
|
|
946 (defvar gnus-category-line-format " %(%20c%): %g\n"
|
|
|
947 "Format of category lines.")
|
|
|
948
|
|
|
949 (defvar gnus-category-mode-line-format "Gnus: %%b"
|
|
|
950 "The format specification for the category mode line.")
|
|
|
951
|
|
|
952 (defvar gnus-agent-short-article 100
|
|
|
953 "Articles that have fewer lines than this are short.")
|
|
|
954
|
|
|
955 (defvar gnus-agent-long-article 200
|
|
|
956 "Articles that have more lines than this are long.")
|
|
|
957
|
|
|
958 (defvar gnus-agent-low-score 0
|
|
|
959 "Articles that have a score lower than this have a low score.")
|
|
|
960
|
|
|
961 (defvar gnus-agent-high-score 0
|
|
|
962 "Articles that have a score higher than this have a high score.")
|
|
|
963
|
|
|
964
|
|
|
965 ;;; Internal variables.
|
|
|
966
|
|
|
967 (defvar gnus-category-buffer "*Agent Category*")
|
|
|
968
|
|
|
969 (defvar gnus-category-line-format-alist
|
|
|
970 `((?c gnus-tmp-name ?s)
|
|
|
971 (?g gnus-tmp-groups ?d)))
|
|
|
972
|
|
|
973 (defvar gnus-category-mode-line-format-alist
|
|
|
974 `((?u user-defined ?s)))
|
|
|
975
|
|
|
976 (defvar gnus-category-line-format-spec nil)
|
|
|
977 (defvar gnus-category-mode-line-format-spec nil)
|
|
|
978
|
|
|
979 (defvar gnus-category-mode-map nil)
|
|
|
980 (put 'gnus-category-mode 'mode-class 'special)
|
|
|
981
|
|
|
982 (unless gnus-category-mode-map
|
|
|
983 (setq gnus-category-mode-map (make-sparse-keymap))
|
|
|
984 (suppress-keymap gnus-category-mode-map)
|
|
|
985
|
|
|
986 (gnus-define-keys gnus-category-mode-map
|
|
|
987 "q" gnus-category-exit
|
|
|
988 "k" gnus-category-kill
|
|
|
989 "c" gnus-category-copy
|
|
|
990 "a" gnus-category-add
|
|
|
991 "p" gnus-category-edit-predicate
|
|
|
992 "g" gnus-category-edit-groups
|
|
|
993 "s" gnus-category-edit-score
|
|
|
994 "l" gnus-category-list
|
|
|
995
|
|
|
996 "\C-c\C-i" gnus-info-find-node
|
|
|
997 "\C-c\C-b" gnus-bug))
|
|
|
998
|
|
|
999 (defvar gnus-category-menu-hook nil
|
|
|
1000 "*Hook run after the creation of the menu.")
|
|
|
1001
|
|
|
1002 (defun gnus-category-make-menu-bar ()
|
|
|
1003 (gnus-turn-off-edit-menu 'category)
|
|
|
1004 (unless (boundp 'gnus-category-menu)
|
|
|
1005 (easy-menu-define
|
|
|
1006 gnus-category-menu gnus-category-mode-map ""
|
|
|
1007 '("Categories"
|
|
|
1008 ["Add" gnus-category-add t]
|
|
|
1009 ["Kill" gnus-category-kill t]
|
|
|
1010 ["Copy" gnus-category-copy t]
|
|
|
1011 ["Edit predicate" gnus-category-edit-predicate t]
|
|
|
1012 ["Edit score" gnus-category-edit-score t]
|
|
|
1013 ["Edit groups" gnus-category-edit-groups t]
|
|
|
1014 ["Exit" gnus-category-exit t]))
|
|
|
1015
|
|
|
1016 (gnus-run-hooks 'gnus-category-menu-hook)))
|
|
|
1017
|
|
|
1018 (defun gnus-category-mode ()
|
|
|
1019 "Major mode for listing and editing agent categories.
|
|
|
1020
|
|
|
1021 All normal editing commands are switched off.
|
|
|
1022 \\<gnus-category-mode-map>
|
|
|
1023 For more in-depth information on this mode, read the manual
|
|
|
1024 (`\\[gnus-info-find-node]').
|
|
|
1025
|
|
|
1026 The following commands are available:
|
|
|
1027
|
|
|
1028 \\{gnus-category-mode-map}"
|
|
|
1029 (interactive)
|
|
|
1030 (when (gnus-visual-p 'category-menu 'menu)
|
|
|
1031 (gnus-category-make-menu-bar))
|
|
|
1032 (kill-all-local-variables)
|
|
|
1033 (gnus-simplify-mode-line)
|
|
|
1034 (setq major-mode 'gnus-category-mode)
|
|
|
1035 (setq mode-name "Category")
|
|
|
1036 (gnus-set-default-directory)
|
|
|
1037 (setq mode-line-process nil)
|
|
|
1038 (use-local-map gnus-category-mode-map)
|
|
|
1039 (buffer-disable-undo (current-buffer))
|
|
|
1040 (setq truncate-lines t)
|
|
|
1041 (setq buffer-read-only t)
|
|
|
1042 (gnus-run-hooks 'gnus-category-mode-hook))
|
|
|
1043
|
|
|
1044 (defalias 'gnus-category-position-point 'gnus-goto-colon)
|
|
|
1045
|
|
|
1046 (defun gnus-category-insert-line (category)
|
|
|
1047 (let* ((gnus-tmp-name (car category))
|
|
|
1048 (gnus-tmp-groups (length (cadddr category))))
|
|
|
1049 (beginning-of-line)
|
|
|
1050 (gnus-add-text-properties
|
|
|
1051 (point)
|
|
|
1052 (prog1 (1+ (point))
|
|
|
1053 ;; Insert the text.
|
|
|
1054 (eval gnus-category-line-format-spec))
|
|
|
1055 (list 'gnus-category gnus-tmp-name))))
|
|
|
1056
|
|
|
1057 (defun gnus-enter-category-buffer ()
|
|
|
1058 "Go to the Category buffer."
|
|
|
1059 (interactive)
|
|
|
1060 (gnus-category-setup-buffer)
|
|
|
1061 (gnus-configure-windows 'category)
|
|
|
1062 (gnus-category-prepare))
|
|
|
1063
|
|
|
1064 (defun gnus-category-setup-buffer ()
|
|
|
1065 (unless (get-buffer gnus-category-buffer)
|
|
|
1066 (save-excursion
|
|
|
1067 (set-buffer (gnus-get-buffer-create gnus-category-buffer))
|
|
|
1068 (gnus-category-mode))))
|
|
|
1069
|
|
|
1070 (defun gnus-category-prepare ()
|
|
|
1071 (gnus-set-format 'category-mode)
|
|
|
1072 (gnus-set-format 'category t)
|
|
|
1073 (let ((alist gnus-category-alist)
|
|
|
1074 (buffer-read-only nil))
|
|
|
1075 (erase-buffer)
|
|
|
1076 (while alist
|
|
|
1077 (gnus-category-insert-line (pop alist)))
|
|
|
1078 (goto-char (point-min))
|
|
|
1079 (gnus-category-position-point)))
|
|
|
1080
|
|
|
1081 (defun gnus-category-name ()
|
|
|
1082 (or (get-text-property (gnus-point-at-bol) 'gnus-category)
|
|
|
1083 (error "No category on the current line")))
|
|
|
1084
|
|
|
1085 (defun gnus-category-read ()
|
|
|
1086 "Read the category alist."
|
|
|
1087 (setq gnus-category-alist
|
|
|
1088 (or (gnus-agent-read-file
|
|
|
1089 (nnheader-concat gnus-agent-directory "lib/categories"))
|
|
|
1090 (list (list 'default 'short nil nil)))))
|
|
|
1091
|
|
|
1092 (defun gnus-category-write ()
|
|
|
1093 "Write the category alist."
|
|
|
1094 (setq gnus-category-predicate-cache nil
|
|
|
1095 gnus-category-group-cache nil)
|
|
|
1096 (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/categories")
|
|
|
1097 (prin1 gnus-category-alist (current-buffer))))
|
|
|
1098
|
|
|
1099 (defun gnus-category-edit-predicate (category)
|
|
|
1100 "Edit the predicate for CATEGORY."
|
|
|
1101 (interactive (list (gnus-category-name)))
|
|
|
1102 (let ((info (assq category gnus-category-alist)))
|
|
|
1103 (gnus-edit-form
|
|
|
1104 (cadr info) (format "Editing the predicate for category %s" category)
|
|
|
1105 `(lambda (predicate)
|
|
|
1106 (setf (cadr (assq ',category gnus-category-alist)) predicate)
|
|
|
1107 (gnus-category-write)
|
|
|
1108 (gnus-category-list)))))
|
|
|
1109
|
|
|
1110 (defun gnus-category-edit-score (category)
|
|
|
1111 "Edit the score expression for CATEGORY."
|
|
|
1112 (interactive (list (gnus-category-name)))
|
|
|
1113 (let ((info (assq category gnus-category-alist)))
|
|
|
1114 (gnus-edit-form
|
|
|
1115 (caddr info)
|
|
|
1116 (format "Editing the score expression for category %s" category)
|
|
|
1117 `(lambda (groups)
|
|
|
1118 (setf (caddr (assq ',category gnus-category-alist)) groups)
|
|
|
1119 (gnus-category-write)
|
|
|
1120 (gnus-category-list)))))
|
|
|
1121
|
|
|
1122 (defun gnus-category-edit-groups (category)
|
|
|
1123 "Edit the group list for CATEGORY."
|
|
|
1124 (interactive (list (gnus-category-name)))
|
|
|
1125 (let ((info (assq category gnus-category-alist)))
|
|
|
1126 (gnus-edit-form
|
|
|
1127 (cadddr info) (format "Editing the group list for category %s" category)
|
|
|
1128 `(lambda (groups)
|
|
|
1129 (setf (cadddr (assq ',category gnus-category-alist)) groups)
|
|
|
1130 (gnus-category-write)
|
|
|
1131 (gnus-category-list)))))
|
|
|
1132
|
|
|
1133 (defun gnus-category-kill (category)
|
|
|
1134 "Kill the current category."
|
|
|
1135 (interactive (list (gnus-category-name)))
|
|
|
1136 (let ((info (assq category gnus-category-alist))
|
|
|
1137 (buffer-read-only nil))
|
|
|
1138 (gnus-delete-line)
|
|
|
1139 (gnus-category-write)
|
|
|
1140 (setq gnus-category-alist (delq info gnus-category-alist))))
|
|
|
1141
|
|
|
1142 (defun gnus-category-copy (category to)
|
|
|
1143 "Copy the current category."
|
|
|
1144 (interactive (list (gnus-category-name) (intern (read-string "New name: "))))
|
|
|
1145 (let ((info (assq category gnus-category-alist)))
|
|
|
1146 (push (list to (gnus-copy-sequence (cadr info))
|
|
|
1147 (gnus-copy-sequence (caddr info)) nil)
|
|
|
1148 gnus-category-alist)
|
|
|
1149 (gnus-category-write)
|
|
|
1150 (gnus-category-list)))
|
|
|
1151
|
|
|
1152 (defun gnus-category-add (category)
|
|
|
1153 "Create a new category."
|
|
|
1154 (interactive "SCategory name: ")
|
|
|
1155 (when (assq category gnus-category-alist)
|
|
|
1156 (error "Category %s already exists" category))
|
|
|
1157 (push (list category 'true nil nil)
|
|
|
1158 gnus-category-alist)
|
|
|
1159 (gnus-category-write)
|
|
|
1160 (gnus-category-list))
|
|
|
1161
|
|
|
1162 (defun gnus-category-list ()
|
|
|
1163 "List all categories."
|
|
|
1164 (interactive)
|
|
|
1165 (gnus-category-prepare))
|
|
|
1166
|
|
|
1167 (defun gnus-category-exit ()
|
|
|
1168 "Return to the group buffer."
|
|
|
1169 (interactive)
|
|
|
1170 (kill-buffer (current-buffer))
|
|
|
1171 (gnus-configure-windows 'group t))
|
|
|
1172
|
|
|
1173 ;; To avoid having 8-bit characters in the source file.
|
|
|
1174 (defvar gnus-category-not (list '! 'not (intern (format "%c" 172))))
|
|
|
1175
|
|
|
1176 (defvar gnus-category-predicate-alist
|
|
|
1177 '((spam . gnus-agent-spam-p)
|
|
|
1178 (short . gnus-agent-short-p)
|
|
|
1179 (long . gnus-agent-long-p)
|
|
|
1180 (low . gnus-agent-low-scored-p)
|
|
|
1181 (high . gnus-agent-high-scored-p)
|
|
|
1182 (true . gnus-agent-true)
|
|
|
1183 (false . gnus-agent-false))
|
|
|
1184 "Mapping from short score predicate symbols to predicate functions.")
|
|
|
1185
|
|
|
1186 (defun gnus-agent-spam-p ()
|
|
|
1187 "Say whether an article is spam or not."
|
|
|
1188 (unless gnus-agent-spam-hashtb
|
|
|
1189 (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000)))
|
|
|
1190 (if (not (equal (mail-header-references gnus-headers) ""))
|
|
|
1191 nil
|
|
|
1192 (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
|
|
|
1193 (prog1
|
|
|
1194 (gnus-gethash string gnus-agent-spam-hashtb)
|
|
|
1195 (gnus-sethash string t gnus-agent-spam-hashtb)))))
|
|
|
1196
|
|
|
1197 (defun gnus-agent-short-p ()
|
|
|
1198 "Say whether an article is short or not."
|
|
|
1199 (< (mail-header-lines gnus-headers) gnus-agent-short-article))
|
|
|
1200
|
|
|
1201 (defun gnus-agent-long-p ()
|
|
|
1202 "Say whether an article is long or not."
|
|
|
1203 (> (mail-header-lines gnus-headers) gnus-agent-long-article))
|
|
|
1204
|
|
|
1205 (defun gnus-agent-low-scored-p ()
|
|
|
1206 "Say whether an article has a low score or not."
|
|
|
1207 (< gnus-score gnus-agent-low-score))
|
|
|
1208
|
|
|
1209 (defun gnus-agent-high-scored-p ()
|
|
|
1210 "Say whether an article has a high score or not."
|
|
|
1211 (> gnus-score gnus-agent-high-score))
|
|
|
1212
|
|
|
1213 (defun gnus-category-make-function (cat)
|
|
|
1214 "Make a function from category CAT."
|
|
|
1215 `(lambda () ,(gnus-category-make-function-1 cat)))
|
|
|
1216
|
|
|
1217 (defun gnus-agent-true ()
|
|
|
1218 "Return t."
|
|
|
1219 t)
|
|
|
1220
|
|
|
1221 (defun gnus-agent-false ()
|
|
|
1222 "Return nil."
|
|
|
1223 nil)
|
|
|
1224
|
|
|
1225 (defun gnus-category-make-function-1 (cat)
|
|
|
1226 "Make a function from category CAT."
|
|
|
1227 (cond
|
|
|
1228 ;; Functions are just returned as is.
|
|
|
1229 ((or (symbolp cat)
|
|
|
1230 (gnus-functionp cat))
|
|
|
1231 `(,(or (cdr (assq cat gnus-category-predicate-alist))
|
|
|
1232 cat)))
|
|
|
1233 ;; More complex category.
|
|
|
1234 ((consp cat)
|
|
|
1235 `(,(cond
|
|
|
1236 ((memq (car cat) '(& and))
|
|
|
1237 'and)
|
|
|
1238 ((memq (car cat) '(| or))
|
|
|
1239 'or)
|
|
|
1240 ((memq (car cat) gnus-category-not)
|
|
|
1241 'not))
|
|
|
1242 ,@(mapcar 'gnus-category-make-function-1 (cdr cat))))
|
|
|
1243 (t
|
|
|
1244 (error "Unknown category type: %s" cat))))
|
|
|
1245
|
|
|
1246 (defun gnus-get-predicate (predicate)
|
|
|
1247 "Return the predicate for CATEGORY."
|
|
|
1248 (or (cdr (assoc predicate gnus-category-predicate-cache))
|
|
|
1249 (cdar (push (cons predicate
|
|
|
1250 (gnus-category-make-function predicate))
|
|
|
1251 gnus-category-predicate-cache))))
|
|
|
1252
|
|
|
1253 (defun gnus-group-category (group)
|
|
|
1254 "Return the category GROUP belongs to."
|
|
|
1255 (unless gnus-category-group-cache
|
|
|
1256 (setq gnus-category-group-cache (gnus-make-hashtable 1000))
|
|
|
1257 (let ((cs gnus-category-alist)
|
|
|
1258 groups cat)
|
|
|
1259 (while (setq cat (pop cs))
|
|
|
1260 (setq groups (cadddr cat))
|
|
|
1261 (while groups
|
|
|
1262 (gnus-sethash (pop groups) cat gnus-category-group-cache)))))
|
|
|
1263 (or (gnus-gethash group gnus-category-group-cache)
|
|
|
1264 (assq 'default gnus-category-alist)))
|
|
|
1265
|
|
|
1266 (defun gnus-agent-expire ()
|
|
|
1267 "Expire all old articles."
|
|
|
1268 (interactive)
|
|
|
1269 (let ((methods gnus-agent-covered-methods)
|
|
|
1270 (day (- (gnus-time-to-day (current-time)) gnus-agent-expire-days))
|
|
|
1271 gnus-command-method sym group articles
|
|
|
1272 history overview file histories elem art nov-file low info
|
|
|
1273 unreads marked article)
|
|
|
1274 (save-excursion
|
|
|
1275 (setq overview (gnus-get-buffer-create " *expire overview*"))
|
|
|
1276 (while (setq gnus-command-method (pop methods))
|
|
|
1277 (let ((expiry-hashtb (gnus-make-hashtable 1023)))
|
|
|
1278 (gnus-agent-open-history)
|
|
|
1279 (set-buffer
|
|
|
1280 (setq gnus-agent-current-history
|
|
|
1281 (setq history (gnus-agent-history-buffer))))
|
|
|
1282 (goto-char (point-min))
|
|
|
1283 (when (> (buffer-size) 1)
|
|
|
1284 (goto-char (point-min))
|
|
|
1285 (while (not (eobp))
|
|
|
1286 (skip-chars-forward "^\t")
|
|
|
1287 (if (> (read (current-buffer)) day)
|
|
|
1288 ;; New article; we don't expire it.
|
|
|
1289 (forward-line 1)
|
|
|
1290 ;; Old article. Schedule it for possible nuking.
|
|
|
1291 (while (not (eolp))
|
|
|
1292 (setq sym (let ((obarray expiry-hashtb))
|
|
|
1293 (read (current-buffer))))
|
|
|
1294 (if (boundp sym)
|
|
|
1295 (set sym (cons (cons (read (current-buffer)) (point))
|
|
|
1296 (symbol-value sym)))
|
|
|
1297 (set sym (list (cons (read (current-buffer)) (point)))))
|
|
|
1298 (skip-chars-forward " "))
|
|
|
1299 (forward-line 1)))
|
|
|
1300 ;; We now have all articles that can possibly be expired.
|
|
|
1301 (mapatoms
|
|
|
1302 (lambda (sym)
|
|
|
1303 (setq group (symbol-name sym)
|
|
|
1304 articles (sort (symbol-value sym) 'car-less-than-car)
|
|
|
1305 low (car (gnus-active group))
|
|
|
1306 info (gnus-get-info group)
|
|
|
1307 unreads (ignore-errors (gnus-list-of-unread-articles group))
|
|
|
1308 marked (nconc (gnus-uncompress-range
|
|
|
1309 (cdr (assq 'tick (gnus-info-marks info))))
|
|
|
1310 (gnus-uncompress-range
|
|
|
1311 (cdr (assq 'dormant
|
|
|
1312 (gnus-info-marks info)))))
|
|
|
1313 nov-file (gnus-agent-article-name ".overview" group))
|
|
|
1314 (when info
|
|
|
1315 (gnus-agent-load-alist group)
|
|
|
1316 (gnus-message 5 "Expiring articles in %s" group)
|
|
|
1317 (set-buffer overview)
|
|
|
1318 (erase-buffer)
|
|
|
1319 (when (file-exists-p nov-file)
|
|
|
1320 (nnheader-insert-file-contents nov-file))
|
|
|
1321 (goto-char (point-min))
|
|
|
1322 (setq article 0)
|
|
|
1323 (while (setq elem (pop articles))
|
|
|
1324 (setq article (car elem))
|
|
|
1325 (when (or (null low)
|
|
|
1326 (< article low)
|
|
|
1327 gnus-agent-expire-all
|
|
|
1328 (and (not (memq article unreads))
|
|
|
1329 (not (memq article marked))))
|
|
|
1330 ;; Find and nuke the NOV line.
|
|
|
1331 (while (and (not (eobp))
|
|
|
1332 (or (not (numberp
|
|
|
1333 (setq art (read (current-buffer)))))
|
|
|
1334 (< art article)))
|
|
|
1335 (if (file-exists-p
|
|
|
1336 (gnus-agent-article-name
|
|
|
1337 (number-to-string art) group))
|
|
|
1338 (forward-line 1)
|
|
|
1339 ;; Remove old NOV lines that have no articles.
|
|
|
1340 (gnus-delete-line)))
|
|
|
1341 (if (or (eobp)
|
|
|
1342 (/= art article))
|
|
|
1343 (beginning-of-line)
|
|
|
1344 (gnus-delete-line))
|
|
|
1345 ;; Nuke the article.
|
|
|
1346 (when (file-exists-p (setq file (gnus-agent-article-name
|
|
|
1347 (number-to-string article)
|
|
|
1348 group)))
|
|
|
1349 (delete-file file))
|
|
|
1350 ;; Schedule the history line for nuking.
|
|
|
1351 (push (cdr elem) histories)))
|
|
|
1352 (gnus-make-directory (file-name-directory nov-file))
|
|
|
1353 (let ((coding-system-for-write
|
|
|
1354 gnus-agent-file-coding-system))
|
|
|
1355 (write-region (point-min) (point-max) nov-file nil 'silent))
|
|
|
1356 ;; Delete the unwanted entries in the alist.
|
|
|
1357 (setq gnus-agent-article-alist
|
|
|
1358 (sort gnus-agent-article-alist 'car-less-than-car))
|
|
|
1359 (let* ((alist gnus-agent-article-alist)
|
|
|
1360 (prev (cons nil alist))
|
|
|
1361 (first prev)
|
|
|
1362 expired)
|
|
|
1363 (while (and alist
|
|
|
1364 (<= (caar alist) article))
|
|
|
1365 (if (or (not (cdar alist))
|
|
|
1366 (not (file-exists-p
|
|
|
1367 (gnus-agent-article-name
|
|
|
1368 (number-to-string
|
|
|
1369 (caar alist))
|
|
|
1370 group))))
|
|
|
1371 (progn
|
|
|
1372 (push (caar alist) expired)
|
|
|
1373 (setcdr prev (setq alist (cdr alist))))
|
|
|
1374 (setq prev alist
|
|
|
1375 alist (cdr alist))))
|
|
|
1376 (setq gnus-agent-article-alist (cdr first))
|
|
|
1377 (gnus-agent-save-alist group)
|
|
|
1378 ;; Mark all articles up to the first article
|
|
|
1379 ;; in `gnus-article-alist' as read.
|
|
|
1380 (when (and info (caar gnus-agent-article-alist))
|
|
|
1381 (setcar (nthcdr 2 info)
|
|
|
1382 (gnus-range-add
|
|
|
1383 (nth 2 info)
|
|
|
1384 (cons 1 (- (caar gnus-agent-article-alist) 1)))))
|
|
|
1385 ;; Maybe everything has been expired from `gnus-article-alist'
|
|
|
1386 ;; and so the above marking as read could not be conducted,
|
|
|
1387 ;; or there are expired article within the range of the alist.
|
|
|
1388 (when (and (car expired)
|
|
|
1389 (or (not (caar gnus-agent-article-alist))
|
|
|
1390 (> (car expired)
|
|
|
1391 (caar gnus-agent-article-alist))) )
|
|
|
1392 (setcar (nthcdr 2 info)
|
|
|
1393 (gnus-add-to-range
|
|
|
1394 (nth 2 info)
|
|
|
1395 (nreverse expired))))
|
|
|
1396 (gnus-dribble-enter
|
|
|
1397 (concat "(gnus-group-set-info '"
|
|
|
1398 (gnus-prin1-to-string info)
|
|
|
1399 ")")))))
|
|
|
1400 expiry-hashtb)
|
|
|
1401 (set-buffer history)
|
|
|
1402 (setq histories (nreverse (sort histories '<)))
|
|
|
1403 (while histories
|
|
|
1404 (goto-char (pop histories))
|
|
|
1405 (gnus-delete-line))
|
|
|
1406 (gnus-agent-save-history)
|
|
|
1407 (gnus-agent-close-history))
|
|
|
1408 (gnus-message 4 "Expiry...done"))))))
|
|
|
1409
|
|
|
1410 ;;;###autoload
|
|
|
1411 (defun gnus-agent-batch ()
|
|
|
1412 (interactive)
|
|
|
1413 (let ((init-file-user "")
|
|
|
1414 (gnus-always-read-dribble-file t))
|
|
|
1415 (gnus))
|
|
|
1416 (gnus-group-send-drafts)
|
|
|
1417 (gnus-agent-fetch-session))
|
|
|
1418
|
|
|
1419 (provide 'gnus-agent)
|
|
|
1420
|
|
|
1421 ;;; gnus-agent.el ends here
|
