cgit.sxemacs.org Git - gnus/blob - lisp/gnus-int.el

   1 ;;; gnus-int.el --- backend interface functions for Gnus
   2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31
  32 (defcustom gnus-open-server-hook nil
  33   "Hook called just before opening connection to the news server."
  34   :group 'gnus-start
  35   :type 'hook)
  36
  37 ;;;
  38 ;;; Server Communication
  39 ;;;
  40
  41 (defun gnus-start-news-server (&optional confirm)
  42   "Open a method for getting news.
  43 If CONFIRM is non-nil, the user will be asked for an NNTP server."
  44   (let (how)
  45     (if gnus-current-select-method
  46         ;; Stream is already opened.
  47         nil
  48       ;; Open NNTP server.
  49       (unless gnus-nntp-service
  50         (setq gnus-nntp-server nil))
  51       (when confirm
  52         ;; Read server name with completion.
  53         (setq gnus-nntp-server
  54               (completing-read "NNTP server: "
  55                                (mapcar (lambda (server) (list server))
  56                                        (cons (list gnus-nntp-server)
  57                                              gnus-secondary-servers))
  58                                nil nil gnus-nntp-server)))
  59
  60       (when (and gnus-nntp-server
  61                  (stringp gnus-nntp-server)
  62                  (not (string= gnus-nntp-server "")))
  63         (setq gnus-select-method
  64               (cond ((or (string= gnus-nntp-server "")
  65                          (string= gnus-nntp-server "::"))
  66                      (list 'nnspool (system-name)))
  67                     ((string-match "^:" gnus-nntp-server)
  68                      (list 'nnmh gnus-nntp-server
  69                            (list 'nnmh-directory
  70                                  (file-name-as-directory
  71                                   (expand-file-name
  72                                    (concat "~/" (substring
  73                                                  gnus-nntp-server 1)))))
  74                            (list 'nnmh-get-new-mail nil)))
  75                     (t
  76                      (list 'nntp gnus-nntp-server)))))
  77
  78       (setq how (car gnus-select-method))
  79       (cond
  80        ((eq how 'nnspool)
  81         (require 'nnspool)
  82         (gnus-message 5 "Looking up local news spool..."))
  83        ((eq how 'nnmh)
  84         (require 'nnmh)
  85         (gnus-message 5 "Looking up mh spool..."))
  86        (t
  87         (require 'nntp)))
  88       (setq gnus-current-select-method gnus-select-method)
  89       (gnus-run-hooks 'gnus-open-server-hook)
  90       (or
  91        ;; gnus-open-server-hook might have opened it
  92        (gnus-server-opened gnus-select-method)
  93        (gnus-open-server gnus-select-method)
  94        (gnus-y-or-n-p
  95         (format
  96          "%s (%s) open error: '%s'.  Continue? "
  97          (car gnus-select-method) (cadr gnus-select-method)
  98          (gnus-status-message gnus-select-method)))
  99        (gnus-error 1 "Couldn't open server on %s"
 100                    (nth 1 gnus-select-method))))))
 101
 102 (defun gnus-check-group (group)
 103   "Try to make sure that the server where GROUP exists is alive."
 104   (let ((method (gnus-find-method-for-group group)))
 105     (or (gnus-server-opened method)
 106         (gnus-open-server method))))
 107
 108 (defun gnus-check-server (&optional method silent)
 109   "Check whether the connection to METHOD is down.
 110 If METHOD is nil, use `gnus-select-method'.
 111 If it is down, start it up (again)."
 112   (let ((method (or method gnus-select-method)))
 113     ;; Transform virtual server names into select methods.
 114     (when (stringp method)
 115       (setq method (gnus-server-to-method method)))
 116     (if (gnus-server-opened method)
 117         ;; The stream is already opened.
 118         t
 119       ;; Open the server.
 120       (unless silent
 121         (gnus-message 5 "Opening %s server%s..." (car method)
 122                       (if (equal (nth 1 method) "") ""
 123                         (format " on %s" (nth 1 method)))))
 124       (gnus-run-hooks 'gnus-open-server-hook)
 125       (prog1
 126           (gnus-open-server method)
 127         (unless silent
 128           (message ""))))))
 129
 130 (defun gnus-get-function (method function &optional noerror)
 131   "Return a function symbol based on METHOD and FUNCTION."
 132   ;; Translate server names into methods.
 133   (unless method
 134     (error "Attempted use of a nil select method"))
 135   (when (stringp method)
 136     (setq method (gnus-server-to-method method)))
 137   ;; Check cache of constructed names.
 138   (let* ((method-sym (if gnus-agent
 139                          (gnus-agent-get-function method)
 140                        (car method)))
 141          (method-fns (get method-sym 'gnus-method-functions))
 142          (func (let ((method-fnlist-elt (assq function method-fns)))
 143                  (unless method-fnlist-elt
 144                    (setq method-fnlist-elt
 145                          (cons function
 146                                (intern (format "%s-%s" method-sym function))))
 147                    (put method-sym 'gnus-method-functions
 148                         (cons method-fnlist-elt method-fns)))
 149                  (cdr method-fnlist-elt))))
 150     ;; Maybe complain if there is no function.
 151     (unless (fboundp func)
 152       (require (car method))
 153       (when (not (fboundp func))
 154         (if noerror
 155             (setq func nil)
 156           (error "No such function: %s" func))))
 157     func))
 158
 159 \f
 160 ;;;
 161 ;;; Interface functions to the backends.
 162 ;;;
 163
 164 (defun gnus-open-server (gnus-command-method)
 165   "Open a connection to GNUS-COMMAND-METHOD."
 166   (when (stringp gnus-command-method)
 167     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 168   (let ((elem (assoc gnus-command-method gnus-opened-servers)))
 169     ;; If this method was previously denied, we just return nil.
 170     (if (eq (nth 1 elem) 'denied)
 171         (progn
 172           (gnus-message 1 "Denied server")
 173           nil)
 174       ;; Open the server.
 175       (let ((result
 176              (funcall (gnus-get-function gnus-command-method 'open-server)
 177                       (nth 1 gnus-command-method)
 178                       (nthcdr 2 gnus-command-method))))
 179         ;; If this hasn't been opened before, we add it to the list.
 180         (unless elem
 181           (setq elem (list gnus-command-method nil)
 182                 gnus-opened-servers (cons elem gnus-opened-servers)))
 183         ;; Set the status of this server.
 184         (setcar (cdr elem) (if result 'ok 'denied))
 185         ;; Return the result from the "open" call.
 186         result))))
 187
 188 (defun gnus-close-server (gnus-command-method)
 189   "Close the connection to GNUS-COMMAND-METHOD."
 190   (when (stringp gnus-command-method)
 191     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 192   (funcall (gnus-get-function gnus-command-method 'close-server)
 193            (nth 1 gnus-command-method)))
 194
 195 (defun gnus-request-list (gnus-command-method)
 196   "Request the active file from GNUS-COMMAND-METHOD."
 197   (when (stringp gnus-command-method)
 198     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 199   (funcall (gnus-get-function gnus-command-method 'request-list)
 200            (nth 1 gnus-command-method)))
 201
 202 (defun gnus-request-list-newsgroups (gnus-command-method)
 203   "Request the newsgroups file from GNUS-COMMAND-METHOD."
 204   (when (stringp gnus-command-method)
 205     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 206   (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups)
 207            (nth 1 gnus-command-method)))
 208
 209 (defun gnus-request-newgroups (date gnus-command-method)
 210   "Request all new groups since DATE from GNUS-COMMAND-METHOD."
 211   (when (stringp gnus-command-method)
 212     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 213   (let ((func (gnus-get-function gnus-command-method 'request-newgroups t)))
 214     (when func
 215       (funcall func date (nth 1 gnus-command-method)))))
 216
 217 (defun gnus-server-opened (gnus-command-method)
 218   "Check whether a connection to GNUS-COMMAND-METHOD has been opened."
 219   (when (stringp gnus-command-method)
 220     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 221   (funcall (inline (gnus-get-function gnus-command-method 'server-opened))
 222            (nth 1 gnus-command-method)))
 223
 224 (defun gnus-status-message (gnus-command-method)
 225   "Return the status message from GNUS-COMMAND-METHOD.
 226 If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name.   The method
 227 this group uses will be queried."
 228   (let ((gnus-command-method
 229          (if (stringp gnus-command-method)
 230              (gnus-find-method-for-group gnus-command-method)
 231            gnus-command-method)))
 232     (funcall (gnus-get-function gnus-command-method 'status-message)
 233              (nth 1 gnus-command-method))))
 234
 235 (defun gnus-request-regenerate (gnus-command-method)
 236   "Request a data generation from GNUS-COMMAND-METHOD."
 237   (when (stringp gnus-command-method)
 238     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 239   (funcall (gnus-get-function gnus-command-method 'request-regenerate)
 240            (nth 1 gnus-command-method)))
 241
 242 (defun gnus-request-group (group &optional dont-check gnus-command-method)
 243   "Request GROUP.  If DONT-CHECK, no information is required."
 244   (let ((gnus-command-method
 245          (or gnus-command-method (inline (gnus-find-method-for-group group)))))
 246     (when (stringp gnus-command-method)
 247       (setq gnus-command-method
 248             (inline (gnus-server-to-method gnus-command-method))))
 249     (funcall (inline (gnus-get-function gnus-command-method 'request-group))
 250              (gnus-group-real-name group) (nth 1 gnus-command-method)
 251              dont-check)))
 252
 253 (defun gnus-list-active-group (group)
 254   "Request active information on GROUP."
 255   (let ((gnus-command-method (gnus-find-method-for-group group))
 256         (func 'list-active-group))
 257     (when (gnus-check-backend-function func group)
 258       (funcall (gnus-get-function gnus-command-method func)
 259                (gnus-group-real-name group) (nth 1 gnus-command-method)))))
 260
 261 (defun gnus-request-group-description (group)
 262   "Request a description of GROUP."
 263   (let ((gnus-command-method (gnus-find-method-for-group group))
 264         (func 'request-group-description))
 265     (when (gnus-check-backend-function func group)
 266       (funcall (gnus-get-function gnus-command-method func)
 267                (gnus-group-real-name group) (nth 1 gnus-command-method)))))
 268
 269 (defun gnus-close-group (group)
 270   "Request the GROUP be closed."
 271   (let ((gnus-command-method (inline (gnus-find-method-for-group group))))
 272     (funcall (gnus-get-function gnus-command-method 'close-group)
 273              (gnus-group-real-name group) (nth 1 gnus-command-method))))
 274
 275 (defun gnus-retrieve-headers (articles group &optional fetch-old)
 276   "Request headers for ARTICLES in GROUP.
 277 If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
 278   (let ((gnus-command-method (gnus-find-method-for-group group)))
 279     (if (and gnus-use-cache (numberp (car articles)))
 280         (gnus-cache-retrieve-headers articles group fetch-old)
 281       (funcall (gnus-get-function gnus-command-method 'retrieve-headers)
 282                articles (gnus-group-real-name group)
 283                (nth 1 gnus-command-method) fetch-old))))
 284
 285 (defun gnus-retrieve-articles (articles group)
 286   "Request ARTICLES in GROUP."
 287   (let ((gnus-command-method (gnus-find-method-for-group group)))
 288     (funcall (gnus-get-function gnus-command-method 'retrieve-articles)
 289              articles (gnus-group-real-name group)
 290              (nth 1 gnus-command-method))))
 291
 292 (defun gnus-retrieve-groups (groups gnus-command-method)
 293   "Request active information on GROUPS from GNUS-COMMAND-METHOD."
 294   (when (stringp gnus-command-method)
 295     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 296   (funcall (gnus-get-function gnus-command-method 'retrieve-groups)
 297            groups (nth 1 gnus-command-method)))
 298
 299 (defun gnus-request-type (group &optional article)
 300   "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
 301   (let ((gnus-command-method (gnus-find-method-for-group group)))
 302     (if (not (gnus-check-backend-function
 303               'request-type (car gnus-command-method)))
 304         'unknown
 305       (funcall (gnus-get-function gnus-command-method 'request-type)
 306                (gnus-group-real-name group) article))))
 307
 308 (defun gnus-request-update-mark (group article mark)
 309   "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
 310   (let ((gnus-command-method (gnus-find-method-for-group group)))
 311     (if (not (gnus-check-backend-function
 312               'request-update-mark (car gnus-command-method)))
 313         mark
 314       (funcall (gnus-get-function gnus-command-method 'request-update-mark)
 315                (gnus-group-real-name group) article mark))))
 316
 317 (defun gnus-request-article (article group &optional buffer)
 318   "Request the ARTICLE in GROUP.
 319 ARTICLE can either be an article number or an article Message-ID.
 320 If BUFFER, insert the article in that group."
 321   (let ((gnus-command-method (gnus-find-method-for-group group)))
 322     (funcall (gnus-get-function gnus-command-method 'request-article)
 323              article (gnus-group-real-name group)
 324              (nth 1 gnus-command-method) buffer)))
 325
 326 (defun gnus-request-head (article group)
 327   "Request the head of ARTICLE in GROUP."
 328   (let* ((gnus-command-method (gnus-find-method-for-group group))
 329          (head (gnus-get-function gnus-command-method 'request-head t))
 330          res clean-up)
 331     (cond
 332      ;; Check the cache.
 333      ((and gnus-use-cache
 334            (numberp article)
 335            (gnus-cache-request-article article group))
 336       (setq res (cons group article)
 337             clean-up t))
 338      ;; Use `head' function.
 339      ((fboundp head)
 340       (setq res (funcall head article (gnus-group-real-name group)
 341                          (nth 1 gnus-command-method))))
 342      ;; Use `article' function.
 343      (t
 344       (setq res (gnus-request-article article group)
 345             clean-up t)))
 346     (when clean-up
 347       (save-excursion
 348         (set-buffer nntp-server-buffer)
 349         (goto-char (point-min))
 350         (when (search-forward "\n\n" nil t)
 351           (delete-region (1- (point)) (point-max)))
 352         (nnheader-fold-continuation-lines)))
 353     res))
 354
 355 (defun gnus-request-body (article group)
 356   "Request the body of ARTICLE in GROUP."
 357   (let* ((gnus-command-method (gnus-find-method-for-group group))
 358          (head (gnus-get-function gnus-command-method 'request-body t))
 359          res clean-up)
 360     (cond
 361      ;; Check the cache.
 362      ((and gnus-use-cache
 363            (numberp article)
 364            (gnus-cache-request-article article group))
 365       (setq res (cons group article)
 366             clean-up t))
 367      ;; Use `head' function.
 368      ((fboundp head)
 369       (setq res (funcall head article (gnus-group-real-name group)
 370                          (nth 1 gnus-command-method))))
 371      ;; Use `article' function.
 372      (t
 373       (setq res (gnus-request-article article group)
 374             clean-up t)))
 375     (when clean-up
 376       (save-excursion
 377         (set-buffer nntp-server-buffer)
 378         (goto-char (point-min))
 379         (when (search-forward "\n\n" nil t)
 380           (delete-region (point-min) (1- (point))))))
 381     res))
 382
 383 (defun gnus-request-post (gnus-command-method)
 384   "Post the current buffer using GNUS-COMMAND-METHOD."
 385   (when (stringp gnus-command-method)
 386     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 387   (funcall (gnus-get-function gnus-command-method 'request-post)
 388            (nth 1 gnus-command-method)))
 389
 390 (defun gnus-request-scan (group gnus-command-method)
 391   "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
 392 If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
 393   (when gnus-plugged
 394     (let ((gnus-command-method
 395            (if group (gnus-find-method-for-group group) gnus-command-method))
 396           (gnus-inhibit-demon t))
 397       (funcall (gnus-get-function gnus-command-method 'request-scan)
 398                (and group (gnus-group-real-name group))
 399                (nth 1 gnus-command-method)))))
 400
 401 (defsubst gnus-request-update-info (info gnus-command-method)
 402   "Request that GNUS-COMMAND-METHOD update INFO."
 403   (when (stringp gnus-command-method)
 404     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 405   (when (gnus-check-backend-function
 406          'request-update-info (car gnus-command-method))
 407     (funcall (gnus-get-function gnus-command-method 'request-update-info)
 408              (gnus-group-real-name (gnus-info-group info))
 409              info (nth 1 gnus-command-method))))
 410
 411 (defun gnus-request-expire-articles (articles group &optional force)
 412   (let ((gnus-command-method (gnus-find-method-for-group group)))
 413     (funcall (gnus-get-function gnus-command-method 'request-expire-articles)
 414              articles (gnus-group-real-name group) (nth 1 gnus-command-method)
 415              force)))
 416
 417 (defun gnus-request-move-article
 418   (article group server accept-function &optional last)
 419   (let ((gnus-command-method (gnus-find-method-for-group group)))
 420     (funcall (gnus-get-function gnus-command-method 'request-move-article)
 421              article (gnus-group-real-name group)
 422              (nth 1 gnus-command-method) accept-function last)))
 423
 424 (defun gnus-request-accept-article (group &optional gnus-command-method last)
 425   ;; Make sure there's a newline at the end of the article.
 426   (when (stringp gnus-command-method)
 427     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 428   (when (and (not gnus-command-method)
 429              (stringp group))
 430     (setq gnus-command-method (gnus-group-name-to-method group)))
 431   (goto-char (point-max))
 432   (unless (bolp)
 433     (insert "\n"))
 434   (let ((func (car (or gnus-command-method
 435                        (gnus-find-method-for-group group)))))
 436     (funcall (intern (format "%s-request-accept-article" func))
 437              (if (stringp group) (gnus-group-real-name group) group)
 438              (cadr gnus-command-method)
 439              last)))
 440
 441 (defun gnus-request-replace-article (article group buffer)
 442   (let ((func (car (gnus-group-name-to-method group))))
 443     (funcall (intern (format "%s-request-replace-article" func))
 444              article (gnus-group-real-name group) buffer)))
 445
 446 (defun gnus-request-associate-buffer (group)
 447   (let ((gnus-command-method (gnus-find-method-for-group group)))
 448     (funcall (gnus-get-function gnus-command-method 'request-associate-buffer)
 449              (gnus-group-real-name group))))
 450
 451 (defun gnus-request-restore-buffer (article group)
 452   "Request a new buffer restored to the state of ARTICLE."
 453   (let ((gnus-command-method (gnus-find-method-for-group group)))
 454     (funcall (gnus-get-function gnus-command-method 'request-restore-buffer)
 455              article (gnus-group-real-name group)
 456              (nth 1 gnus-command-method))))
 457
 458 (defun gnus-request-create-group (group &optional gnus-command-method args)
 459   (when (stringp gnus-command-method)
 460     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 461   (let ((gnus-command-method
 462          (or gnus-command-method (gnus-find-method-for-group group))))
 463     (funcall (gnus-get-function gnus-command-method 'request-create-group)
 464              (gnus-group-real-name group) (nth 1 gnus-command-method) args)))
 465
 466 (defun gnus-request-delete-group (group &optional force)
 467   (let ((gnus-command-method (gnus-find-method-for-group group)))
 468     (funcall (gnus-get-function gnus-command-method 'request-delete-group)
 469              (gnus-group-real-name group) force (nth 1 gnus-command-method))))
 470
 471 (defun gnus-request-rename-group (group new-name)
 472   (let ((gnus-command-method (gnus-find-method-for-group group)))
 473     (funcall (gnus-get-function gnus-command-method 'request-rename-group)
 474              (gnus-group-real-name group)
 475              (gnus-group-real-name new-name) (nth 1 gnus-command-method))))
 476
 477 (defun gnus-close-backends ()
 478   ;; Send a close request to all backends that support such a request.
 479   (let ((methods gnus-valid-select-methods)
 480         (gnus-inhibit-demon t)
 481         func gnus-command-method)
 482     (while (setq gnus-command-method (pop methods))
 483       (when (fboundp (setq func (intern
 484                                  (concat (car gnus-command-method)
 485                                          "-request-close"))))
 486         (funcall func)))))
 487
 488 (defun gnus-asynchronous-p (gnus-command-method)
 489   (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t)))
 490     (when (fboundp func)
 491       (funcall func))))
 492
 493 (defun gnus-remove-denial (gnus-command-method)
 494   (when (stringp gnus-command-method)
 495     (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
 496   (let* ((elem (assoc gnus-command-method gnus-opened-servers))
 497          (status (cadr elem)))
 498     ;; If this hasn't been opened before, we add it to the list.
 499     (when (eq status 'denied)
 500       ;; Set the status of this server.
 501       (setcar (cdr elem) 'closed))))
 502
 503 (provide 'gnus-int)
 504
 505 ;;; gnus-int.el ends here