/[emacs]/emacs/lisp/gnus/gnus-int.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-int.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7.6.1 by handa, Fri Mar 12 00:02:57 2004 UTC revision 1.7.6.2 by miles, Thu Sep 9 09:36:25 2004 UTC
# Line 1  Line 1 
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>
# Line 29  Line 29 
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  ;;;  ;;;
# Line 87  If CONFIRM is non-nil, the user will be Line 106  If CONFIRM is non-nil, the user will be
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)
# Line 110  If CONFIRM is non-nil, the user will be Line 141  If CONFIRM is non-nil, the user will be
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)))
# Line 124  If it is down, start it up (again)." Line 156  If it is down, start it up (again)."
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."
# Line 175  If it is down, start it up (again)." Line 213  If it is down, start it up (again)."
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."
# Line 228  If it is down, start it up (again)." Line 314  If it is down, start it up (again)."
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)
# Line 289  this group uses will be queried." Line 375  this group uses will be queried."
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."
# Line 319  If FETCH-OLD, retrieve all headers (or s Line 410  If FETCH-OLD, retrieve all headers (or s
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)))
# Line 329  If FETCH-OLD, retrieve all headers (or s Line 420  If FETCH-OLD, retrieve all headers (or s
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)))
# Line 358  If BUFFER, insert the article in that gr Line 449  If BUFFER, insert the article in that gr
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)
# Line 387  If BUFFER, insert the article in that gr Line 482  If BUFFER, insert the article in that gr
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)
# Line 418  If GROUP is nil, all groups on GNUS-COMM Line 517  If GROUP is nil, all groups on GNUS-COMM
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."
# Line 428  If GROUP is nil, all groups on GNUS-COMM Line 529  If GROUP is nil, all groups on GNUS-COMM
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.
# Line 457  If GROUP is nil, all groups on GNUS-COMM Line 584  If GROUP is nil, all groups on GNUS-COMM
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)))

Legend:
Removed from v.1.7.6.1  
changed lines
  Added in v.1.7.6.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26