114 |
:group 'gnus-agent |
:group 'gnus-agent |
115 |
:type 'function) |
:type 'function) |
116 |
|
|
117 |
(defcustom gnus-agent-synchronize-flags 'ask |
(defcustom gnus-agent-synchronize-flags nil |
118 |
"Indicate if flags are synchronized when you plug in. |
"Indicate if flags are synchronized when you plug in. |
119 |
If this is `ask' the hook will query the user." |
If this is `ask' the hook will query the user." |
120 |
:version "21.1" |
:version "21.1" |
362 |
(gnus-agent-cat-defaccessor |
(gnus-agent-cat-defaccessor |
363 |
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) |
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) |
364 |
|
|
365 |
|
|
366 |
|
;; This form is equivalent to defsetf except that it calls make-symbol |
367 |
|
;; whereas defsetf calls gensym (Using gensym creates a run-time |
368 |
|
;; dependency on the CL library). |
369 |
|
|
370 |
(eval-and-compile |
(eval-and-compile |
371 |
(defsetf gnus-agent-cat-groups (category) (groups) |
(define-setf-method gnus-agent-cat-groups (category) |
372 |
(list 'gnus-agent-set-cat-groups category groups))) |
(let* ((--category--temp-- (make-symbol "--category--")) |
373 |
|
(--groups--temp-- (make-symbol "--groups--"))) |
374 |
|
(list (list --category--temp--) |
375 |
|
(list category) |
376 |
|
(list --groups--temp--) |
377 |
|
(let* ((category --category--temp--) |
378 |
|
(groups --groups--temp--)) |
379 |
|
(list (quote gnus-agent-set-cat-groups) category groups)) |
380 |
|
(list (quote gnus-agent-cat-groups) --category--temp--)))) |
381 |
|
) |
382 |
|
|
383 |
(defun gnus-agent-set-cat-groups (category groups) |
(defun gnus-agent-set-cat-groups (category groups) |
384 |
(unless (eq groups 'ignore) |
(unless (eq groups 'ignore) |
638 |
(unless gnus-agent-send-mail-function |
(unless gnus-agent-send-mail-function |
639 |
(setq gnus-agent-send-mail-function |
(setq gnus-agent-send-mail-function |
640 |
(or message-send-mail-real-function |
(or message-send-mail-real-function |
641 |
message-send-mail-function) |
(function (lambda () (funcall message-send-mail-function)))) |
642 |
message-send-mail-real-function 'gnus-agent-send-mail)) |
message-send-mail-real-function 'gnus-agent-send-mail)) |
643 |
|
|
644 |
;; If the servers file doesn't exist, auto-agentize some servers and |
;; If the servers file doesn't exist, auto-agentize some servers and |
804 |
(interactive) |
(interactive) |
805 |
(save-excursion |
(save-excursion |
806 |
(dolist (gnus-command-method (gnus-agent-covered-methods)) |
(dolist (gnus-command-method (gnus-agent-covered-methods)) |
807 |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
(when (and (file-exists-p (gnus-agent-lib-file "flags")) |
808 |
|
(not (eq (gnus-server-status gnus-command-method) 'offline))) |
809 |
(gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) |
(gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) |
810 |
|
|
811 |
(defun gnus-agent-synchronize-flags-server (method) |
(defun gnus-agent-synchronize-flags-server (method) |
812 |
"Synchronize flags set when unplugged for server." |
"Synchronize flags set when unplugged for server." |
813 |
(let ((gnus-command-method method)) |
(let ((gnus-command-method method) |
814 |
|
(gnus-agent nil)) |
815 |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
816 |
(set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) |
(set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) |
817 |
(erase-buffer) |
(erase-buffer) |
818 |
(nnheader-insert-file-contents (gnus-agent-lib-file "flags")) |
(nnheader-insert-file-contents (gnus-agent-lib-file "flags")) |
819 |
(if (null (gnus-check-server gnus-command-method)) |
(cond ((null gnus-plugged) |
820 |
(gnus-message 1 "Couldn't open server %s" (nth 1 gnus-command-method)) |
(gnus-message |
821 |
(while (not (eobp)) |
1 "You must be plugged to synchronize flags with server %s" |
822 |
(if (null (eval (read (current-buffer)))) |
(nth 1 gnus-command-method))) |
823 |
(gnus-delete-line) |
((null (gnus-check-server gnus-command-method)) |
824 |
(write-file (gnus-agent-lib-file "flags")) |
(gnus-message |
825 |
(error "Couldn't set flags from file %s" |
1 "Couldn't open server %s" (nth 1 gnus-command-method))) |
826 |
(gnus-agent-lib-file "flags")))) |
(t |
827 |
(delete-file (gnus-agent-lib-file "flags"))) |
(condition-case err |
828 |
|
(while t |
829 |
|
(let ((bgn (point))) |
830 |
|
(eval (read (current-buffer))) |
831 |
|
(delete-region bgn (point)))) |
832 |
|
(end-of-file |
833 |
|
(delete-file (gnus-agent-lib-file "flags"))) |
834 |
|
(error |
835 |
|
(let ((file (gnus-agent-lib-file "flags"))) |
836 |
|
(write-region (point-min) (point-max) |
837 |
|
(gnus-agent-lib-file "flags") nil 'silent) |
838 |
|
(error "Couldn't set flags from file %s due to %s" |
839 |
|
file (error-message-string err))))))) |
840 |
(kill-buffer nil)))) |
(kill-buffer nil)))) |
841 |
|
|
842 |
(defun gnus-agent-possibly-synchronize-flags-server (method) |
(defun gnus-agent-possibly-synchronize-flags-server (method) |
848 |
(cadr method))))) |
(cadr method))))) |
849 |
(gnus-agent-synchronize-flags-server method))) |
(gnus-agent-synchronize-flags-server method))) |
850 |
|
|
851 |
|
;;;###autoload |
852 |
|
(defun gnus-agent-rename-group (old-group new-group) |
853 |
|
"Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when |
854 |
|
disabled, as the old agent files would corrupt gnus when the agent was |
855 |
|
next enabled. Depends upon the caller to determine whether group renaming is supported." |
856 |
|
(let* ((old-command-method (gnus-find-method-for-group old-group)) |
857 |
|
(old-path (directory-file-name |
858 |
|
(let (gnus-command-method old-command-method) |
859 |
|
(gnus-agent-group-pathname old-group)))) |
860 |
|
(new-command-method (gnus-find-method-for-group new-group)) |
861 |
|
(new-path (directory-file-name |
862 |
|
(let (gnus-command-method new-command-method) |
863 |
|
(gnus-agent-group-pathname new-group))))) |
864 |
|
(gnus-rename-file old-path new-path t) |
865 |
|
|
866 |
|
(let* ((old-real-group (gnus-group-real-name old-group)) |
867 |
|
(new-real-group (gnus-group-real-name new-group)) |
868 |
|
(old-active (gnus-agent-get-group-info old-command-method old-real-group))) |
869 |
|
(gnus-agent-save-group-info old-command-method old-real-group nil) |
870 |
|
(gnus-agent-save-group-info new-command-method new-real-group old-active) |
871 |
|
|
872 |
|
(let ((old-local (gnus-agent-get-local old-group |
873 |
|
old-real-group old-command-method))) |
874 |
|
(gnus-agent-set-local old-group |
875 |
|
nil nil |
876 |
|
old-real-group old-command-method) |
877 |
|
(gnus-agent-set-local new-group |
878 |
|
(car old-local) (cdr old-local) |
879 |
|
new-real-group new-command-method))))) |
880 |
|
|
881 |
|
;;;###autoload |
882 |
|
(defun gnus-agent-delete-group (group) |
883 |
|
"Delete fully-qualified GROUP. Always updates the agent, even when |
884 |
|
disabled, as the old agent files would corrupt gnus when the agent was |
885 |
|
next enabled. Depends upon the caller to determine whether group deletion is supported." |
886 |
|
(let* ((command-method (gnus-find-method-for-group group)) |
887 |
|
(path (directory-file-name |
888 |
|
(let (gnus-command-method command-method) |
889 |
|
(gnus-agent-group-pathname group))))) |
890 |
|
(gnus-delete-file path) |
891 |
|
|
892 |
|
(let* ((real-group (gnus-group-real-name group))) |
893 |
|
(gnus-agent-save-group-info command-method real-group nil) |
894 |
|
|
895 |
|
(let ((local (gnus-agent-get-local group |
896 |
|
real-group command-method))) |
897 |
|
(gnus-agent-set-local group |
898 |
|
nil nil |
899 |
|
real-group command-method))))) |
900 |
|
|
901 |
;;; |
;;; |
902 |
;;; Server mode commands |
;;; Server mode commands |
903 |
;;; |
;;; |
1047 |
gnus-downloadable-mark) |
gnus-downloadable-mark) |
1048 |
'unread)))) |
'unread)))) |
1049 |
|
|
1050 |
|
;;;###autoload |
1051 |
(defun gnus-agent-get-undownloaded-list () |
(defun gnus-agent-get-undownloaded-list () |
1052 |
"Construct list of articles that have not been downloaded." |
"Construct list of articles that have not been downloaded." |
1053 |
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) |
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) |
1192 |
;;; Internal functions |
;;; Internal functions |
1193 |
;;; |
;;; |
1194 |
|
|
1195 |
|
(defun gnus-agent-synchronize-group-flags (group actions server) |
1196 |
|
"Update a plugged group by performing the indicated actions." |
1197 |
|
(let* ((gnus-command-method (gnus-server-to-method server)) |
1198 |
|
(info |
1199 |
|
;; This initializer is required as gnus-request-set-mark |
1200 |
|
;; calls gnus-group-real-name to strip off the host name |
1201 |
|
;; before calling the backend. Now that the backend is |
1202 |
|
;; trying to call gnus-request-set-mark, I have to |
1203 |
|
;; reconstruct the original group name. |
1204 |
|
(or (gnus-get-info group) |
1205 |
|
(gnus-get-info |
1206 |
|
(setq group (gnus-group-full-name |
1207 |
|
group gnus-command-method)))))) |
1208 |
|
(gnus-request-set-mark group actions) |
1209 |
|
|
1210 |
|
(when info |
1211 |
|
(dolist (action actions) |
1212 |
|
(let ((range (nth 0 action)) |
1213 |
|
(what (nth 1 action)) |
1214 |
|
(marks (nth 2 action))) |
1215 |
|
(dolist (mark marks) |
1216 |
|
(cond ((eq mark 'read) |
1217 |
|
(gnus-info-set-read |
1218 |
|
info |
1219 |
|
(funcall (if (eq what 'add) |
1220 |
|
'gnus-range-add |
1221 |
|
'gnus-remove-from-range) |
1222 |
|
(gnus-info-read info) |
1223 |
|
range)) |
1224 |
|
(gnus-get-unread-articles-in-group |
1225 |
|
info |
1226 |
|
(gnus-active (gnus-info-group info)))) |
1227 |
|
((memq mark '(tick)) |
1228 |
|
(let ((info-marks (assoc mark (gnus-info-marks info)))) |
1229 |
|
(unless info-marks |
1230 |
|
(gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info)))) |
1231 |
|
(setcdr info-marks (funcall (if (eq what 'add) |
1232 |
|
'gnus-range-add |
1233 |
|
'gnus-remove-from-range) |
1234 |
|
(cdr info-marks) |
1235 |
|
range))))))))) |
1236 |
|
nil)) |
1237 |
|
|
1238 |
(defun gnus-agent-save-active (method) |
(defun gnus-agent-save-active (method) |
1239 |
(when (gnus-agent-method-p method) |
(when (gnus-agent-method-p method) |
1240 |
(let* ((gnus-command-method method) |
(let* ((gnus-command-method method) |
1253 |
;; will add it while reading the file. |
;; will add it while reading the file. |
1254 |
(gnus-write-active-file file new nil))) |
(gnus-write-active-file file new nil))) |
1255 |
|
|
1256 |
|
;;;###autoload |
1257 |
(defun gnus-agent-possibly-alter-active (group active &optional info) |
(defun gnus-agent-possibly-alter-active (group active &optional info) |
1258 |
"Possibly expand a group's active range to include articles |
"Possibly expand a group's active range to include articles |
1259 |
downloaded into the agent." |
downloaded into the agent." |
1306 |
(defun gnus-agent-save-group-info (method group active) |
(defun gnus-agent-save-group-info (method group active) |
1307 |
"Update a single group's active range in the agent's copy of the server's active file." |
"Update a single group's active range in the agent's copy of the server's active file." |
1308 |
(when (gnus-agent-method-p method) |
(when (gnus-agent-method-p method) |
1309 |
(let* ((gnus-command-method method) |
(let* ((gnus-command-method (or method gnus-command-method)) |
1310 |
(coding-system-for-write nnheader-file-coding-system) |
(coding-system-for-write nnheader-file-coding-system) |
1311 |
(file-name-coding-system nnmail-pathname-coding-system) |
(file-name-coding-system nnmail-pathname-coding-system) |
1312 |
(file (gnus-agent-lib-file "active")) |
(file (gnus-agent-lib-file "active")) |
1322 |
(when (re-search-forward |
(when (re-search-forward |
1323 |
(concat "^" (regexp-quote group) " ") nil t) |
(concat "^" (regexp-quote group) " ") nil t) |
1324 |
(save-excursion |
(save-excursion |
1325 |
(setq oactive-max (read (current-buffer)) ;; max |
(setq oactive-max (read (current-buffer)) ;; max |
1326 |
oactive-min (read (current-buffer)))) ;; min |
oactive-min (read (current-buffer)))) ;; min |
1327 |
(gnus-delete-line))) |
(gnus-delete-line))) |
1328 |
(insert (format "%S %d %d y\n" (intern group) |
(when active |
1329 |
(max (or oactive-max (cdr active)) (cdr active)) |
(insert (format "%S %d %d y\n" (intern group) |
1330 |
(min (or oactive-min (car active)) (car active)))) |
(max (or oactive-max (cdr active)) (cdr active)) |
1331 |
(goto-char (point-max)) |
(min (or oactive-min (car active)) (car active)))) |
1332 |
(while (search-backward "\\." nil t) |
(goto-char (point-max)) |
1333 |
(delete-char 1)))))) |
(while (search-backward "\\." nil t) |
1334 |
|
(delete-char 1))))))) |
1335 |
|
|
1336 |
|
(defun gnus-agent-get-group-info (method group) |
1337 |
|
"Get a single group's active range in the agent's copy of the server's active file." |
1338 |
|
(when (gnus-agent-method-p method) |
1339 |
|
(let* ((gnus-command-method (or method gnus-command-method)) |
1340 |
|
(coding-system-for-write nnheader-file-coding-system) |
1341 |
|
(file-name-coding-system nnmail-pathname-coding-system) |
1342 |
|
(file (gnus-agent-lib-file "active")) |
1343 |
|
oactive-min oactive-max) |
1344 |
|
(gnus-make-directory (file-name-directory file)) |
1345 |
|
(with-temp-buffer |
1346 |
|
;; Emacs got problem to match non-ASCII group in multibyte buffer. |
1347 |
|
(mm-disable-multibyte) |
1348 |
|
(when (file-exists-p file) |
1349 |
|
(nnheader-insert-file-contents file) |
1350 |
|
|
1351 |
|
(goto-char (point-min)) |
1352 |
|
(when (re-search-forward |
1353 |
|
(concat "^" (regexp-quote group) " ") nil t) |
1354 |
|
(save-excursion |
1355 |
|
(setq oactive-max (read (current-buffer)) ;; max |
1356 |
|
oactive-min (read (current-buffer))) ;; min |
1357 |
|
(cons oactive-min oactive-max)))))))) |
1358 |
|
|
1359 |
(defun gnus-agent-group-path (group) |
(defun gnus-agent-group-path (group) |
1360 |
"Translate GROUP into a file name." |
"Translate GROUP into a file name." |
1560 |
(gnus-message 7 "")) |
(gnus-message 7 "")) |
1561 |
(cdr fetched-articles)))))) |
(cdr fetched-articles)))))) |
1562 |
|
|
1563 |
|
(defun gnus-agent-unfetch-articles (group articles) |
1564 |
|
"Delete ARTICLES that were fetched from GROUP into the agent." |
1565 |
|
(when articles |
1566 |
|
(gnus-agent-load-alist group) |
1567 |
|
(let* ((alist (cons nil gnus-agent-article-alist)) |
1568 |
|
(articles (sort articles #'<)) |
1569 |
|
(next-possibility alist) |
1570 |
|
(delete-this (pop articles))) |
1571 |
|
(while (and (cdr next-possibility) delete-this) |
1572 |
|
(let ((have-this (caar (cdr next-possibility)))) |
1573 |
|
(cond ((< delete-this have-this) |
1574 |
|
(setq delete-this (pop articles))) |
1575 |
|
((= delete-this have-this) |
1576 |
|
(let ((timestamp (cdar (cdr next-possibility)))) |
1577 |
|
(when timestamp |
1578 |
|
(let* ((file-name (concat (gnus-agent-group-pathname group) |
1579 |
|
(number-to-string have-this)))) |
1580 |
|
(delete-file file-name)))) |
1581 |
|
|
1582 |
|
(setcdr next-possibility (cddr next-possibility))) |
1583 |
|
(t |
1584 |
|
(setq next-possibility (cdr next-possibility)))))) |
1585 |
|
(setq gnus-agent-article-alist (cdr alist)) |
1586 |
|
(gnus-agent-save-alist group)))) |
1587 |
|
|
1588 |
(defun gnus-agent-crosspost (crosses article &optional date) |
(defun gnus-agent-crosspost (crosses article &optional date) |
1589 |
(setq date (or date t)) |
(setq date (or date t)) |
1590 |
|
|
1659 |
(setq backed-up (gnus-agent-backup-overview-buffer))) |
(setq backed-up (gnus-agent-backup-overview-buffer))) |
1660 |
(gnus-message 1 |
(gnus-message 1 |
1661 |
"Duplicate overview line for %d" cur) |
"Duplicate overview line for %d" cur) |
1662 |
(delete-region (point) (progn (forward-line 1) (point)))) |
(delete-region p (progn (forward-line 1) (point)))) |
1663 |
((< cur prev-num) |
((< cur prev-num) |
1664 |
(or backed-up |
(or backed-up |
1665 |
(setq backed-up (gnus-agent-backup-overview-buffer))) |
(setq backed-up (gnus-agent-backup-overview-buffer))) |
1691 |
(insert "\n")) |
(insert "\n")) |
1692 |
(setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) |
(setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) |
1693 |
|
|
1694 |
|
;;;###autoload |
1695 |
(defun gnus-agent-find-parameter (group symbol) |
(defun gnus-agent-find-parameter (group symbol) |
1696 |
"Search for GROUPs SYMBOL in the group's parameters, the group's |
"Search for GROUPs SYMBOL in the group's parameters, the group's |
1697 |
topic parameters, the group's category, or the customizable |
topic parameters, the group's category, or the customizable |
1796 |
;; of FILE. |
;; of FILE. |
1797 |
(copy-to-buffer |
(copy-to-buffer |
1798 |
gnus-agent-overview-buffer (point-min) (point-max)) |
gnus-agent-overview-buffer (point-min) (point-max)) |
1799 |
(when (file-exists-p file) |
;; NOTE: Call g-a-brand-nov even when the file does not |
1800 |
(gnus-agent-braid-nov group articles file)) |
;; exist. As a minimum, it will validate the article |
1801 |
|
;; numbers already in the buffer. |
1802 |
|
(gnus-agent-braid-nov group articles file) |
1803 |
(let ((coding-system-for-write |
(let ((coding-system-for-write |
1804 |
gnus-agent-file-coding-system)) |
gnus-agent-file-coding-system)) |
1805 |
(gnus-agent-check-overview-buffer) |
(gnus-agent-check-overview-buffer) |
1811 |
(nnheader-insert-file-contents file))))) |
(nnheader-insert-file-contents file))))) |
1812 |
articles)) |
articles)) |
1813 |
|
|
1814 |
|
(defsubst gnus-agent-read-article-number () |
1815 |
|
"Reads the article number at point. Returns nil when a valid article number can not be read." |
1816 |
|
|
1817 |
|
;; It is unfortunite but the read function quietly overflows |
1818 |
|
;; integer. As a result, I have to use string operations to test |
1819 |
|
;; for overflow BEFORE calling read. |
1820 |
|
(when (looking-at "[0-9]+\t") |
1821 |
|
(let ((len (- (match-end 0) (match-beginning 0)))) |
1822 |
|
(cond ((< len 9) |
1823 |
|
(read (current-buffer))) |
1824 |
|
((= len 9) |
1825 |
|
;; Many 9 digit base-10 numbers can be represented in a 27-bit int |
1826 |
|
;; Back convert from int to string to ensure that this is one of them. |
1827 |
|
(let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0)))) |
1828 |
|
(num (read (current-buffer))) |
1829 |
|
(str2 (int-to-string num))) |
1830 |
|
(when (equal str1 str2) |
1831 |
|
num))))))) |
1832 |
|
|
1833 |
(defsubst gnus-agent-copy-nov-line (article) |
(defsubst gnus-agent-copy-nov-line (article) |
1834 |
|
"Copy the indicated ARTICLE from the overview buffer to the nntp server buffer." |
1835 |
(let (art b e) |
(let (art b e) |
1836 |
(set-buffer gnus-agent-overview-buffer) |
(set-buffer gnus-agent-overview-buffer) |
1837 |
(while (and (not (eobp)) |
(while (and (not (eobp)) |
1838 |
(< (setq art (read (current-buffer))) article)) |
(or (not (setq art (gnus-agent-read-article-number))) |
1839 |
|
(< art article))) |
1840 |
(forward-line 1)) |
(forward-line 1)) |
1841 |
(beginning-of-line) |
(beginning-of-line) |
1842 |
(if (or (eobp) |
(if (or (eobp) |
1849 |
|
|
1850 |
(defun gnus-agent-braid-nov (group articles file) |
(defun gnus-agent-braid-nov (group articles file) |
1851 |
"Merge agent overview data with given file. |
"Merge agent overview data with given file. |
1852 |
Takes headers for ARTICLES from `gnus-agent-overview-buffer' and the given |
Takes unvalidated headers for ARTICLES from |
1853 |
FILE and places the combined headers into `nntp-server-buffer'." |
`gnus-agent-overview-buffer' and validated headers from the given |
1854 |
|
FILE and places the combined valid headers into |
1855 |
|
`nntp-server-buffer'. This function can be used, when file |
1856 |
|
doesn't exist, to valid the overview buffer." |
1857 |
(let (start last) |
(let (start last) |
1858 |
(set-buffer gnus-agent-overview-buffer) |
(set-buffer gnus-agent-overview-buffer) |
1859 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1860 |
(set-buffer nntp-server-buffer) |
(set-buffer nntp-server-buffer) |
1861 |
(erase-buffer) |
(erase-buffer) |
1862 |
(nnheader-insert-file-contents file) |
(when (file-exists-p file) |
1863 |
|
(nnheader-insert-file-contents file)) |
1864 |
(goto-char (point-max)) |
(goto-char (point-max)) |
1865 |
(forward-line -1) |
(forward-line -1) |
1866 |
(unless (looking-at "[0-9]+\t") |
|
|
;; Remove corrupted lines |
|
|
(gnus-message |
|
|
1 "Overview %s is corrupted. Removing corrupted lines..." file) |
|
|
(goto-char (point-min)) |
|
|
(while (not (eobp)) |
|
|
(if (looking-at "[0-9]+\t") |
|
|
(forward-line 1) |
|
|
(delete-region (point) (progn (forward-line 1) (point))))) |
|
|
(forward-line -1)) |
|
1867 |
(unless (or (= (point-min) (point-max)) |
(unless (or (= (point-min) (point-max)) |
1868 |
(< (setq last (read (current-buffer))) (car articles))) |
(< (setq last (read (current-buffer))) (car articles))) |
1869 |
;; We do it the hard way. |
;; Old and new overlap -- We do it the hard way. |
1870 |
(when (nnheader-find-nov-line (car articles)) |
(when (nnheader-find-nov-line (car articles)) |
1871 |
;; Replacing existing NOV entry |
;; Replacing existing NOV entry |
1872 |
(delete-region (point) (progn (forward-line 1) (point)))) |
(delete-region (point) (progn (forward-line 1) (point)))) |
1873 |
(gnus-agent-copy-nov-line (pop articles)) |
(gnus-agent-copy-nov-line (pop articles)) |
1874 |
|
|
1875 |
(ignore-errors |
(ignore-errors |
1876 |
(while articles |
(while articles |
1877 |
(while (let ((art (read (current-buffer)))) |
(while (let ((art (read (current-buffer)))) |
1878 |
(cond ((< art (car articles)) |
(cond ((< art (car articles)) |
1879 |
(forward-line 1) |
(forward-line 1) |
1880 |
t) |
t) |
1881 |
((= art (car articles)) |
((= art (car articles)) |
1882 |
(beginning-of-line) |
(beginning-of-line) |
1883 |
(delete-region |
(delete-region |
1884 |
(point) (progn (forward-line 1) (point))) |
(point) (progn (forward-line 1) (point))) |
1885 |
nil) |
nil) |
1886 |
(t |
(t |
1887 |
(beginning-of-line) |
(beginning-of-line) |
1888 |
nil)))) |
nil)))) |
1889 |
|
|
1890 |
(gnus-agent-copy-nov-line (pop articles))))) |
(gnus-agent-copy-nov-line (pop articles))))) |
1891 |
|
|
|
;; Copy the rest lines |
|
|
(set-buffer nntp-server-buffer) |
|
1892 |
(goto-char (point-max)) |
(goto-char (point-max)) |
1893 |
|
|
1894 |
|
;; Append the remaining lines |
1895 |
(when articles |
(when articles |
1896 |
(when last |
(when last |
1897 |
(set-buffer gnus-agent-overview-buffer) |
(set-buffer gnus-agent-overview-buffer) |
|
(ignore-errors |
|
|
(while (<= (read (current-buffer)) last) |
|
|
(forward-line 1))) |
|
|
(beginning-of-line) |
|
1898 |
(setq start (point)) |
(setq start (point)) |
1899 |
(set-buffer nntp-server-buffer)) |
(set-buffer nntp-server-buffer)) |
1900 |
(insert-buffer-substring gnus-agent-overview-buffer start)))) |
|
1901 |
|
(let ((p (point))) |
1902 |
|
(insert-buffer-substring gnus-agent-overview-buffer start) |
1903 |
|
(goto-char p)) |
1904 |
|
|
1905 |
|
(setq last (or last -134217728)) |
1906 |
|
(let (sort art) |
1907 |
|
(while (not (eobp)) |
1908 |
|
(setq art (gnus-agent-read-article-number)) |
1909 |
|
(cond ((not art) |
1910 |
|
;; Bad art num - delete this line |
1911 |
|
(beginning-of-line) |
1912 |
|
(delete-region (point) (progn (forward-line 1) (point)))) |
1913 |
|
((< art last) |
1914 |
|
;; Art num out of order - enable sort |
1915 |
|
(setq sort t) |
1916 |
|
(forward-line 1)) |
1917 |
|
(t |
1918 |
|
;; Good art num |
1919 |
|
(setq last art) |
1920 |
|
(forward-line 1)))) |
1921 |
|
(when sort |
1922 |
|
(sort-numeric-fields 1 (point-min) (point-max))))))) |
1923 |
|
|
1924 |
;; Keeps the compiler from warning about the free variable in |
;; Keeps the compiler from warning about the free variable in |
1925 |
;; gnus-agent-read-agentview. |
;; gnus-agent-read-agentview. |
1944 |
(defun gnus-agent-read-agentview (file) |
(defun gnus-agent-read-agentview (file) |
1945 |
"Load FILE and do a `read' there." |
"Load FILE and do a `read' there." |
1946 |
(with-temp-buffer |
(with-temp-buffer |
1947 |
(ignore-errors |
(condition-case nil |
1948 |
|
(progn |
1949 |
(nnheader-insert-file-contents file) |
(nnheader-insert-file-contents file) |
1950 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1951 |
(let ((alist (read (current-buffer))) |
(let ((alist (read (current-buffer))) |
1954 |
changed-version) |
changed-version) |
1955 |
|
|
1956 |
(cond |
(cond |
1957 |
|
((< version 2) |
1958 |
|
(error "gnus-agent-read-agentview no longer supports version %d. Stop gnus, manually evaluate gnus-agent-convert-to-compressed-agentview, then restart gnus." version)) |
1959 |
((= version 0) |
((= version 0) |
1960 |
(let ((inhibit-quit t) |
(let ((inhibit-quit t) |
1961 |
entry) |
entry) |
1979 |
(mapcar |
(mapcar |
1980 |
(lambda (comp-list) |
(lambda (comp-list) |
1981 |
(let ((state (car comp-list)) |
(let ((state (car comp-list)) |
1982 |
(sequence (gnus-uncompress-sequence |
(sequence (inline |
1983 |
(cdr comp-list)))) |
(gnus-uncompress-range |
1984 |
|
(cdr comp-list))))) |
1985 |
(mapcar (lambda (article-id) |
(mapcar (lambda (article-id) |
1986 |
(setq uncomp (cons (cons article-id state) uncomp))) |
(setq uncomp (cons (cons article-id state) uncomp))) |
1987 |
sequence))) |
sequence))) |
1990 |
(when changed-version |
(when changed-version |
1991 |
(let ((gnus-agent-article-alist alist)) |
(let ((gnus-agent-article-alist alist)) |
1992 |
(gnus-agent-save-alist gnus-agent-read-agentview))) |
(gnus-agent-save-alist gnus-agent-read-agentview))) |
1993 |
alist)))) |
alist)) |
1994 |
|
(file-error nil)))) |
1995 |
|
|
1996 |
(defun gnus-agent-save-alist (group &optional articles state) |
(defun gnus-agent-save-alist (group &optional articles state) |
1997 |
"Save the article-state alist for GROUP." |
"Save the article-state alist for GROUP." |
2074 |
(line 1)) |
(line 1)) |
2075 |
(with-temp-buffer |
(with-temp-buffer |
2076 |
(condition-case nil |
(condition-case nil |
2077 |
(nnheader-insert-file-contents file) |
(let ((nnheader-file-coding-system gnus-agent-file-coding-system)) |
2078 |
|
(nnheader-insert-file-contents file)) |
2079 |
(file-error)) |
(file-error)) |
2080 |
|
|
2081 |
(goto-char (point-min)) |
(goto-char (point-min)) |
2118 |
;; NOTE: gnus-command-method is used within gnus-agent-lib-file. |
;; NOTE: gnus-command-method is used within gnus-agent-lib-file. |
2119 |
(dest (gnus-agent-lib-file "local"))) |
(dest (gnus-agent-lib-file "local"))) |
2120 |
(gnus-make-directory (gnus-agent-lib-file "")) |
(gnus-make-directory (gnus-agent-lib-file "")) |
2121 |
(with-temp-file dest |
|
2122 |
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) |
(let ((buffer-file-coding-system gnus-agent-file-coding-system)) |
2123 |
(file-name-coding-system nnmail-pathname-coding-system) |
(with-temp-file dest |
2124 |
(coding-system-for-write |
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) |
2125 |
gnus-agent-file-coding-system) |
(file-name-coding-system nnmail-pathname-coding-system) |
2126 |
print-level print-length item article |
print-level print-length item article |
2127 |
(standard-output (current-buffer))) |
(standard-output (current-buffer))) |
2128 |
(mapatoms (lambda (symbol) |
(mapatoms (lambda (symbol) |
2129 |
(cond ((not (boundp symbol)) |
(cond ((not (boundp symbol)) |
2130 |
nil) |
nil) |
2131 |
((member (symbol-name symbol) '("+dirty" "+method")) |
((member (symbol-name symbol) '("+dirty" "+method")) |
2132 |
nil) |
nil) |
2133 |
(t |
(t |
2134 |
(prin1 symbol) |
(prin1 symbol) |
2135 |
(let ((range (symbol-value symbol))) |
(let ((range (symbol-value symbol))) |
2136 |
(princ " ") |
(princ " ") |
2137 |
(princ (car range)) |
(princ (car range)) |
2138 |
(princ " ") |
(princ " ") |
2139 |
(princ (cdr range)) |
(princ (cdr range)) |
2140 |
(princ "\n"))))) |
(princ "\n"))))) |
2141 |
my-obarray))))))) |
my-obarray)))))))) |
2142 |
|
|
2143 |
(defun gnus-agent-get-local (group) |
(defun gnus-agent-get-local (group &optional gmane method) |
2144 |
(let* ((gmane (gnus-group-real-name group)) |
(let* ((gmane (or gmane (gnus-group-real-name group))) |
2145 |
(gnus-command-method (gnus-find-method-for-group group)) |
(gnus-command-method (or method (gnus-find-method-for-group group))) |
2146 |
(local (gnus-agent-load-local)) |
(local (gnus-agent-load-local)) |
2147 |
(symb (intern gmane local)) |
(symb (intern gmane local)) |
2148 |
(minmax (and (boundp symb) (symbol-value symb)))) |
(minmax (and (boundp symb) (symbol-value symb)))) |
2177 |
nil) |
nil) |
2178 |
((and min max) |
((and min max) |
2179 |
(set symb (cons min max)) |
(set symb (cons min max)) |
2180 |
t)) |
t) |
2181 |
|
(t |
2182 |
|
(unintern symb local))) |
2183 |
(set (intern "+dirty" local) t)))) |
(set (intern "+dirty" local) t)))) |
2184 |
|
|
2185 |
(defun gnus-agent-article-name (article group) |
(defun gnus-agent-article-name (article group) |
2229 |
group gnus-command-method) |
group gnus-command-method) |
2230 |
(error |
(error |
2231 |
(unless (funcall gnus-agent-confirmation-function |
(unless (funcall gnus-agent-confirmation-function |
2232 |
(format "Error %s. Continue? " |
(format "Error %s while fetching session. Should gnus continue? " |
2233 |
(error-message-string err))) |
(error-message-string err))) |
2234 |
(error "Cannot fetch articles into the Gnus agent"))) |
(error "Cannot fetch articles into the Gnus agent"))) |
2235 |
(quit |
(quit |
2236 |
|
(gnus-agent-regenerate-group group) |
2237 |
(unless (funcall gnus-agent-confirmation-function |
(unless (funcall gnus-agent-confirmation-function |
2238 |
(format |
(format |
2239 |
"Quit fetching session %s. Continue? " |
"%s while fetching session. Should gnus continue? " |
2240 |
(error-message-string err))) |
(error-message-string err))) |
2241 |
(signal 'quit |
(signal 'quit |
2242 |
"Cannot fetch articles into the Gnus agent"))))))))) |
"Cannot fetch articles into the Gnus agent"))))))))) |
2954 |
(let ((dir (gnus-agent-group-pathname group))) |
(let ((dir (gnus-agent-group-pathname group))) |
2955 |
(when (boundp 'gnus-agent-expire-current-dirs) |
(when (boundp 'gnus-agent-expire-current-dirs) |
2956 |
(set 'gnus-agent-expire-current-dirs |
(set 'gnus-agent-expire-current-dirs |
2957 |
(cons dir |
(cons dir |
2958 |
(symbol-value 'gnus-agent-expire-current-dirs)))) |
(symbol-value 'gnus-agent-expire-current-dirs)))) |
2959 |
|
|
2960 |
(if (and (not force) |
(if (and (not force) |
2961 |
(eq 'DISABLE (gnus-agent-find-parameter group |
(eq 'DISABLE (gnus-agent-find-parameter group |
2962 |
'agent-enable-expiration))) |
'agent-enable-expiration))) |
2963 |
(gnus-message 5 "Expiry skipping over %s" group) |
(gnus-message 5 "Expiry skipping over %s" group) |
2964 |
(gnus-message 5 "Expiring articles in %s" group) |
(gnus-message 5 "Expiring articles in %s" group) |
2965 |
(gnus-agent-load-alist group) |
(gnus-agent-load-alist group) |
2966 |
(let* ((stats (if (boundp 'gnus-agent-expire-stats) |
(let* ((bytes-freed 0) |
2967 |
;; Use the list provided by my caller |
(files-deleted 0) |
2968 |
(symbol-value 'gnus-agent-expire-stats) |
(nov-entries-deleted 0) |
2969 |
;; otherwise use my own temporary list |
(info (gnus-get-info group)) |
2970 |
(list 0 0 0.0))) |
(alist gnus-agent-article-alist) |
2971 |
(info (gnus-get-info group)) |
(day (- (time-to-days (current-time)) |
2972 |
(alist gnus-agent-article-alist) |
(gnus-agent-find-parameter group 'agent-days-until-old))) |
2973 |
(day (- (time-to-days (current-time)) |
(specials (if (and alist |
2974 |
(gnus-agent-find-parameter group 'agent-days-until-old))) |
(not force)) |
2975 |
(specials (if (and alist |
;; This could be a bit of a problem. I need to |
2976 |
(not force)) |
;; keep the last article to avoid refetching |
2977 |
;; This could be a bit of a problem. I need to |
;; headers when using nntp in the backend. At |
2978 |
;; keep the last article to avoid refetching |
;; the same time, if someone uses a backend |
2979 |
;; headers when using nntp in the backend. At |
;; that supports article moving then I may have |
2980 |
;; the same time, if someone uses a backend |
;; to remove the last article to complete the |
2981 |
;; that supports article moving then I may have |
;; move. Right now, I'm going to assume that |
2982 |
;; to remove the last article to complete the |
;; FORCE overrides specials. |
2983 |
;; move. Right now, I'm going to assume that |
(list (caar (last alist))))) |
2984 |
;; FORCE overrides specials. |
(unreads ;; Articles that are excluded from the |
2985 |
(list (caar (last alist))))) |
;; expiration process |
2986 |
(unreads ;; Articles that are excluded from the |
(cond (gnus-agent-expire-all |
2987 |
;; expiration process |
;; All articles are marked read by global decree |
2988 |
(cond (gnus-agent-expire-all |
nil) |
2989 |
;; All articles are marked read by global decree |
((eq articles t) |
2990 |
nil) |
;; All articles are marked read by function |
2991 |
((eq articles t) |
;; parameter |
2992 |
;; All articles are marked read by function |
nil) |
2993 |
;; parameter |
((not articles) |
2994 |
nil) |
;; Unread articles are marked protected from |
2995 |
((not articles) |
;; expiration Don't call |
2996 |
;; Unread articles are marked protected from |
;; gnus-list-of-unread-articles as it returns |
2997 |
;; expiration Don't call |
;; articles that have not been fetched into the |
2998 |
;; gnus-list-of-unread-articles as it returns |
;; agent. |
2999 |
;; articles that have not been fetched into the |
(ignore-errors |
3000 |
;; agent. |
(gnus-agent-unread-articles group))) |
3001 |
(ignore-errors |
(t |
3002 |
(gnus-agent-unread-articles group))) |
;; All articles EXCEPT those named by the caller |
3003 |
(t |
;; are protected from expiration |
3004 |
;; All articles EXCEPT those named by the caller |
(gnus-sorted-difference |
3005 |
;; are protected from expiration |
(gnus-uncompress-range |
3006 |
(gnus-sorted-difference |
(cons (caar alist) |
3007 |
(gnus-uncompress-range |
(caar (last alist)))) |
3008 |
(cons (caar alist) |
(sort articles '<))))) |
3009 |
(caar (last alist)))) |
(marked ;; More articles that are excluded from the |
3010 |
(sort articles '<))))) |
;; expiration process |
3011 |
(marked ;; More articles that are excluded from the |
(cond (gnus-agent-expire-all |
3012 |
;; expiration process |
;; All articles are unmarked by global decree |
3013 |
(cond (gnus-agent-expire-all |
nil) |
3014 |
;; All articles are unmarked by global decree |
((eq articles t) |
3015 |
nil) |
;; All articles are unmarked by function |
3016 |
((eq articles t) |
;; parameter |
3017 |
;; All articles are unmarked by function |
nil) |
3018 |
;; parameter |
(articles |
3019 |
nil) |
;; All articles may as well be unmarked as the |
3020 |
(articles |
;; unreads list already names the articles we are |
3021 |
;; All articles may as well be unmarked as the |
;; going to keep |
3022 |
;; unreads list already names the articles we are |
nil) |
3023 |
;; going to keep |
(t |
3024 |
nil) |
;; Ticked and/or dormant articles are excluded |
3025 |
(t |
;; from expiration |
3026 |
;; Ticked and/or dormant articles are excluded |
(nconc |
3027 |
;; from expiration |
(gnus-uncompress-range |
3028 |
(nconc |
(cdr (assq 'tick (gnus-info-marks info)))) |
3029 |
(gnus-uncompress-range |
(gnus-uncompress-range |
3030 |
(cdr (assq 'tick (gnus-info-marks info)))) |
(cdr (assq 'dormant |
3031 |
(gnus-uncompress-range |
(gnus-info-marks info)))))))) |
3032 |
(cdr (assq 'dormant |
(nov-file (concat dir ".overview")) |
3033 |
(gnus-info-marks info)))))))) |
(cnt 0) |
3034 |
(nov-file (concat dir ".overview")) |
(completed -1) |
3035 |
(cnt 0) |
dlist |
3036 |
(completed -1) |
type) |
3037 |
dlist |
|
3038 |
type) |
;; The normal article alist contains elements that look like |
3039 |
|
;; (article# . fetch_date) I need to combine other |
3040 |
;; The normal article alist contains elements that look like |
;; information with this list. For example, a flag indicating |
3041 |
;; (article# . fetch_date) I need to combine other |
;; that a particular article MUST BE KEPT. To do this, I'm |
3042 |
;; information with this list. For example, a flag indicating |
;; going to transform the elements to look like (article# |
3043 |
;; that a particular article MUST BE KEPT. To do this, I'm |
;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse |
3044 |
;; going to transform the elements to look like (article# |
;; the process to generate the expired article alist. |
3045 |
;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse |
|
3046 |
;; the process to generate the expired article alist. |
;; Convert the alist elements to (article# fetch_date nil |
3047 |
|
;; nil). |
3048 |
;; Convert the alist elements to (article# fetch_date nil |
(setq dlist (mapcar (lambda (e) |
3049 |
;; nil). |
(list (car e) (cdr e) nil nil)) alist)) |
3050 |
(setq dlist (mapcar (lambda (e) |
|
3051 |
(list (car e) (cdr e) nil nil)) alist)) |
;; Convert the keep lists to elements that look like (article# |
3052 |
|
;; nil keep_flag nil) then append it to the expanded dlist |
3053 |
;; Convert the keep lists to elements that look like (article# |
;; These statements are sorted by ascending precidence of the |
3054 |
;; nil keep_flag nil) then append it to the expanded dlist |
;; keep_flag. |
3055 |
;; These statements are sorted by ascending precidence of the |
(setq dlist (nconc dlist |
3056 |
;; keep_flag. |
(mapcar (lambda (e) |
3057 |
(setq dlist (nconc dlist |
(list e nil 'unread nil)) |
3058 |
(mapcar (lambda (e) |
unreads))) |
3059 |
(list e nil 'unread nil)) |
(setq dlist (nconc dlist |
3060 |
unreads))) |
(mapcar (lambda (e) |
3061 |
(setq dlist (nconc dlist |
(list e nil 'marked nil)) |
3062 |
(mapcar (lambda (e) |
marked))) |
3063 |
(list e nil 'marked nil)) |
(setq dlist (nconc dlist |
3064 |
marked))) |
(mapcar (lambda (e) |
3065 |
(setq dlist (nconc dlist |
(list e nil 'special nil)) |
3066 |
(mapcar (lambda (e) |
specials))) |
|
(list e nil 'special nil)) |
|
|
specials))) |
|
3067 |
|
|
3068 |
(set-buffer overview) |
(set-buffer overview) |
3069 |
(erase-buffer) |
(erase-buffer) |
3070 |
(buffer-disable-undo) |
(buffer-disable-undo) |
3071 |
(when (file-exists-p nov-file) |
(when (file-exists-p nov-file) |
3072 |
(gnus-message 7 "gnus-agent-expire: Loading overview...") |
(gnus-message 7 "gnus-agent-expire: Loading overview...") |
3073 |
(nnheader-insert-file-contents nov-file) |
(nnheader-insert-file-contents nov-file) |
3074 |
(goto-char (point-min)) |
(goto-char (point-min)) |
3075 |
|
|
3076 |
(let (p) |
(let (p) |
3077 |
(while (< (setq p (point)) (point-max)) |
(while (< (setq p (point)) (point-max)) |
3078 |
(condition-case nil |
(condition-case nil |
3079 |
;; If I successfully read an integer (the plus zero |
;; If I successfully read an integer (the plus zero |
3080 |
;; ensures a numeric type), prepend a marker entry |
;; ensures a numeric type), prepend a marker entry |
3081 |
;; to the list |
;; to the list |
3082 |
(push (list (+ 0 (read (current-buffer))) nil nil |
(push (list (+ 0 (read (current-buffer))) nil nil |
3083 |
(set-marker (make-marker) p)) |
(set-marker (make-marker) p)) |
3084 |
dlist) |
dlist) |
3085 |
(error |
(error |
3086 |
(gnus-message 1 "gnus-agent-expire: read error \ |
(gnus-message 1 "gnus-agent-expire: read error \ |
3087 |
occurred when reading expression at %s in %s. Skipping to next \ |
occurred when reading expression at %s in %s. Skipping to next \ |
3088 |
line." (point) nov-file))) |
line." (point) nov-file))) |
3089 |
;; Whether I succeeded, or failed, it doesn't matter. |
;; Whether I succeeded, or failed, it doesn't matter. |
3090 |
;; Move to the next line then try again. |
;; Move to the next line then try again. |
3091 |
(forward-line 1))) |
(forward-line 1))) |
3092 |
|
|
3093 |
(gnus-message |
(gnus-message |
3094 |
7 "gnus-agent-expire: Loading overview... Done")) |
7 "gnus-agent-expire: Loading overview... Done")) |
3095 |
(set-buffer-modified-p nil) |
(set-buffer-modified-p nil) |
3096 |
|
|
3097 |
;; At this point, all of the information is in dlist. The |
;; At this point, all of the information is in dlist. The |
3098 |
;; only problem is that much of it is spread across multiple |
;; only problem is that much of it is spread across multiple |
3099 |
;; entries. Sort then MERGE!! |
;; entries. Sort then MERGE!! |
3100 |
(gnus-message 7 "gnus-agent-expire: Sorting entries... ") |
(gnus-message 7 "gnus-agent-expire: Sorting entries... ") |
3101 |
;; If two entries have the same article-number then sort by |
;; If two entries have the same article-number then sort by |
3102 |
;; ascending keep_flag. |
;; ascending keep_flag. |
3103 |
(let ((special 0) |
(let ((special 0) |
3104 |
(marked 1) |
(marked 1) |
3105 |
(unread 2)) |
(unread 2)) |
3106 |
(setq dlist |
(setq dlist |
3107 |
(sort dlist |
(sort dlist |
3108 |
(lambda (a b) |
(lambda (a b) |
3109 |
(cond ((< (nth 0 a) (nth 0 b)) |
(cond ((< (nth 0 a) (nth 0 b)) |
3110 |
t) |
t) |
3111 |
((> (nth 0 a) (nth 0 b)) |
((> (nth 0 a) (nth 0 b)) |
3112 |
nil) |
nil) |
3113 |
(t |
(t |
3114 |
(let ((a (or (symbol-value (nth 2 a)) |
(let ((a (or (symbol-value (nth 2 a)) |
3115 |
3)) |
3)) |
3116 |
(b (or (symbol-value (nth 2 b)) |
(b (or (symbol-value (nth 2 b)) |
3117 |
3))) |
3))) |
3118 |
(<= a b)))))))) |
(<= a b)))))))) |
3119 |
(gnus-message 7 "gnus-agent-expire: Sorting entries... Done") |
(gnus-message 7 "gnus-agent-expire: Sorting entries... Done") |
3120 |
(gnus-message 7 "gnus-agent-expire: Merging entries... ") |
(gnus-message 7 "gnus-agent-expire: Merging entries... ") |
3121 |
(let ((dlist dlist)) |
(let ((dlist dlist)) |
3122 |
(while (cdr dlist) ; I'm not at the end-of-list |
(while (cdr dlist) ; I'm not at the end-of-list |
3123 |
(if (eq (caar dlist) (caadr dlist)) |
(if (eq (caar dlist) (caadr dlist)) |
3124 |
(let ((first (cdr (car dlist))) |
(let ((first (cdr (car dlist))) |
3125 |
(secnd (cdr (cadr dlist)))) |
(secnd (cdr (cadr dlist)))) |
3126 |
(setcar first (or (car first) |
(setcar first (or (car first) |
3127 |
(car secnd))) ; fetch_date |
(car secnd))) ; fetch_date |
3128 |
(setq first (cdr first) |
(setq first (cdr first) |
3129 |
secnd (cdr secnd)) |
secnd (cdr secnd)) |
3130 |
(setcar first (or (car first) |
(setcar first (or (car first) |
3131 |
(car secnd))) ; Keep_flag |
(car secnd))) ; Keep_flag |
3132 |
(setq first (cdr first) |
(setq first (cdr first) |
3133 |
secnd (cdr secnd)) |
secnd (cdr secnd)) |
3134 |
(setcar first (or (car first) |
(setcar first (or (car first) |
3135 |
(car secnd))) ; NOV_entry_marker |
(car secnd))) ; NOV_entry_marker |
3136 |
|
|
3137 |
(setcdr dlist (cddr dlist))) |
(setcdr dlist (cddr dlist))) |
3138 |
(setq dlist (cdr dlist))))) |
(setq dlist (cdr dlist))))) |
3139 |
(gnus-message 7 "gnus-agent-expire: Merging entries... Done") |
(gnus-message 7 "gnus-agent-expire: Merging entries... Done") |
3140 |
|
|
3141 |
(let* ((len (float (length dlist))) |
(let* ((len (float (length dlist))) |
3142 |
(alist (list nil)) |
(alist (list nil)) |
3143 |
(tail-alist alist)) |
(tail-alist alist)) |
3144 |
(while dlist |
(while dlist |
3145 |
(let ((new-completed (truncate (* 100.0 |
(let ((new-completed (truncate (* 100.0 |
3146 |
(/ (setq cnt (1+ cnt)) |
(/ (setq cnt (1+ cnt)) |
3147 |
len)))) |
len)))) |
3148 |
message-log-max) |
message-log-max) |
3149 |
(when (> new-completed completed) |
(when (> new-completed completed) |
3150 |
(setq completed new-completed) |
(setq completed new-completed) |
3151 |
(gnus-message 7 "%3d%% completed..." completed))) |
(gnus-message 7 "%3d%% completed..." completed))) |
3152 |
(let* ((entry (car dlist)) |
(let* ((entry (car dlist)) |
3153 |
(article-number (nth 0 entry)) |
(article-number (nth 0 entry)) |
3154 |
(fetch-date (nth 1 entry)) |
(fetch-date (nth 1 entry)) |
3155 |
(keep (nth 2 entry)) |
(keep (nth 2 entry)) |
3156 |
(marker (nth 3 entry))) |
(marker (nth 3 entry))) |
3157 |
|
|
3158 |
(cond |
(cond |
3159 |
;; Kept articles are unread, marked, or special. |
;; Kept articles are unread, marked, or special. |
3160 |
(keep |
(keep |
3161 |
(gnus-agent-message 10 |
(gnus-agent-message 10 |
3162 |
"gnus-agent-expire: %s:%d: Kept %s article%s." |
"gnus-agent-expire: %s:%d: Kept %s article%s." |
3163 |
group article-number keep (if fetch-date " and file" "")) |
group article-number keep (if fetch-date " and file" "")) |
3164 |
(when fetch-date |
(when fetch-date |
3165 |
(unless (file-exists-p |
(unless (file-exists-p |
3166 |
(concat dir (number-to-string |
(concat dir (number-to-string |
3167 |
article-number))) |
article-number))) |
3168 |
(setf (nth 1 entry) nil) |
(setf (nth 1 entry) nil) |
3169 |
(gnus-agent-message 3 "gnus-agent-expire cleared \ |
(gnus-agent-message 3 "gnus-agent-expire cleared \ |
3170 |
download flag on %s:%d as the cached article file is missing." |
download flag on %s:%d as the cached article file is missing." |
3171 |
group (caar dlist))) |
group (caar dlist))) |
3172 |
(unless marker |
(unless marker |
3173 |
(gnus-message 1 "gnus-agent-expire detected a \ |
(gnus-message 1 "gnus-agent-expire detected a \ |
3174 |
missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) |
missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) |
3175 |
(gnus-agent-append-to-list |
(gnus-agent-append-to-list |
3176 |
tail-alist |
tail-alist |
3177 |
(cons article-number fetch-date))) |
(cons article-number fetch-date))) |
3178 |
|
|
3179 |
;; The following articles are READ, UNMARKED, and |
;; The following articles are READ, UNMARKED, and |
3180 |
;; ORDINARY. See if they can be EXPIRED!!! |
;; ORDINARY. See if they can be EXPIRED!!! |
3181 |
((setq type |
((setq type |
3182 |
(cond |
(cond |
3183 |
((not (integerp fetch-date)) |
((not (integerp fetch-date)) |
3184 |
'read) ;; never fetched article (may expire |
'read) ;; never fetched article (may expire |
3185 |
;; right now) |
;; right now) |
3186 |
((not (file-exists-p |
((not (file-exists-p |
3187 |
(concat dir (number-to-string |
(concat dir (number-to-string |
3188 |
article-number)))) |
article-number)))) |
3189 |
(setf (nth 1 entry) nil) |
(setf (nth 1 entry) nil) |
3190 |
'externally-expired) ;; Can't find the cached |
'externally-expired) ;; Can't find the cached |
3191 |
;; article. Handle case |
;; article. Handle case |
3192 |
;; as though this article |
;; as though this article |
3193 |
;; was never fetched. |
;; was never fetched. |
3194 |
|
|
3195 |
;; We now have the arrival day, so we see |
;; We now have the arrival day, so we see |
3196 |
;; whether it's old enough to be expired. |
;; whether it's old enough to be expired. |
3197 |
((< fetch-date day) |
((< fetch-date day) |
3198 |
'expired) |
'expired) |
3199 |
(force |
(force |
3200 |
'forced))) |
'forced))) |
3201 |
|
|
3202 |
;; I found some reason to expire this entry. |
;; I found some reason to expire this entry. |
3203 |
|
|
3204 |
(let ((actions nil)) |
(let ((actions nil)) |
3205 |
(when (memq type '(forced expired)) |
(when (memq type '(forced expired)) |
3206 |
(ignore-errors ; Just being paranoid. |
(ignore-errors ; Just being paranoid. |
3207 |
(let ((file-name (concat dir (number-to-string |
(let* ((file-name (nnheader-concat dir (number-to-string |
3208 |
article-number)))) |
article-number))) |
3209 |
(incf (nth 2 stats) (nth 7 (file-attributes file-name))) |
(size (float (nth 7 (file-attributes file-name))))) |
3210 |
(incf (nth 1 stats)) |
(incf bytes-freed size) |
3211 |
(delete-file file-name)) |
(incf files-deleted) |
3212 |
(push "expired cached article" actions)) |
(delete-file file-name)) |
3213 |
(setf (nth 1 entry) nil) |
(push "expired cached article" actions)) |
3214 |
) |
(setf (nth 1 entry) nil) |
3215 |
|
) |
3216 |
(when marker |
|
3217 |
(push "NOV entry removed" actions) |
(when marker |
3218 |
(goto-char marker) |
(push "NOV entry removed" actions) |
3219 |
|
(goto-char marker) |
3220 |
(incf (nth 0 stats)) |
|
3221 |
|
(incf nov-entries-deleted) |
3222 |
(let ((from (gnus-point-at-bol)) |
|
3223 |
(to (progn (forward-line 1) (point)))) |
(let ((from (gnus-point-at-bol)) |
3224 |
(incf (nth 2 stats) (- to from)) |
(to (progn (forward-line 1) (point)))) |
3225 |
(delete-region from to))) |
(incf bytes-freed (- to from)) |
3226 |
|
(delete-region from to))) |
3227 |
;; If considering all articles is set, I can only |
|
3228 |
;; expire article IDs that are no longer in the |
;; If considering all articles is set, I can only |
3229 |
;; active range (That is, articles that preceed the |
;; expire article IDs that are no longer in the |
3230 |
;; first article in the new alist). |
;; active range (That is, articles that preceed the |
3231 |
(if (and gnus-agent-consider-all-articles |
;; first article in the new alist). |
3232 |
(>= article-number (car active))) |
(if (and gnus-agent-consider-all-articles |
3233 |
;; I have to keep this ID in the alist |
(>= article-number (car active))) |
3234 |
(gnus-agent-append-to-list |
;; I have to keep this ID in the alist |
3235 |
tail-alist (cons article-number fetch-date)) |
(gnus-agent-append-to-list |
3236 |
(push (format "Removed %s article number from \ |
tail-alist (cons article-number fetch-date)) |
3237 |
|
(push (format "Removed %s article number from \ |
3238 |
article alist" type) actions)) |
article alist" type) actions)) |
3239 |
|
|
3240 |
(when actions |
(when actions |
3241 |
(gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" |
(gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" |
3242 |
group article-number |
group article-number |
3243 |
(mapconcat 'identity actions ", "))))) |
(mapconcat 'identity actions ", "))))) |
3244 |
(t |
(t |
3245 |
(gnus-agent-message |
(gnus-agent-message |
3246 |
10 "gnus-agent-expire: %s:%d: Article kept as \ |
10 "gnus-agent-expire: %s:%d: Article kept as \ |
3247 |
expiration tests failed." group article-number) |
expiration tests failed." group article-number) |
3248 |
(gnus-agent-append-to-list |
(gnus-agent-append-to-list |
3249 |
tail-alist (cons article-number fetch-date))) |
tail-alist (cons article-number fetch-date))) |
3250 |
) |
) |
3251 |
|
|
3252 |
;; Clean up markers as I want to recycle this buffer |
;; Clean up markers as I want to recycle this buffer |
3253 |
;; over several groups. |
;; over several groups. |
3254 |
(when marker |
(when marker |
3255 |
(set-marker marker nil)) |
(set-marker marker nil)) |
3256 |
|
|
3257 |
(setq dlist (cdr dlist)))) |
(setq dlist (cdr dlist)))) |
3258 |
|
|
3259 |
(setq alist (cdr alist)) |
(setq alist (cdr alist)) |
3260 |
|
|
3261 |
(let ((inhibit-quit t)) |
(let ((inhibit-quit t)) |
3262 |
(unless (equal alist gnus-agent-article-alist) |
(unless (equal alist gnus-agent-article-alist) |
3263 |
(setq gnus-agent-article-alist alist) |
(setq gnus-agent-article-alist alist) |
3264 |
(gnus-agent-save-alist group)) |
(gnus-agent-save-alist group)) |
3265 |
|
|
3266 |
(when (buffer-modified-p) |
(when (buffer-modified-p) |
3267 |
(let ((coding-system-for-write |
(let ((coding-system-for-write |
3268 |
gnus-agent-file-coding-system)) |
gnus-agent-file-coding-system)) |
3269 |
(gnus-make-directory dir) |
(gnus-make-directory dir) |
3270 |
(write-region (point-min) (point-max) nov-file nil |
(write-region (point-min) (point-max) nov-file nil |
3271 |
'silent) |
'silent) |
3272 |
;; clear the modified flag as that I'm not confused by |
;; clear the modified flag as that I'm not confused by |
3273 |
;; its status on the next pass through this routine. |
;; its status on the next pass through this routine. |
3274 |
(set-buffer-modified-p nil))) |
(set-buffer-modified-p nil))) |
3275 |
|
|
3276 |
(when (eq articles t) |
(when (eq articles t) |
3277 |
(gnus-summary-update-info)))))))) |
(gnus-summary-update-info)))) |
3278 |
|
|
3279 |
|
(when (boundp 'gnus-agent-expire-stats) |
3280 |
|
(let ((stats (symbol-value 'gnus-agent-expire-stats))) |
3281 |
|
(incf (nth 2 stats) bytes-freed) |
3282 |
|
(incf (nth 1 stats) files-deleted) |
3283 |
|
(incf (nth 0 stats) nov-entries-deleted))) |
3284 |
|
)))) |
3285 |
|
|
3286 |
(defun gnus-agent-expire (&optional articles group force) |
(defun gnus-agent-expire (&optional articles group force) |
3287 |
"Expire all old articles. |
"Expire all old articles. |
3472 |
|
|
3473 |
(defun gnus-agent-uncached-articles (articles group &optional cached-header) |
(defun gnus-agent-uncached-articles (articles group &optional cached-header) |
3474 |
"Restrict ARTICLES to numbers already fetched. |
"Restrict ARTICLES to numbers already fetched. |
3475 |
Returns a sublist of ARTICLES that excludes thos article ids in GROUP |
Returns a sublist of ARTICLES that excludes those article ids in GROUP |
3476 |
that have already been fetched. |
that have already been fetched. |
3477 |
If CACHED-HEADER is nil, articles are only excluded if the article itself |
If CACHED-HEADER is nil, articles are only excluded if the article itself |
3478 |
has been fetched." |
has been fetched." |
3562 |
|
|
3563 |
;; Get the list of articles that were fetched |
;; Get the list of articles that were fetched |
3564 |
(goto-char (point-min)) |
(goto-char (point-min)) |
3565 |
(let ((pm (point-max))) |
(let ((pm (point-max)) |
3566 |
|
art) |
3567 |
(while (< (point) pm) |
(while (< (point) pm) |
3568 |
(when (looking-at "[0-9]+\t") |
(when (setq art (gnus-agent-read-article-number)) |
3569 |
(gnus-agent-append-to-list |
(gnus-agent-append-to-list tail-fetched-articles art)) |
|
tail-fetched-articles |
|
|
(read (current-buffer)))) |
|
3570 |
(forward-line 1))) |
(forward-line 1))) |
3571 |
|
|
3572 |
;; Clip this list to the headers that will |
;; Clip this list to the headers that will |
3603 |
(set-buffer nntp-server-buffer) |
(set-buffer nntp-server-buffer) |
3604 |
(copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) |
(copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) |
3605 |
|
|
3606 |
;; Merge the temp buffer with the known headers (found on |
;; Merge the temp buffer with the known headers (found on |
3607 |
;; disk in FILE) into the nntp-server-buffer |
;; disk in FILE) into the nntp-server-buffer |
3608 |
(when (and uncached-articles (file-exists-p file)) |
(when uncached-articles |
3609 |
(gnus-agent-braid-nov group uncached-articles file)) |
(gnus-agent-braid-nov group uncached-articles file)) |
3610 |
|
|
3611 |
;; Save the new set of known headers to FILE |
;; Save the new set of known headers to FILE |
3612 |
(set-buffer nntp-server-buffer) |
(set-buffer nntp-server-buffer) |
3613 |
(let ((coding-system-for-write |
(let ((coding-system-for-write |
3614 |
gnus-agent-file-coding-system)) |
gnus-agent-file-coding-system)) |
3688 |
(gnus-message 3 "Ignoring unexpected input") |
(gnus-message 3 "Ignoring unexpected input") |
3689 |
(sit-for 1) |
(sit-for 1) |
3690 |
t))))) |
t))))) |
|
|
|
3691 |
(when group |
(when group |
3692 |
(gnus-message 5 "Regenerating in %s" group) |
(gnus-message 5 "Regenerating in %s" group) |
3693 |
(let* ((gnus-command-method (or gnus-command-method |
(let* ((gnus-command-method (or gnus-command-method |
3728 |
(gnus-delete-line) |
(gnus-delete-line) |
3729 |
(setq nov-arts (cdr nov-arts)) |
(setq nov-arts (cdr nov-arts)) |
3730 |
(gnus-message 4 "gnus-agent-regenerate-group: NOV\ |
(gnus-message 4 "gnus-agent-regenerate-group: NOV\ |
3731 |
entry of article %s deleted." l1)) |
entry of article %s deleted." l1)) |
3732 |
((not l2) |
((not l2) |
3733 |
nil) |
nil) |
3734 |
((< l1 l2) |
((< l1 l2) |
3873 |
gnus-agent-article-alist)))) |
gnus-agent-article-alist)))) |
3874 |
|
|
3875 |
(when (gnus-buffer-live-p gnus-group-buffer) |
(when (gnus-buffer-live-p gnus-group-buffer) |
3876 |
(gnus-group-update-group group t) |
(gnus-group-update-group group t))) |
|
(sit-for 0))) |
|
3877 |
|
|
3878 |
(gnus-message 5 nil) |
(gnus-message 5 "") |
3879 |
regenerated))) |
regenerated))) |
3880 |
|
|
3881 |
;;;###autoload |
;;;###autoload |
3921 |
(defun gnus-agent-group-covered-p (group) |
(defun gnus-agent-group-covered-p (group) |
3922 |
(gnus-agent-method-p (gnus-group-method group))) |
(gnus-agent-method-p (gnus-group-method group))) |
3923 |
|
|
|
(add-hook 'gnus-group-prepare-hook |
|
|
(lambda () |
|
|
'gnus-agent-do-once |
|
|
|
|
|
(when (listp gnus-agent-expire-days) |
|
|
(beep) |
|
|
(beep) |
|
|
(gnus-message 1 "WARNING: gnus-agent-expire-days no longer\ |
|
|
supports being set to a list.")(sleep-for 3) |
|
|
(gnus-message 1 "Change your configuration to set it to an\ |
|
|
integer.")(sleep-for 3) |
|
|
(gnus-message 1 "I am now setting group parameters on each\ |
|
|
group to match the configuration that the list offered.") |
|
|
|
|
|
(save-excursion |
|
|
(let ((groups (gnus-group-listed-groups))) |
|
|
(while groups |
|
|
(let* ((group (pop groups)) |
|
|
(days gnus-agent-expire-days) |
|
|
(day (catch 'found |
|
|
(while days |
|
|
(when (eq 0 (string-match |
|
|
(caar days) |
|
|
group)) |
|
|
(throw 'found (cadar days))) |
|
|
(setq days (cdr days))) |
|
|
nil))) |
|
|
(when day |
|
|
(gnus-group-set-parameter group 'agent-days-until-old |
|
|
day)))))) |
|
|
|
|
|
(let ((h gnus-group-prepare-hook)) |
|
|
(while h |
|
|
(let ((func (pop h))) |
|
|
(when (and (listp func) |
|
|
(eq (cadr (caddr func)) 'gnus-agent-do-once)) |
|
|
(remove-hook 'gnus-group-prepare-hook func) |
|
|
(setq h nil))))) |
|
|
|
|
|
(gnus-message 1 "I have finished setting group parameters on\ |
|
|
each group. You may now customize your groups and/or topics to control the\ |
|
|
agent.")))) |
|
|
|
|
3924 |
(provide 'gnus-agent) |
(provide 'gnus-agent) |
3925 |
|
|
3926 |
;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e |
;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e |