/[emacs]/emacs/lisp/gnus/gnus-agent.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-agent.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7.6.3 by miles, Tue Sep 21 09:34:07 2004 UTC revision 1.7.6.4 by miles, Fri Oct 22 10:13:31 2004 UTC
# Line 114  If nil, only read articles will be expir Line 114  If nil, only read articles will be expir
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"
# Line 362  manipulated as follows: Line 362  manipulated as follows:
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)
# Line 624  minor mode in all Gnus buffers." Line 638  minor mode in all Gnus buffers."
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
# Line 790  be a select method." Line 804  be a select method."
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)
# Line 820  be a select method." Line 848  be a select 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  ;;;  ;;;
# Line 969  article's mark is toggled." Line 1047  article's mark is toggled."
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)))
# Line 1113  This can be added to `gnus-select-articl Line 1192  This can be added to `gnus-select-articl
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)
# Line 1131  This can be added to `gnus-select-articl Line 1253  This can be added to `gnus-select-articl
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."
# Line 1183  downloaded into the agent." Line 1306  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"))
# Line 1199  downloaded into the agent." Line 1322  downloaded into the agent."
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."
# Line 1413  downloaded into the agent." Line 1560  downloaded into the agent."
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    
# Line 1487  and that there are no duplicates." Line 1659  and that there are no duplicates."
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)))
# Line 1519  and that there are no duplicates." Line 1691  and that there are no duplicates."
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
# Line 1623  article numbers will be returned." Line 1796  article numbers will be returned."
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)
# Line 1636  article numbers will be returned." Line 1811  article numbers will be returned."
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)
# Line 1653  article numbers will be returned." Line 1849  article numbers will be returned."
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.
# Line 1735  FILE and places the combined headers int Line 1944  FILE and places the combined headers int
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)))
# Line 1744  FILE and places the combined headers int Line 1954  FILE and places the combined headers int
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)
# Line 1767  FILE and places the combined headers int Line 1979  FILE and places the combined headers int
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)))
# Line 1777  FILE and places the combined headers int Line 1990  FILE and places the combined headers int
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."
# Line 1860  modified) original contents, they are fi Line 2074  modified) original contents, they are fi
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))
# Line 1903  modified) original contents, they are fi Line 2118  modified) original contents, they are fi
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))))
# Line 1962  modified) original contents, they are fi Line 2177  modified) original contents, they are fi
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)
# Line 2012  modified) original contents, they are fi Line 2229  modified) original contents, they are fi
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")))))))))
# Line 2736  FORCE is equivalent to setting the expir Line 2954  FORCE is equivalent to setting the expir
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.
# Line 3248  articles in every agentized group.")) Line 3472  articles in every agentized group."))
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."
# Line 3338  has been fetched." Line 3562  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
# Line 3380  has been fetched." Line 3603  has been fetched."
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))
# Line 3465  If REREAD is not nil, downloaded article Line 3688  If REREAD is not nil, downloaded article
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
# Line 3506  If REREAD is not nil, downloaded article Line 3728  If REREAD is not nil, downloaded article
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)
# Line 3651  entry of article %s deleted." l1)) Line 3873  entry of article %s deleted." l1))
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
# Line 3700  If CLEAN, obsolete (ignore)." Line 3921  If CLEAN, obsolete (ignore)."
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

Legend:
Removed from v.1.7.6.3  
changed lines
  Added in v.1.7.6.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26