X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-int.el;h=4f8f17f18f35a49e3d9b154d0059889ac549fdd0;hp=ef15a479892dfe34e6e38fec8898968d22b2f872;hb=4c9cd8776a12037707860bb9885869129198425b;hpb=36b02a9b3e82b7a6e5553dc78ba6851e3427630d diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el index ef15a4798..4f8f17f18 100644 --- a/lisp/gnus-int.el +++ b/lisp/gnus-int.el @@ -1,6 +1,6 @@ ;;; gnus-int.el --- backend interface functions for Gnus -;; Copyright (C) 1996-2011 Free Software Foundation, Inc. +;; Copyright (C) 1996-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -43,11 +43,13 @@ (defcustom gnus-after-set-mark-hook nil "Hook called just after marks are set in a group." + :version "24.1" :group 'gnus-start :type 'hook) (defcustom gnus-before-update-mark-hook nil "Hook called just before marks are updated in a group." + :version "24.1" :group 'gnus-start :type 'hook) @@ -63,6 +65,13 @@ server denied." (const :tag "Deny server" denied) (const :tag "Unplug Agent" offline))) +(defcustom gnus-nntp-server nil + "The name of the host running the NNTP server." + :group 'gnus-server + :type '(choice (const :tag "disable" nil) + string)) +(make-obsolete-variable 'gnus-nntp-server 'gnus-select-method "24.1") + (defvar gnus-internal-registry-spool-current-method nil "The current method, for the registry.") @@ -104,7 +113,8 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (setq gnus-nntp-server (gnus-completing-read "NNTP server" (cons gnus-nntp-server - gnus-secondary-servers) + (if (boundp 'gnus-secondary-servers) + gnus-secondary-servers)) nil gnus-nntp-server))) (when (and gnus-nntp-server @@ -154,8 +164,8 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (gnus-open-server gnus-select-method) gnus-batch-mode (gnus-y-or-n-p - (format - "%s (%s) open error: '%s'. Continue? " + (gnus-format-message + "%s (%s) open error: `%s'. Continue? " (car gnus-select-method) (cadr gnus-select-method) (gnus-status-message gnus-select-method))) (gnus-error 1 "Couldn't open server on %s" @@ -238,24 +248,34 @@ If it is down, start it up (again)." (eq (nth 1 (assoc method gnus-opened-servers)) 'denied)) -(defvar gnus-backend-trace t) +(defvar gnus-backend-trace nil) +(defvar gnus-backend-trace-elapsed nil) -(defun gnus-open-server (gnus-command-method) - "Open a connection to GNUS-COMMAND-METHOD." - (when (stringp gnus-command-method) - (setq gnus-command-method (gnus-server-to-method gnus-command-method))) +(defun gnus-backend-trace (type form) (when gnus-backend-trace (with-current-buffer (get-buffer-create "*gnus trace*") (buffer-disable-undo) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") - (format " %S\n" gnus-command-method)))) + (format " %.2fs %s %S\n" + (if (numberp gnus-backend-trace-elapsed) + (- (float-time) gnus-backend-trace-elapsed) + 0) + type form)) + (setq gnus-backend-trace-elapsed (float-time))))) + +(defun gnus-open-server (gnus-command-method) + "Open a connection to GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (gnus-backend-trace :opening gnus-command-method) (let ((elem (assoc gnus-command-method gnus-opened-servers)) (server (gnus-method-to-server-name gnus-command-method))) ;; If this method was previously denied, we just return nil. (if (eq (nth 1 elem) 'denied) (progn - (gnus-message 1 "Denied server %s" server) + (gnus-message + 1 "Server %s previously determined to be down; not retrying" server) nil) ;; Open the server. (let* ((open-server-function @@ -283,7 +303,7 @@ If it is down, start it up (again)." (setcar (cdr elem) (cond (result - (if (eq open-server-function #'nnagent-open-server) + (if (eq open-server-function 'nnagent-open-server) ;; The agent's backend has a "special" status 'offline 'ok)) @@ -323,6 +343,7 @@ If it is down, start it up (again)." (save-excursion (gnus-agent-possibly-synchronize-flags-server gnus-command-method))) + (gnus-backend-trace :opened gnus-command-method) result))))) (defun gnus-close-server (gnus-command-method) @@ -343,12 +364,16 @@ If it is down, start it up (again)." "Read and update infos from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) - (funcall (gnus-get-function gnus-command-method 'finish-retrieve-group-infos) - (nth 1 gnus-command-method) - infos data)) + (gnus-backend-trace :finishing gnus-command-method) + (prog1 + (funcall (gnus-get-function gnus-command-method + 'finish-retrieve-group-infos) + (nth 1 gnus-command-method) + infos data) + (gnus-backend-trace :finished gnus-command-method))) (defun gnus-retrieve-group-data-early (gnus-command-method infos) - "Start early async retrival of data from GNUS-COMMAND-METHOD." + "Start early async retrieval of data from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early) @@ -388,7 +413,7 @@ If it is down, start it up (again)." result)) (defun gnus-request-compact (gnus-command-method) - "Request groups compaction from GNUS-COMMAND-METHOD." + "Request groups compaction from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (funcall (gnus-get-function gnus-command-method 'request-compact) @@ -406,14 +431,6 @@ If it is down, start it up (again)." dont-check info))) -(defun gnus-list-active-group (group) - "Request active information on GROUP." - (let ((gnus-command-method (gnus-find-method-for-group group)) - (func 'list-active-group)) - (when (gnus-check-backend-function func group) - (funcall (gnus-get-function gnus-command-method func) - (gnus-group-real-name group) (nth 1 gnus-command-method))))) - (defun gnus-request-group-description (group) "Request a description of GROUP." (let ((gnus-command-method (gnus-find-method-for-group group)) @@ -422,13 +439,13 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method func) (gnus-group-real-name group) (nth 1 gnus-command-method))))) -(defun gnus-request-group-articles (group) - "Request a list of existing articles in GROUP." +(defun gnus-request-group-scan (group info) + "Request that GROUP get a complete rescan." (let ((gnus-command-method (gnus-find-method-for-group group)) - (func 'request-group-articles)) + (func 'request-group-scan)) (when (gnus-check-backend-function func group) (funcall (gnus-get-function gnus-command-method func) - (gnus-group-real-name group) (nth 1 gnus-command-method))))) + (gnus-group-real-name group) (nth 1 gnus-command-method) info)))) (defun gnus-close-group (group) "Request the GROUP be closed." @@ -516,21 +533,76 @@ If BUFFER, insert the article in that group." article (gnus-group-real-name group) (nth 1 gnus-command-method) buffer))) -(defun gnus-request-thread (header) +(defun gnus-request-thread (header group) "Request the headers in the thread containing the article specified by HEADER." - (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) + (let ((gnus-command-method (gnus-find-method-for-group group))) (funcall (gnus-get-function gnus-command-method 'request-thread) - header))) + header + (gnus-group-real-name group)))) + +(defun gnus-select-group-with-message-id (group message-id) + "Activate and select GROUP with the given MESSAGE-ID selected. +Returns the article number of the message. + +If GROUP is not already selected, the message will be the only one in +the group's summary. +" + ;; TODO: is there a way to know at this point whether the group will + ;; be newly-selected? If so we could clean up the logic at the end + ;; + ;; save the new group's display parameter, if any, so we + ;; can replace it temporarily with zero. + (let ((saved-display + (gnus-group-get-parameter group 'display :allow-list))) + + ;; Tell gnus we really don't want any articles + (gnus-group-set-parameter group 'display 0) + + (unwind-protect + (gnus-summary-read-group-1 + group (not :show-all) :no-article (not :kill-buffer) + ;; The combination of no-display and this dummy list of + ;; articles to select somehow makes it possible to open a + ;; group with no articles in it. Black magic. + :no-display '(-1); select-articles + ) + ;; Restore the new group's display parameter + (gnus-group-set-parameter group 'display saved-display))) + + ;; The summary buffer was suppressed by :no-display above. + ;; Create it now and insert the message + (let ((group-is-new (gnus-summary-setup-buffer group))) + (condition-case err + (let ((article-number + (gnus-summary-insert-subject message-id))) + (unless article-number + (signal 'error "message-id not in group")) + (gnus-summary-select-article nil nil nil article-number) + article-number) + ;; Clean up the new summary and propagate the error + (error (when group-is-new (gnus-summary-exit)) + (apply 'signal err))))) + +(defun gnus-simplify-group-name (group) + "Return the simplest representation of the name of GROUP. +This is the string that Gnus uses to identify the group." + (gnus-group-prefixed-name + (gnus-group-real-name group) + (gnus-group-method group))) (defun gnus-warp-to-article () - "Warps from an article in a virtual group to the article in its -real group. Does nothing on a real group." + "Look up the current article in the group where it originated. +This command only makes sense for groups shows articles gathered +from other groups -- for instance, search results and the like." (interactive) (let ((gnus-command-method - (gnus-find-method-for-group gnus-newsgroup-name))) - (when (gnus-check-backend-function - 'warp-to-article (car gnus-command-method)) - (funcall (gnus-get-function gnus-command-method 'warp-to-article))))) + (gnus-find-method-for-group gnus-newsgroup-name))) + (or + (when (gnus-check-backend-function + 'warp-to-article (car gnus-command-method)) + (funcall (gnus-get-function gnus-command-method 'warp-to-article))) + (and (bound-and-true-p gnus-registry-enabled) + (gnus-try-warping-via-registry))))) (defun gnus-request-head (article group) "Request the head of ARTICLE in GROUP." @@ -550,7 +622,8 @@ real group. Does nothing on a real group." clean-up t)) ;; Use `head' function. ((fboundp head) - (setq res (funcall head article (gnus-group-real-name group) + (setq res (funcall head article + (and (not gnus-override-method) (gnus-group-real-name group)) (nth 1 gnus-command-method)))) ;; Use `article' function. (t @@ -657,6 +730,10 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (defun gnus-request-expire-articles (articles group &optional force) (let* ((gnus-command-method (gnus-find-method-for-group group)) + ;; Filter out any negative article numbers; they can't be + ;; expired here. + (articles + (delq nil (mapcar (lambda (n) (and (>= n 0) n)) articles))) (gnus-inhibit-demon t) (not-deleted (funcall @@ -685,7 +762,6 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (defun gnus-request-accept-article (group &optional gnus-command-method last no-encode) - ;; Make sure there's a newline at the end of the article. (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (when (and (not gnus-command-method) @@ -693,6 +769,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (setq gnus-command-method (or (gnus-find-method-for-group group) (gnus-group-name-to-method group)))) (goto-char (point-max)) + ;; Make sure there's a newline at the end of the article. (unless (bolp) (insert "\n")) (unless no-encode @@ -733,11 +810,6 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (gnus-agent-regenerate-group group (list article))) result)) -(defun gnus-request-associate-buffer (group) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-associate-buffer) - (gnus-group-real-name group)))) - (defun gnus-request-restore-buffer (article group) "Request a new buffer restored to the state of ARTICLE." (let ((gnus-command-method (gnus-find-method-for-group group)))