1 |
;;; gnus-int.el --- backend interface functions for Gnus |
;;; gnus-int.el --- backend interface functions for Gnus |
2 |
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 |
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
29 |
(eval-when-compile (require 'cl)) |
(eval-when-compile (require 'cl)) |
30 |
|
|
31 |
(require 'gnus) |
(require 'gnus) |
32 |
|
(require 'message) |
33 |
|
(require 'gnus-range) |
34 |
|
|
35 |
|
(autoload 'gnus-agent-expire "gnus-agent") |
36 |
|
(autoload 'gnus-agent-read-servers-validate-native "gnus-agent") |
37 |
|
|
38 |
(defcustom gnus-open-server-hook nil |
(defcustom gnus-open-server-hook nil |
39 |
"Hook called just before opening connection to the news server." |
"Hook called just before opening connection to the news server." |
40 |
:group 'gnus-start |
:group 'gnus-start |
41 |
:type 'hook) |
:type 'hook) |
42 |
|
|
43 |
|
(defcustom gnus-server-unopen-status nil |
44 |
|
"The default status if the server is not able to open. |
45 |
|
If the server is covered by Gnus agent, the possible values are |
46 |
|
`denied', set the server denied; `offline', set the server offline; |
47 |
|
nil, ask user. If the server is not covered by Gnus agent, set the |
48 |
|
server denied." |
49 |
|
:group 'gnus-start |
50 |
|
:type '(choice (const :tag "Ask" nil) |
51 |
|
(const :tag "Deny server" denied) |
52 |
|
(const :tag "Unplug Agent" offline))) |
53 |
|
|
54 |
|
(defvar gnus-internal-registry-spool-current-method nil |
55 |
|
"The current method, for the registry.") |
56 |
|
|
57 |
;;; |
;;; |
58 |
;;; Server Communication |
;;; Server Communication |
59 |
;;; |
;;; |
106 |
(require 'nntp))) |
(require 'nntp))) |
107 |
(setq gnus-current-select-method gnus-select-method) |
(setq gnus-current-select-method gnus-select-method) |
108 |
(gnus-run-hooks 'gnus-open-server-hook) |
(gnus-run-hooks 'gnus-open-server-hook) |
109 |
|
|
110 |
|
;; Partially validate agent covered methods now that the |
111 |
|
;; gnus-select-method is known. |
112 |
|
|
113 |
|
(if gnus-agent |
114 |
|
;; NOTE: This is here for one purpose only. By validating |
115 |
|
;; the current select method, it converts the old 5.10.3, |
116 |
|
;; and earlier, format to the current format. That enables |
117 |
|
;; the agent code within gnus-open-server to function |
118 |
|
;; correctly. |
119 |
|
(gnus-agent-read-servers-validate-native gnus-select-method)) |
120 |
|
|
121 |
(or |
(or |
122 |
;; gnus-open-server-hook might have opened it |
;; gnus-open-server-hook might have opened it |
123 |
(gnus-server-opened gnus-select-method) |
(gnus-server-opened gnus-select-method) |
141 |
"Check whether the connection to METHOD is down. |
"Check whether the connection to METHOD is down. |
142 |
If METHOD is nil, use `gnus-select-method'. |
If METHOD is nil, use `gnus-select-method'. |
143 |
If it is down, start it up (again)." |
If it is down, start it up (again)." |
144 |
(let ((method (or method gnus-select-method))) |
(let ((method (or method gnus-select-method)) |
145 |
|
result) |
146 |
;; Transform virtual server names into select methods. |
;; Transform virtual server names into select methods. |
147 |
(when (stringp method) |
(when (stringp method) |
148 |
(setq method (gnus-server-to-method method))) |
(setq method (gnus-server-to-method method))) |
156 |
(format " on %s" (nth 1 method))))) |
(format " on %s" (nth 1 method))))) |
157 |
(gnus-run-hooks 'gnus-open-server-hook) |
(gnus-run-hooks 'gnus-open-server-hook) |
158 |
(prog1 |
(prog1 |
159 |
(gnus-open-server method) |
(condition-case () |
160 |
|
(setq result (gnus-open-server method)) |
161 |
|
(quit (message "Quit gnus-check-server") |
162 |
|
nil)) |
163 |
(unless silent |
(unless silent |
164 |
(message "")))))) |
(gnus-message 5 "Opening %s server%s...%s" (car method) |
165 |
|
(if (equal (nth 1 method) "") "" |
166 |
|
(format " on %s" (nth 1 method))) |
167 |
|
(if result "done" "failed"))))))) |
168 |
|
|
169 |
(defun gnus-get-function (method function &optional noerror) |
(defun gnus-get-function (method function &optional noerror) |
170 |
"Return a function symbol based on METHOD and FUNCTION." |
"Return a function symbol based on METHOD and FUNCTION." |
213 |
(gnus-message 1 "Denied server") |
(gnus-message 1 "Denied server") |
214 |
nil) |
nil) |
215 |
;; Open the server. |
;; Open the server. |
216 |
(let ((result |
(let* ((open-server-function (gnus-get-function gnus-command-method 'open-server)) |
217 |
(funcall (gnus-get-function gnus-command-method 'open-server) |
(result |
218 |
(nth 1 gnus-command-method) |
(condition-case err |
219 |
(nthcdr 2 gnus-command-method)))) |
(funcall open-server-function |
220 |
|
(nth 1 gnus-command-method) |
221 |
|
(nthcdr 2 gnus-command-method)) |
222 |
|
(error |
223 |
|
(gnus-message 1 (format |
224 |
|
"Unable to open server due to: %s" |
225 |
|
(error-message-string err))) |
226 |
|
nil) |
227 |
|
(quit |
228 |
|
(gnus-message 1 "Quit trying to open server") |
229 |
|
nil))) |
230 |
|
open-offline) |
231 |
;; If this hasn't been opened before, we add it to the list. |
;; If this hasn't been opened before, we add it to the list. |
232 |
(unless elem |
(unless elem |
233 |
(setq elem (list gnus-command-method nil) |
(setq elem (list gnus-command-method nil) |
234 |
gnus-opened-servers (cons elem gnus-opened-servers))) |
gnus-opened-servers (cons elem gnus-opened-servers))) |
235 |
;; Set the status of this server. |
;; Set the status of this server. |
236 |
(setcar (cdr elem) (if result 'ok 'denied)) |
(setcar (cdr elem) |
237 |
;; Return the result from the "open" call. |
(cond (result |
238 |
result)))) |
(if (eq open-server-function #'nnagent-open-server) |
239 |
|
;; The agent's backend has a "special" status |
240 |
|
'offline |
241 |
|
'ok)) |
242 |
|
((and gnus-agent |
243 |
|
(gnus-agent-method-p gnus-command-method)) |
244 |
|
(cond (gnus-server-unopen-status |
245 |
|
;; Set the server's status to the unopen |
246 |
|
;; status. If that status is offline, |
247 |
|
;; recurse to open the agent's backend. |
248 |
|
(setq open-offline (eq gnus-server-unopen-status 'offline)) |
249 |
|
gnus-server-unopen-status) |
250 |
|
((gnus-y-or-n-p |
251 |
|
(format "Unable to open %s:%s, go offline? " |
252 |
|
(car gnus-command-method) |
253 |
|
(cadr gnus-command-method))) |
254 |
|
(setq open-offline t) |
255 |
|
'offline) |
256 |
|
(t |
257 |
|
;; This agentized server was still denied |
258 |
|
'denied))) |
259 |
|
(t |
260 |
|
;; This unagentized server must be denied |
261 |
|
'denied))) |
262 |
|
|
263 |
|
;; NOTE: I MUST set the server's status to offline before this |
264 |
|
;; recursive call as this status will drive the |
265 |
|
;; gnus-get-function (called above) to return the agent's |
266 |
|
;; backend. |
267 |
|
(if open-offline |
268 |
|
;; Recursively open this offline server to perform the |
269 |
|
;; open-server function of the agent's backend. |
270 |
|
(let ((gnus-server-unopen-status 'denied)) |
271 |
|
;; Bind gnus-server-unopen-status to avoid recursively |
272 |
|
;; prompting with "go offline?". This is only a concern |
273 |
|
;; when the agent's backend fails to open the server. |
274 |
|
(gnus-open-server gnus-command-method)) |
275 |
|
result))))) |
276 |
|
|
277 |
(defun gnus-close-server (gnus-command-method) |
(defun gnus-close-server (gnus-command-method) |
278 |
"Close the connection to GNUS-COMMAND-METHOD." |
"Close the connection to GNUS-COMMAND-METHOD." |
314 |
|
|
315 |
(defun gnus-status-message (gnus-command-method) |
(defun gnus-status-message (gnus-command-method) |
316 |
"Return the status message from GNUS-COMMAND-METHOD. |
"Return the status message from GNUS-COMMAND-METHOD. |
317 |
If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method |
If GNUS-COMMAND-METHOD is a string, it is interpreted as a group |
318 |
this group uses will be queried." |
name. The method this group uses will be queried." |
319 |
(let ((gnus-command-method |
(let ((gnus-command-method |
320 |
(if (stringp gnus-command-method) |
(if (stringp gnus-command-method) |
321 |
(gnus-find-method-for-group gnus-command-method) |
(gnus-find-method-for-group gnus-command-method) |
375 |
"Request headers for ARTICLES in GROUP. |
"Request headers for ARTICLES in GROUP. |
376 |
If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." |
If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." |
377 |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
378 |
(if (and gnus-use-cache (numberp (car articles))) |
(cond |
379 |
(gnus-cache-retrieve-headers articles group fetch-old) |
((and gnus-use-cache (numberp (car articles))) |
380 |
|
(gnus-cache-retrieve-headers articles group fetch-old)) |
381 |
|
((and gnus-agent (gnus-online gnus-command-method) |
382 |
|
(gnus-agent-method-p gnus-command-method)) |
383 |
|
(gnus-agent-retrieve-headers articles group fetch-old)) |
384 |
|
(t |
385 |
(funcall (gnus-get-function gnus-command-method 'retrieve-headers) |
(funcall (gnus-get-function gnus-command-method 'retrieve-headers) |
386 |
articles (gnus-group-real-name group) |
articles (gnus-group-real-name group) |
387 |
(nth 1 gnus-command-method) fetch-old)))) |
(nth 1 gnus-command-method) fetch-old))))) |
388 |
|
|
389 |
(defun gnus-retrieve-articles (articles group) |
(defun gnus-retrieve-articles (articles group) |
390 |
"Request ARTICLES in GROUP." |
"Request ARTICLES in GROUP." |
410 |
(gnus-group-real-name group) article)))) |
(gnus-group-real-name group) article)))) |
411 |
|
|
412 |
(defun gnus-request-set-mark (group action) |
(defun gnus-request-set-mark (group action) |
413 |
"Set marks on articles in the backend." |
"Set marks on articles in the back end." |
414 |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
415 |
(if (not (gnus-check-backend-function |
(if (not (gnus-check-backend-function |
416 |
'request-set-mark (car gnus-command-method))) |
'request-set-mark (car gnus-command-method))) |
420 |
(nth 1 gnus-command-method))))) |
(nth 1 gnus-command-method))))) |
421 |
|
|
422 |
(defun gnus-request-update-mark (group article mark) |
(defun gnus-request-update-mark (group article mark) |
423 |
"Allow the backend to change the mark the user tries to put on an article." |
"Allow the back end to change the mark the user tries to put on an article." |
424 |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
425 |
(if (not (gnus-check-backend-function |
(if (not (gnus-check-backend-function |
426 |
'request-update-mark (car gnus-command-method))) |
'request-update-mark (car gnus-command-method))) |
449 |
(gnus-cache-request-article article group)) |
(gnus-cache-request-article article group)) |
450 |
(setq res (cons group article) |
(setq res (cons group article) |
451 |
clean-up t)) |
clean-up t)) |
452 |
|
;; Check the agent cache. |
453 |
|
((gnus-agent-request-article article group) |
454 |
|
(setq res (cons group article) |
455 |
|
clean-up t)) |
456 |
;; Use `head' function. |
;; Use `head' function. |
457 |
((fboundp head) |
((fboundp head) |
458 |
(setq res (funcall head article (gnus-group-real-name group) |
(setq res (funcall head article (gnus-group-real-name group) |
482 |
(gnus-cache-request-article article group)) |
(gnus-cache-request-article article group)) |
483 |
(setq res (cons group article) |
(setq res (cons group article) |
484 |
clean-up t)) |
clean-up t)) |
485 |
|
;; Check the agent cache. |
486 |
|
((gnus-agent-request-article article group) |
487 |
|
(setq res (cons group article) |
488 |
|
clean-up t)) |
489 |
;; Use `head' function. |
;; Use `head' function. |
490 |
((fboundp head) |
((fboundp head) |
491 |
(setq res (funcall head article (gnus-group-real-name group) |
(setq res (funcall head article (gnus-group-real-name group) |
517 |
(gnus-inhibit-demon t) |
(gnus-inhibit-demon t) |
518 |
(mail-source-plugged gnus-plugged)) |
(mail-source-plugged gnus-plugged)) |
519 |
(if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) |
(if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) |
520 |
(funcall (gnus-get-function gnus-command-method 'request-scan) |
(progn |
521 |
(and group (gnus-group-real-name group)) |
(setq gnus-internal-registry-spool-current-method gnus-command-method) |
522 |
(nth 1 gnus-command-method))))) |
(funcall (gnus-get-function gnus-command-method 'request-scan) |
523 |
|
(and group (gnus-group-real-name group)) |
524 |
|
(nth 1 gnus-command-method)))))) |
525 |
|
|
526 |
(defsubst gnus-request-update-info (info gnus-command-method) |
(defsubst gnus-request-update-info (info gnus-command-method) |
527 |
"Request that GNUS-COMMAND-METHOD update INFO." |
"Request that GNUS-COMMAND-METHOD update INFO." |
529 |
(setq gnus-command-method (gnus-server-to-method gnus-command-method))) |
(setq gnus-command-method (gnus-server-to-method gnus-command-method))) |
530 |
(when (gnus-check-backend-function |
(when (gnus-check-backend-function |
531 |
'request-update-info (car gnus-command-method)) |
'request-update-info (car gnus-command-method)) |
532 |
(funcall (gnus-get-function gnus-command-method 'request-update-info) |
(let ((group (gnus-info-group info))) |
533 |
(gnus-group-real-name (gnus-info-group info)) |
(and (funcall (gnus-get-function gnus-command-method |
534 |
info (nth 1 gnus-command-method)))) |
'request-update-info) |
535 |
|
(gnus-group-real-name group) |
536 |
|
info (nth 1 gnus-command-method)) |
537 |
|
;; If the minimum article number is greater than 1, then all |
538 |
|
;; smaller article numbers are known not to exist; we'll |
539 |
|
;; artificially add those to the 'read range. |
540 |
|
(let* ((active (gnus-active group)) |
541 |
|
(min (car active))) |
542 |
|
(when (> min 1) |
543 |
|
(let* ((range (if (= min 2) 1 (cons 1 (1- min)))) |
544 |
|
(read (gnus-info-read info)) |
545 |
|
(new-read (gnus-range-add read (list range)))) |
546 |
|
(gnus-info-set-read info new-read))) |
547 |
|
info))))) |
548 |
|
|
549 |
(defun gnus-request-expire-articles (articles group &optional force) |
(defun gnus-request-expire-articles (articles group &optional force) |
550 |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
(let* ((gnus-command-method (gnus-find-method-for-group group)) |
551 |
(funcall (gnus-get-function gnus-command-method 'request-expire-articles) |
(not-deleted |
552 |
articles (gnus-group-real-name group) (nth 1 gnus-command-method) |
(funcall |
553 |
force))) |
(gnus-get-function gnus-command-method 'request-expire-articles) |
554 |
|
articles (gnus-group-real-name group) (nth 1 gnus-command-method) |
555 |
(defun gnus-request-move-article |
force))) |
556 |
(article group server accept-function &optional last) |
(when (and gnus-agent |
557 |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
(gnus-agent-method-p gnus-command-method)) |
558 |
(funcall (gnus-get-function gnus-command-method 'request-move-article) |
(let ((expired-articles (gnus-sorted-difference articles not-deleted))) |
559 |
article (gnus-group-real-name group) |
(when expired-articles |
560 |
(nth 1 gnus-command-method) accept-function last))) |
(gnus-agent-expire expired-articles group 'force)))) |
561 |
|
not-deleted)) |
562 |
|
|
563 |
|
(defun gnus-request-move-article (article group server accept-function |
564 |
|
&optional last) |
565 |
|
(let* ((gnus-command-method (gnus-find-method-for-group group)) |
566 |
|
(result (funcall (gnus-get-function gnus-command-method |
567 |
|
'request-move-article) |
568 |
|
article (gnus-group-real-name group) |
569 |
|
(nth 1 gnus-command-method) accept-function last))) |
570 |
|
(when (and result gnus-agent |
571 |
|
(gnus-agent-method-p gnus-command-method)) |
572 |
|
(gnus-agent-expire (list article) group 'force)) |
573 |
|
result)) |
574 |
|
|
575 |
(defun gnus-request-accept-article (group &optional gnus-command-method last |
(defun gnus-request-accept-article (group &optional gnus-command-method last |
576 |
no-encode) |
no-encode) |
577 |
;; Make sure there's a newline at the end of the article. |
;; Make sure there's a newline at the end of the article. |
584 |
(unless (bolp) |
(unless (bolp) |
585 |
(insert "\n")) |
(insert "\n")) |
586 |
(unless no-encode |
(unless no-encode |
587 |
(save-restriction |
(let ((message-options message-options)) |
588 |
(message-narrow-to-head) |
(message-options-set-recipient) |
589 |
(let ((mail-parse-charset message-default-charset)) |
(save-restriction |
590 |
(mail-encode-encoded-word-buffer))) |
(message-narrow-to-head) |
591 |
(message-encode-message-body)) |
(let ((mail-parse-charset message-default-charset)) |
592 |
(let ((func (car (or gnus-command-method |
(mail-encode-encoded-word-buffer))) |
593 |
(gnus-find-method-for-group group))))) |
(message-encode-message-body))) |
594 |
(funcall (intern (format "%s-request-accept-article" func)) |
(let ((gnus-command-method (or gnus-command-method |
595 |
|
(gnus-find-method-for-group group)))) |
596 |
|
(funcall (gnus-get-function gnus-command-method 'request-accept-article) |
597 |
(if (stringp group) (gnus-group-real-name group) group) |
(if (stringp group) (gnus-group-real-name group) group) |
598 |
(cadr gnus-command-method) |
(cadr gnus-command-method) |
599 |
last))) |
last))) |
600 |
|
|
601 |
(defun gnus-request-replace-article (article group buffer &optional no-encode) |
(defun gnus-request-replace-article (article group buffer &optional no-encode) |
602 |
(unless no-encode |
(unless no-encode |
603 |
(save-restriction |
(let ((message-options message-options)) |
604 |
(message-narrow-to-head) |
(message-options-set-recipient) |
605 |
(let ((mail-parse-charset message-default-charset)) |
(save-restriction |
606 |
(mail-encode-encoded-word-buffer))) |
(message-narrow-to-head) |
607 |
(message-encode-message-body)) |
(let ((mail-parse-charset message-default-charset)) |
608 |
|
(mail-encode-encoded-word-buffer))) |
609 |
|
(message-encode-message-body))) |
610 |
(let ((func (car (gnus-group-name-to-method group)))) |
(let ((func (car (gnus-group-name-to-method group)))) |
611 |
(funcall (intern (format "%s-request-replace-article" func)) |
(funcall (intern (format "%s-request-replace-article" func)) |
612 |
article (gnus-group-real-name group) buffer))) |
article (gnus-group-real-name group) buffer))) |