;;; gnus-int.el --- backend interface functions for Gnus
-;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2013 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
'denied))
(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.
(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))
(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)
"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 retrieval of data from GNUS-COMMAND-METHOD."
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))
(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."
- (let ((gnus-command-method (gnus-find-method-for-group group))
- (func 'request-group-articles))
- (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-close-group (group)
"Request the GROUP be closed."
(let ((gnus-command-method (inline (gnus-find-method-for-group group))))
(gnus-group-real-name group)
(gnus-group-method group)))
-;; largely based on nnir-warp-to-article
-(defun gnus-try-warping-via-registry ()
- "Attempt to warp to the current article's source group based on
-data stored in the registry."
- (interactive)
- (when (gnus-summary-article-header)
- (let* ((message-id (mail-header-id (gnus-summary-article-header)))
- ;; Retrieve the message's group(s) from the registry
- (groups (gnus-registry-get-id-key message-id 'group))
- ;; If starting from an ephemeral group, this describes
- ;; how to restore the window configuration
- (quit-config
- (gnus-ephemeral-group-p gnus-newsgroup-name))
- (seen-groups (list (gnus-group-group-name))))
-
- (catch 'found
- (dolist (group (mapcar 'gnus-simplify-group-name groups))
-
- ;; skip over any groups we really don't want to warp to.
- (unless (or (member group seen-groups)
- (gnus-ephemeral-group-p group) ;; any ephemeral group
- (memq (car (gnus-find-method-for-group group))
- '(nnir))) ;; Specific methods; this list may need to expand.
-
- ;; remember that we've seen this group already
- (push group seen-groups)
-
- ;; first exit from any ephemeral summary buffer.
- (when quit-config
- (gnus-summary-exit)
- ;; and if the ephemeral summary buffer in turn came from another
- ;; summary buffer we have to clean that summary up too.
- (when (eq (cdr quit-config) 'summary)
- (gnus-summary-exit))
- ;; remember that we've already done this part
- (setq quit-config nil))
-
- ;; Try to activate the group. If that fails, just move
- ;; along. We may have more groups to work with
- (ignore-errors
- (gnus-select-group-with-message-id group message-id))
- (throw 'found t)))))))
-
(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)))
+ (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)))
- (gnus-try-warping-via-registry))))
+ (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."
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
(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
(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)))