X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=4e9ddd8ec533d5a019a945ed3c4a5187de6fb308;hb=6012f8d1ee972cfa2dcde9bb1495abbc752ad44a;hp=d2ed36b1066d53e6e667908ec0f61fcc202b381d;hpb=5e4e86bc38bb7a48ada0261a14c6388ad67e2f96;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index d2ed36b10..4e9ddd8ec 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -77,6 +77,11 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'hook) +(defcustom gnus-agent-confirmation-function 'y-or-n-p + "Function to confirm when error happens." + :group 'gnus-agent + :type 'function) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -227,6 +232,7 @@ If nil, only read articles will be expired." "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session + "JY" gnus-agent-synchronize "JS" gnus-group-send-drafts "Ja" gnus-agent-add-group "Jr" gnus-agent-remove-group) @@ -418,6 +424,27 @@ be a select method." (setf (cadddr c) (delete group (cadddr c)))))) (gnus-category-write))) +(defun gnus-agent-synchronize () + "Synchronize local, unplugged, data with backend. +Currently sends flag setting requests, if any." + (interactive) + (save-excursion + (dolist (gnus-command-method gnus-agent-covered-methods) + (when (file-exists-p (gnus-agent-lib-file "flags")) + (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (erase-buffer) + (insert-file-contents (gnus-agent-lib-file "flags")) + (if (null (gnus-check-server gnus-command-method)) + (message "Couldn't open server %s" (nth 1 gnus-command-method)) + (while (not (eobp)) + (if (null (eval (read (current-buffer)))) + (progn (forward-line) + (kill-line -1)) + (write-file (gnus-agent-lib-file "flags")) + (error "Couldn't set flags from file %s" + (gnus-agent-lib-file "flags")))) + (write-file (gnus-agent-lib-file "flags"))))))) + ;;; ;;; Server mode commands ;;; @@ -584,7 +611,9 @@ the actual number of articles toggled is returned." new)) (gnus-make-directory (file-name-directory file)) (let ((coding-system-for-write gnus-agent-file-coding-system)) - (gnus-write-active-file file orig)))) + ;; The hashtable contains real names of groups, no more prefix + ;; removing, so set `full' to `t'. + (gnus-write-active-file file orig t)))) (defun gnus-agent-save-groups (method) (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) @@ -592,7 +621,8 @@ the actual number of articles toggled is returned." (defun gnus-agent-save-group-info (method group active) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) - (file (gnus-agent-lib-file "active"))) + (file (gnus-agent-lib-file "active")) + oactive) (gnus-make-directory (file-name-directory file)) (with-temp-file file (when (file-exists-p file) @@ -600,17 +630,33 @@ the actual number of articles toggled is returned." (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) + (save-excursion + (save-restriction + (narrow-to-region (match-beginning 0) + (progn + (forward-line 1) + (point))) + (setq oactive (car (nnmail-parse-active))))) (gnus-delete-line)) - (insert group " " (number-to-string (cdr active)) " " - (number-to-string (car active)) " y\n"))))) + (insert (format "%S %d %d y\n" (intern group) + (cdr active) + (or (car oactive) (car active)))) + (goto-char (point-max)) + (while (search-backward "\\." nil t) + (delete-char 1)))))) (defun gnus-agent-group-path (group) "Translate GROUP into a path." (if nnmail-use-long-file-names (gnus-group-real-name group) - (nnheader-replace-chars-in-string - (nnheader-translate-file-chars (gnus-group-real-name group)) - ?. ?/))) + (nnheader-translate-file-chars + (nnheader-replace-chars-in-string + (nnheader-replace-duplicate-chars-in-string + (nnheader-replace-chars-in-string + (gnus-group-real-name group) + ?/ ?_) + ?. ?_) + ?. ?/)))) @@ -664,11 +710,15 @@ the actual number of articles toggled is returned." (save-excursion (set-buffer gnus-agent-current-history) (goto-char (point-max)) - (insert id "\t" (number-to-string date) "\t") - (while group-arts - (insert (caar group-arts) " " (number-to-string (cdr (pop group-arts))) - " ")) - (insert "\n"))) + (let ((p (point))) + (insert id "\t" (number-to-string date) "\t") + (while group-arts + (insert (format "%S" (intern (caar group-arts))) + " " (number-to-string (cdr (pop group-arts))) + " ")) + (insert "\n") + (while (search-backward "\\." p t) + (delete-char 1))))) (defun gnus-agent-article-in-history-p (id) (save-excursion @@ -697,7 +747,7 @@ the actual number of articles toggled is returned." ;; Prune off articles that we have already fetched. (while (and articles (cdr (assq (car articles) gnus-agent-article-alist))) - (pop articles)) + (pop articles)) (let ((arts articles)) (while (cdr arts) (if (cdr (assq (cadr arts) gnus-agent-article-alist)) @@ -718,7 +768,10 @@ the actual number of articles toggled is returned." (with-temp-buffer (let (article) (while (setq article (pop articles)) - (when (gnus-request-article article group) + (when (or + (gnus-backlog-request-article group article + nntp-server-buffer) + (gnus-request-article article group)) (goto-char (point-max)) (push (cons article (point)) pos) (insert-buffer-substring nntp-server-buffer))) @@ -777,7 +830,7 @@ the actual number of articles toggled is returned." (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" - group))) + group))) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors @@ -812,18 +865,18 @@ the actual number of articles toggled is returned." ;; add article with marks to list of article headers we want to fetch (dolist (arts (gnus-info-marks (gnus-get-info group))) (setq articles (union (gnus-uncompress-sequence (cdr arts)) - articles))) + articles))) (setq articles (sort articles '<)) ;; remove known articles (when (gnus-agent-load-alist group) (setq articles (gnus-sorted-intersection - articles - (gnus-uncompress-range - (cons (1+ (caar (last gnus-agent-article-alist))) - (cdr (gnus-active group))))))) + articles + (gnus-uncompress-range + (cons (1+ (caar (last gnus-agent-article-alist))) + (cdr (gnus-active group))))))) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file))) + (file-name-directory file) t)) (when articles (gnus-message 7 "Fetching headers for %s..." group) (save-excursion @@ -917,12 +970,18 @@ the actual number of articles toggled is returned." (concat (gnus-agent-directory) (gnus-agent-group-path group) "/" (if (stringp article) article (string-to-number article)))) +(defun gnus-agent-batch-confirmation (msg) + "Show error message and return t." + (gnus-message 1 msg) + t) + ;;;###autoload (defun gnus-agent-batch-fetch () "Start Gnus and fetch session." (interactive) (gnus) - (gnus-agent-fetch-session) + (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) + (gnus-agent-fetch-session)) (gnus-group-exit)) (defun gnus-agent-fetch-session () @@ -936,14 +995,20 @@ the actual number of articles toggled is returned." groups group gnus-command-method) (save-excursion (while methods - (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) - (setq groups (gnus-groups-from-server (car methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (when (<= (gnus-group-level group) gnus-agent-handle-level) - (gnus-agent-fetch-group-1 group gnus-command-method))))) + (condition-case err + (progn + (setq gnus-command-method (car methods)) + (when (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (setq groups (gnus-groups-from-server (car methods))) + (gnus-agent-with-fetch + (while (setq group (pop groups)) + (when (<= (gnus-group-level group) gnus-agent-handle-level) + (gnus-agent-fetch-group-1 group gnus-command-method)))))) + (error + (unless (funcall gnus-agent-confirmation-function + (format "Error (%s). Continue? " err)) + (error "Cannot fetch articles into the Gnus agent.")))) (pop methods)) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) @@ -955,6 +1020,8 @@ the actual number of articles toggled is returned." gnus-newsgroup-scored gnus-headers gnus-score gnus-use-cache articles arts category predicate info marks score-param) + (unless (gnus-check-group group) + (error "Can't open server for %s" group)) ;; Fetch headers. (when (and (or (gnus-active group) (gnus-activate-group group)) (setq articles (gnus-agent-fetch-headers group)) @@ -970,12 +1037,12 @@ the actual number of articles toggled is returned." (gnus-get-newsgroup-headers-xover articles nil nil group))) ;; `gnus-agent-overview-buffer' may be killed for - ;; timeout reason. If so, recreate it. + ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer))) (setq category (gnus-group-category group)) (setq predicate (gnus-get-predicate - (or (gnus-group-find-parameter group 'agent-predicate t) + (or (gnus-group-find-parameter group 'agent-predicate t) (cadr category)))) ;; Do we want to download everything, or nothing? (if (or (eq (caaddr predicate) 'gnus-agent-true) @@ -1208,7 +1275,7 @@ The following commands are available: (gnus-edit-form (cadr info) (format "Editing the predicate for category %s" category) `(lambda (predicate) - (setf (cadr (assq ',category gnus-category-alist)) predicate) + (setcar (cdr (assq ',category gnus-category-alist)) predicate) (gnus-category-write) (gnus-category-list))))) @@ -1220,7 +1287,7 @@ The following commands are available: (caddr info) (format "Editing the score expression for category %s" category) `(lambda (groups) - (setf (caddr (assq ',category gnus-category-alist)) groups) + (setcar (cddr (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1231,7 +1298,7 @@ The following commands are available: (gnus-edit-form (cadddr info) (format "Editing the group list for category %s" category) `(lambda (groups) - (setf (cadddr (assq ',category gnus-category-alist)) groups) + (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1401,8 +1468,9 @@ The following commands are available: (forward-line 1) ;; Old article. Schedule it for possible nuking. (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb)) - (read (current-buffer)))) + (setq sym (let ((obarray expiry-hashtb) s) + (setq s (read (current-buffer))) + (if (stringp s) (intern s) s))) (if (boundp sym) (set sym (cons (cons (read (current-buffer)) (point)) (symbol-value sym))) @@ -1432,7 +1500,7 @@ The following commands are available: (set-buffer overview) (erase-buffer) (when (file-exists-p nov-file) - (nnheader-insert-file-contents nov-file)) + (nnheader-insert-file-contents nov-file)) (goto-char (point-min)) (setq article 0) (while (setq elem (pop articles)) @@ -1447,9 +1515,10 @@ The following commands are available: (or (not (numberp (setq art (read (current-buffer))))) (< art article))) - (if (file-exists-p - (gnus-agent-article-name - (number-to-string art) group)) + (if (and (numberp art) + (file-exists-p + (gnus-agent-article-name + (number-to-string art) group))) (progn (unless lowest (setq lowest art))