X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-int.el;h=20add470abe1741220af1a2aa58324b16b236c57;hb=ae5fb0b06c5230fe667d0ac25e637c16f0fd8e89;hp=3245b16997b2d6358817d8cb6c03f5f2cf2b77fc;hpb=c59af0125bbb6e57a071d9f11bf130f251ca1749;p=gnus diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el index 3245b1699..20add470a 100644 --- a/lisp/gnus-int.el +++ b/lisp/gnus-int.el @@ -1,7 +1,6 @@ ;;; gnus-int.el --- backend interface functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -31,6 +30,7 @@ (require 'message) (require 'gnus-range) +(autoload 'gnus-run-hook-with-args "gnus-util") (autoload 'gnus-agent-expire "gnus-agent") (autoload 'gnus-agent-regenerate-group "gnus-agent") (autoload 'gnus-agent-read-servers-validate-native "gnus-agent") @@ -41,6 +41,16 @@ :group 'gnus-start :type 'hook) +(defcustom gnus-after-set-mark-hook nil + "Hook called just after marks are set in a group." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-update-mark-hook nil + "Hook called just before marks are updated in a group." + :group 'gnus-start + :type 'hook) + (defcustom gnus-server-unopen-status nil "The default status if the server is not able to open. If the server is covered by Gnus agent, the possible values are @@ -53,6 +63,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.") @@ -89,16 +106,13 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." ;; Stream is already opened. nil ;; Open NNTP server. - (unless gnus-nntp-service - (setq gnus-nntp-server nil)) (when confirm ;; Read server name with completion. (setq gnus-nntp-server - (completing-read "NNTP server: " - (mapcar 'list - (cons (list gnus-nntp-server) - gnus-secondary-servers)) - nil nil gnus-nntp-server))) + (gnus-completing-read "NNTP server" + (cons gnus-nntp-server + gnus-secondary-servers) + nil gnus-nntp-server))) (when (and gnus-nntp-server (stringp gnus-nntp-server) @@ -248,23 +262,27 @@ If it is down, start it up (again)." ;; 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 (gnus-get-function gnus-command-method 'open-server)) + (let* ((open-server-function + (gnus-get-function gnus-command-method 'open-server)) (result - (condition-case err - (funcall open-server-function - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method)) - (error - (gnus-message 1 "Unable to open server %s due to: %s" - server (error-message-string err)) - nil) - (quit - (gnus-message 1 "Quit trying to open server %s" server) - nil))) - open-offline) + (condition-case err + (funcall open-server-function + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)) + (error + (gnus-message 1 "Unable to open server %s due to: %s" + server (error-message-string err)) + nil) + (quit + (if debug-on-quit + (debug "Quit") + (gnus-message 1 "Quit trying to open server %s" server)) + nil))) + open-offline) ;; If this hasn't been opened before, we add it to the list. (unless elem (setq elem (list gnus-command-method nil) @@ -338,7 +356,7 @@ If it is down, start it up (again)." infos data)) (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) @@ -378,7 +396,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) @@ -464,6 +482,18 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (funcall (gnus-get-function gnus-command-method 'request-type) (gnus-group-real-name group) article)))) +(defun gnus-request-update-group-status (group status) + "Change the status of a group. +Valid statuses include `subscribe' and `unsubscribe'." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-update-group-status (car gnus-command-method))) + nil + (funcall + (gnus-get-function gnus-command-method 'request-update-group-status) + (gnus-group-real-name group) status + (nth 1 gnus-command-method))))) + (defun gnus-request-set-mark (group action) "Set marks on articles in the back end." (let ((gnus-command-method (gnus-find-method-for-group group))) @@ -472,7 +502,8 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." action (funcall (gnus-get-function gnus-command-method 'request-set-mark) (gnus-group-real-name group) action - (nth 1 gnus-command-method))))) + (nth 1 gnus-command-method)) + (gnus-run-hook-with-args gnus-after-set-mark-hook group action)))) (defun gnus-request-update-mark (group article mark) "Allow the back end to change the mark the user tries to put on an article." @@ -480,6 +511,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (if (not (gnus-check-backend-function 'request-update-mark (car gnus-command-method))) mark + (gnus-run-hook-with-args gnus-before-update-mark-hook group article mark) (funcall (gnus-get-function gnus-command-method 'request-update-mark) (gnus-group-real-name group) article mark)))) @@ -492,6 +524,23 @@ 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 group) + "Request the headers in the thread containing the article specified by HEADER." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-thread) + header + (gnus-group-real-name 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." + (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))))) + (defun gnus-request-head (article group) "Request the head of ARTICLE in GROUP." (let* ((gnus-command-method (gnus-find-method-for-group group)) @@ -600,8 +649,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (when (gnus-check-backend-function 'request-marks (car gnus-command-method)) (let ((group (gnus-info-group info))) - (and (funcall (gnus-get-function gnus-command-method - 'request-update-info) + (and (funcall (gnus-get-function gnus-command-method 'request-marks) (gnus-group-real-name group) info (nth 1 gnus-command-method)) ;; If the minimum article number is greater than 1, then all @@ -637,7 +685,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (result (funcall (gnus-get-function gnus-command-method 'request-move-article) article (gnus-group-real-name group) - (nth 1 gnus-command-method) accept-function last move-is-internal))) + (nth 1 gnus-command-method) accept-function + last move-is-internal))) (when (and result gnus-agent (gnus-agent-method-p gnus-command-method)) (gnus-agent-unfetch-articles group (list article))) @@ -671,7 +720,9 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (if (stringp group) (gnus-group-real-name group) group) (cadr gnus-command-method) last))) - (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (when (and gnus-agent + (gnus-agent-method-p gnus-command-method) + (cdr result)) (gnus-agent-regenerate-group group (list (cdr result)))) result))