comparison lisp/gnus/gnus-int.el @ 82951:0fde48feb604

Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author Andreas Schwab <schwab@suse.de>
date Thu, 22 Jul 2004 16:45:51 +0000
parents 695cf19ef79e
children 497f0d2ca551 cce1c0ee76ee
comparison
equal deleted inserted replaced
56503:8bbd2323fbf2 82951:0fde48feb604
1 ;;; gnus-int.el --- backend interface functions for Gnus 1 ;;; gnus-int.el --- backend interface functions for Gnus
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3 ;; Free Software Foundation, Inc. 3 ;; Free Software Foundation, Inc.
4 4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news 6 ;; Keywords: news
7 7
27 ;;; Code: 27 ;;; Code:
28 28
29 (eval-when-compile (require 'cl)) 29 (eval-when-compile (require 'cl))
30 30
31 (require 'gnus) 31 (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")
32 37
33 (defcustom gnus-open-server-hook nil 38 (defcustom gnus-open-server-hook nil
34 "Hook called just before opening connection to the news server." 39 "Hook called just before opening connection to the news server."
35 :group 'gnus-start 40 :group 'gnus-start
36 :type 'hook) 41 :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.")
37 56
38 ;;; 57 ;;;
39 ;;; Server Communication 58 ;;; Server Communication
40 ;;; 59 ;;;
41 60
85 (gnus-message 5 "Looking up mh spool...")) 104 (gnus-message 5 "Looking up mh spool..."))
86 (t 105 (t
87 (require 'nntp))) 106 (require 'nntp)))
88 (setq gnus-current-select-method gnus-select-method) 107 (setq gnus-current-select-method gnus-select-method)
89 (gnus-run-hooks 'gnus-open-server-hook) 108 (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
90 (or 121 (or
91 ;; gnus-open-server-hook might have opened it 122 ;; gnus-open-server-hook might have opened it
92 (gnus-server-opened gnus-select-method) 123 (gnus-server-opened gnus-select-method)
93 (gnus-open-server gnus-select-method) 124 (gnus-open-server gnus-select-method)
94 gnus-batch-mode 125 gnus-batch-mode
108 139
109 (defun gnus-check-server (&optional method silent) 140 (defun gnus-check-server (&optional method silent)
110 "Check whether the connection to METHOD is down. 141 "Check whether the connection to METHOD is down.
111 If METHOD is nil, use `gnus-select-method'. 142 If METHOD is nil, use `gnus-select-method'.
112 If it is down, start it up (again)." 143 If it is down, start it up (again)."
113 (let ((method (or method gnus-select-method))) 144 (let ((method (or method gnus-select-method))
145 result)
114 ;; Transform virtual server names into select methods. 146 ;; Transform virtual server names into select methods.
115 (when (stringp method) 147 (when (stringp method)
116 (setq method (gnus-server-to-method method))) 148 (setq method (gnus-server-to-method method)))
117 (if (gnus-server-opened method) 149 (if (gnus-server-opened method)
118 ;; The stream is already opened. 150 ;; The stream is already opened.
122 (gnus-message 5 "Opening %s server%s..." (car method) 154 (gnus-message 5 "Opening %s server%s..." (car method)
123 (if (equal (nth 1 method) "") "" 155 (if (equal (nth 1 method) "") ""
124 (format " on %s" (nth 1 method))))) 156 (format " on %s" (nth 1 method)))))
125 (gnus-run-hooks 'gnus-open-server-hook) 157 (gnus-run-hooks 'gnus-open-server-hook)
126 (prog1 158 (prog1
127 (gnus-open-server method) 159 (condition-case ()
160 (setq result (gnus-open-server method))
161 (quit (message "Quit gnus-check-server")
162 nil))
128 (unless silent 163 (unless silent
129 (message "")))))) 164 (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")))))))
130 168
131 (defun gnus-get-function (method function &optional noerror) 169 (defun gnus-get-function (method function &optional noerror)
132 "Return a function symbol based on METHOD and FUNCTION." 170 "Return a function symbol based on METHOD and FUNCTION."
133 ;; Translate server names into methods. 171 ;; Translate server names into methods.
134 (unless method 172 (unless method
173 (if (eq (nth 1 elem) 'denied) 211 (if (eq (nth 1 elem) 'denied)
174 (progn 212 (progn
175 (gnus-message 1 "Denied server") 213 (gnus-message 1 "Denied server")
176 nil) 214 nil)
177 ;; Open the server. 215 ;; Open the server.
178 (let ((result 216 (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
179 (funcall (gnus-get-function gnus-command-method 'open-server) 217 (result
180 (nth 1 gnus-command-method) 218 (condition-case err
181 (nthcdr 2 gnus-command-method)))) 219 (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)
182 ;; If this hasn't been opened before, we add it to the list. 231 ;; If this hasn't been opened before, we add it to the list.
183 (unless elem 232 (unless elem
184 (setq elem (list gnus-command-method nil) 233 (setq elem (list gnus-command-method nil)
185 gnus-opened-servers (cons elem gnus-opened-servers))) 234 gnus-opened-servers (cons elem gnus-opened-servers)))
186 ;; Set the status of this server. 235 ;; Set the status of this server.
187 (setcar (cdr elem) (if result 'ok 'denied)) 236 (setcar (cdr elem)
188 ;; Return the result from the "open" call. 237 (cond (result
189 result)))) 238 (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)))))
190 276
191 (defun gnus-close-server (gnus-command-method) 277 (defun gnus-close-server (gnus-command-method)
192 "Close the connection to GNUS-COMMAND-METHOD." 278 "Close the connection to GNUS-COMMAND-METHOD."
193 (when (stringp gnus-command-method) 279 (when (stringp gnus-command-method)
194 (setq gnus-command-method (gnus-server-to-method gnus-command-method))) 280 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
226 (funcall (inline (gnus-get-function gnus-command-method 'server-opened)) 312 (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
227 (nth 1 gnus-command-method)))) 313 (nth 1 gnus-command-method))))
228 314
229 (defun gnus-status-message (gnus-command-method) 315 (defun gnus-status-message (gnus-command-method)
230 "Return the status message from GNUS-COMMAND-METHOD. 316 "Return the status message from GNUS-COMMAND-METHOD.
231 If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method 317 If GNUS-COMMAND-METHOD is a string, it is interpreted as a group
232 this group uses will be queried." 318 name. The method this group uses will be queried."
233 (let ((gnus-command-method 319 (let ((gnus-command-method
234 (if (stringp gnus-command-method) 320 (if (stringp gnus-command-method)
235 (gnus-find-method-for-group gnus-command-method) 321 (gnus-find-method-for-group gnus-command-method)
236 gnus-command-method))) 322 gnus-command-method)))
237 (funcall (gnus-get-function gnus-command-method 'status-message) 323 (funcall (gnus-get-function gnus-command-method 'status-message)
287 373
288 (defun gnus-retrieve-headers (articles group &optional fetch-old) 374 (defun gnus-retrieve-headers (articles group &optional fetch-old)
289 "Request headers for ARTICLES in GROUP. 375 "Request headers for ARTICLES in GROUP.
290 If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." 376 If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
291 (let ((gnus-command-method (gnus-find-method-for-group group))) 377 (let ((gnus-command-method (gnus-find-method-for-group group)))
292 (if (and gnus-use-cache (numberp (car articles))) 378 (cond
293 (gnus-cache-retrieve-headers articles group fetch-old) 379 ((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
294 (funcall (gnus-get-function gnus-command-method 'retrieve-headers) 385 (funcall (gnus-get-function gnus-command-method 'retrieve-headers)
295 articles (gnus-group-real-name group) 386 articles (gnus-group-real-name group)
296 (nth 1 gnus-command-method) fetch-old)))) 387 (nth 1 gnus-command-method) fetch-old)))))
297 388
298 (defun gnus-retrieve-articles (articles group) 389 (defun gnus-retrieve-articles (articles group)
299 "Request ARTICLES in GROUP." 390 "Request ARTICLES in GROUP."
300 (let ((gnus-command-method (gnus-find-method-for-group group))) 391 (let ((gnus-command-method (gnus-find-method-for-group group)))
301 (funcall (gnus-get-function gnus-command-method 'retrieve-articles) 392 (funcall (gnus-get-function gnus-command-method 'retrieve-articles)
317 'unknown 408 'unknown
318 (funcall (gnus-get-function gnus-command-method 'request-type) 409 (funcall (gnus-get-function gnus-command-method 'request-type)
319 (gnus-group-real-name group) article)))) 410 (gnus-group-real-name group) article))))
320 411
321 (defun gnus-request-set-mark (group action) 412 (defun gnus-request-set-mark (group action)
322 "Set marks on articles in the backend." 413 "Set marks on articles in the back end."
323 (let ((gnus-command-method (gnus-find-method-for-group group))) 414 (let ((gnus-command-method (gnus-find-method-for-group group)))
324 (if (not (gnus-check-backend-function 415 (if (not (gnus-check-backend-function
325 'request-set-mark (car gnus-command-method))) 416 'request-set-mark (car gnus-command-method)))
326 action 417 action
327 (funcall (gnus-get-function gnus-command-method 'request-set-mark) 418 (funcall (gnus-get-function gnus-command-method 'request-set-mark)
328 (gnus-group-real-name group) action 419 (gnus-group-real-name group) action
329 (nth 1 gnus-command-method))))) 420 (nth 1 gnus-command-method)))))
330 421
331 (defun gnus-request-update-mark (group article mark) 422 (defun gnus-request-update-mark (group article mark)
332 "Allow the backend to change the mark the user tries to put on an article." 423 "Allow the back end to change the mark the user tries to put on an article."
333 (let ((gnus-command-method (gnus-find-method-for-group group))) 424 (let ((gnus-command-method (gnus-find-method-for-group group)))
334 (if (not (gnus-check-backend-function 425 (if (not (gnus-check-backend-function
335 'request-update-mark (car gnus-command-method))) 426 'request-update-mark (car gnus-command-method)))
336 mark 427 mark
337 (funcall (gnus-get-function gnus-command-method 'request-update-mark) 428 (funcall (gnus-get-function gnus-command-method 'request-update-mark)
354 (cond 445 (cond
355 ;; Check the cache. 446 ;; Check the cache.
356 ((and gnus-use-cache 447 ((and gnus-use-cache
357 (numberp article) 448 (numberp article)
358 (gnus-cache-request-article article group)) 449 (gnus-cache-request-article article group))
450 (setq res (cons group article)
451 clean-up t))
452 ;; Check the agent cache.
453 ((gnus-agent-request-article article group)
359 (setq res (cons group article) 454 (setq res (cons group article)
360 clean-up t)) 455 clean-up t))
361 ;; Use `head' function. 456 ;; Use `head' function.
362 ((fboundp head) 457 ((fboundp head)
363 (setq res (funcall head article (gnus-group-real-name group) 458 (setq res (funcall head article (gnus-group-real-name group)
385 ((and gnus-use-cache 480 ((and gnus-use-cache
386 (numberp article) 481 (numberp article)
387 (gnus-cache-request-article article group)) 482 (gnus-cache-request-article article group))
388 (setq res (cons group article) 483 (setq res (cons group article)
389 clean-up t)) 484 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))
390 ;; Use `head' function. 489 ;; Use `head' function.
391 ((fboundp head) 490 ((fboundp head)
392 (setq res (funcall head article (gnus-group-real-name group) 491 (setq res (funcall head article (gnus-group-real-name group)
393 (nth 1 gnus-command-method)))) 492 (nth 1 gnus-command-method))))
394 ;; Use `article' function. 493 ;; Use `article' function.
416 (let ((gnus-command-method 515 (let ((gnus-command-method
417 (if group (gnus-find-method-for-group group) gnus-command-method)) 516 (if group (gnus-find-method-for-group group) gnus-command-method))
418 (gnus-inhibit-demon t) 517 (gnus-inhibit-demon t)
419 (mail-source-plugged gnus-plugged)) 518 (mail-source-plugged gnus-plugged))
420 (if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) 519 (if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method)))
421 (funcall (gnus-get-function gnus-command-method 'request-scan) 520 (progn
422 (and group (gnus-group-real-name group)) 521 (setq gnus-internal-registry-spool-current-method gnus-command-method)
423 (nth 1 gnus-command-method))))) 522 (funcall (gnus-get-function gnus-command-method 'request-scan)
523 (and group (gnus-group-real-name group))
524 (nth 1 gnus-command-method))))))
424 525
425 (defsubst gnus-request-update-info (info gnus-command-method) 526 (defsubst gnus-request-update-info (info gnus-command-method)
426 "Request that GNUS-COMMAND-METHOD update INFO." 527 "Request that GNUS-COMMAND-METHOD update INFO."
427 (when (stringp gnus-command-method) 528 (when (stringp gnus-command-method)
428 (setq gnus-command-method (gnus-server-to-method gnus-command-method))) 529 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
429 (when (gnus-check-backend-function 530 (when (gnus-check-backend-function
430 'request-update-info (car gnus-command-method)) 531 'request-update-info (car gnus-command-method))
431 (funcall (gnus-get-function gnus-command-method 'request-update-info) 532 (let ((group (gnus-info-group info)))
432 (gnus-group-real-name (gnus-info-group info)) 533 (and (funcall (gnus-get-function gnus-command-method
433 info (nth 1 gnus-command-method)))) 534 '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)))))
434 548
435 (defun gnus-request-expire-articles (articles group &optional force) 549 (defun gnus-request-expire-articles (articles group &optional force)
436 (let ((gnus-command-method (gnus-find-method-for-group group))) 550 (let* ((gnus-command-method (gnus-find-method-for-group group))
437 (funcall (gnus-get-function gnus-command-method 'request-expire-articles) 551 (not-deleted
438 articles (gnus-group-real-name group) (nth 1 gnus-command-method) 552 (funcall
439 force))) 553 (gnus-get-function gnus-command-method 'request-expire-articles)
440 554 articles (gnus-group-real-name group) (nth 1 gnus-command-method)
441 (defun gnus-request-move-article 555 force)))
442 (article group server accept-function &optional last) 556 (when (and gnus-agent
443 (let ((gnus-command-method (gnus-find-method-for-group group))) 557 (gnus-agent-method-p gnus-command-method))
444 (funcall (gnus-get-function gnus-command-method 'request-move-article) 558 (let ((expired-articles (gnus-sorted-difference articles not-deleted)))
445 article (gnus-group-real-name group) 559 (when expired-articles
446 (nth 1 gnus-command-method) accept-function last))) 560 (gnus-agent-expire expired-articles group 'force))))
447 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
448 (defun gnus-request-accept-article (group &optional gnus-command-method last 575 (defun gnus-request-accept-article (group &optional gnus-command-method last
449 no-encode) 576 no-encode)
450 ;; Make sure there's a newline at the end of the article. 577 ;; Make sure there's a newline at the end of the article.
451 (when (stringp gnus-command-method) 578 (when (stringp gnus-command-method)
452 (setq gnus-command-method (gnus-server-to-method gnus-command-method))) 579 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
455 (setq gnus-command-method (gnus-group-name-to-method group))) 582 (setq gnus-command-method (gnus-group-name-to-method group)))
456 (goto-char (point-max)) 583 (goto-char (point-max))
457 (unless (bolp) 584 (unless (bolp)
458 (insert "\n")) 585 (insert "\n"))
459 (unless no-encode 586 (unless no-encode
460 (save-restriction 587 (let ((message-options message-options))
461 (message-narrow-to-head) 588 (message-options-set-recipient)
462 (let ((mail-parse-charset message-default-charset)) 589 (save-restriction
463 (mail-encode-encoded-word-buffer))) 590 (message-narrow-to-head)
464 (message-encode-message-body)) 591 (let ((mail-parse-charset message-default-charset))
465 (let ((func (car (or gnus-command-method 592 (mail-encode-encoded-word-buffer)))
466 (gnus-find-method-for-group group))))) 593 (message-encode-message-body)))
467 (funcall (intern (format "%s-request-accept-article" func)) 594 (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)
468 (if (stringp group) (gnus-group-real-name group) group) 597 (if (stringp group) (gnus-group-real-name group) group)
469 (cadr gnus-command-method) 598 (cadr gnus-command-method)
470 last))) 599 last)))
471 600
472 (defun gnus-request-replace-article (article group buffer &optional no-encode) 601 (defun gnus-request-replace-article (article group buffer &optional no-encode)
473 (unless no-encode 602 (unless no-encode
474 (save-restriction 603 (let ((message-options message-options))
475 (message-narrow-to-head) 604 (message-options-set-recipient)
476 (let ((mail-parse-charset message-default-charset)) 605 (save-restriction
477 (mail-encode-encoded-word-buffer))) 606 (message-narrow-to-head)
478 (message-encode-message-body)) 607 (let ((mail-parse-charset message-default-charset))
608 (mail-encode-encoded-word-buffer)))
609 (message-encode-message-body)))
479 (let ((func (car (gnus-group-name-to-method group)))) 610 (let ((func (car (gnus-group-name-to-method group))))
480 (funcall (intern (format "%s-request-replace-article" func)) 611 (funcall (intern (format "%s-request-replace-article" func))
481 article (gnus-group-real-name group) buffer))) 612 article (gnus-group-real-name group) buffer)))
482 613
483 (defun gnus-request-associate-buffer (group) 614 (defun gnus-request-associate-buffer (group)