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

   1 ;;; gnus.el --- a newsreader for GNU Emacs
   2 ;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval '(run-hooks 'gnus-load-hook))
  30
  31 (defconst gnus-version-number "0.29"
  32   "Version number for this version of Gnus.")
  33
  34 (defconst gnus-version (format "Red Gnus v%s" gnus-version-number)
  35   "Version string for this version of Gnus.")
  36
  37 (defvar gnus-inhibit-startup-message nil
  38   "*If non-nil, the startup message will not be displayed.")
  39
  40 (defvar gnus-play-startup-jingle nil
  41   "If non-nil, play the Gnus jingle at startup.")
  42
  43 ;;; Internal variables
  44
  45 (defvar gnus-group-buffer "*Group*")
  46
  47 (eval-and-compile
  48   (autoload 'gnus-play-jingle "gnus-audio"))
  49
  50 ;;; Splash screen.
  51
  52 (defun gnus-splash ()
  53   (save-excursion
  54     (switch-to-buffer gnus-group-buffer)
  55     (let ((buffer-read-only nil))
  56       (erase-buffer)
  57       (unless gnus-inhibit-startup-message
  58         (gnus-group-startup-message)
  59         (sit-for 0)
  60         (when gnus-play-startup-jingle
  61           (gnus-play-jingle))))))
  62
  63 (defun gnus-indent-rigidly (start end arg)
  64   "Indent rigidly using only spaces and no tabs."
  65   (save-excursion
  66     (save-restriction
  67       (narrow-to-region start end)
  68       (indent-rigidly start end arg)
  69       ;; We translate tabs into spaces -- not everybody uses
  70       ;; an 8-character tab.
  71       (goto-char (point-min))
  72       (while (search-forward "\t" nil t)
  73         (replace-match "        " t t)))))
  74
  75 (defun gnus-group-startup-message (&optional x y)
  76   "Insert startup message in current buffer."
  77   ;; Insert the message.
  78   (erase-buffer)
  79   (insert
  80    (format "              %s
  81           _    ___ _             _
  82           _ ___ __ ___  __    _ ___
  83           __   _     ___    __  ___
  84               _           ___     _
  85              _  _ __             _
  86              ___   __            _
  87                    __           _
  88                     _      _   _
  89                    _      _    _
  90                       _  _    _
  91                   __  ___
  92                  _   _ _     _
  93                 _   _
  94               _    _
  95              _    _
  96             _
  97           __
  98
  99 "
 100            ""))
 101   ;; And then hack it.
 102   (gnus-indent-rigidly (point-min) (point-max)
 103                        (/ (max (- (window-width) (or x 46)) 0) 2))
 104   (goto-char (point-min))
 105   (forward-line 1)
 106   (let* ((pheight (count-lines (point-min) (point-max)))
 107          (wheight (window-height))
 108          (rest (- wheight pheight)))
 109     (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
 110   ;; Fontify some.
 111   (goto-char (point-min))
 112   (and (search-forward "Praxis" nil t)
 113        (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 114   (goto-char (point-min))
 115   (setq mode-line-buffer-identification gnus-version)
 116   (set-buffer-modified-p t))
 117
 118 (eval-when (load)
 119   (when (string-match "gnus" (format "%s" this-command))
 120     (gnus-splash)))
 121
 122 ;;; Do the rest.
 123
 124 (require 'gnus-load)
 125
 126 \f
 127
 128 ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
 129 ;; If you want the cursor to go somewhere else, set these two
 130 ;; functions in some startup hook to whatever you want.
 131 (defalias 'gnus-summary-position-point 'gnus-goto-colon)
 132 (defalias 'gnus-group-position-point 'gnus-goto-colon)
 133
 134 ;;; Various macros and substs.
 135
 136 (defun gnus-header-from (header)
 137   (mail-header-from header))
 138
 139 (defmacro gnus-gethash (string hashtable)
 140   "Get hash value of STRING in HASHTABLE."
 141   `(symbol-value (intern-soft ,string ,hashtable)))
 142
 143 (defmacro gnus-sethash (string value hashtable)
 144   "Set hash value.  Arguments are STRING, VALUE, and HASHTABLE."
 145   `(set (intern ,string ,hashtable) ,value))
 146 (put 'nnheader-temp-write 'edebug-form-spec '(form form form))
 147
 148 (defmacro gnus-group-unread (group)
 149   "Get the currently computed number of unread articles in GROUP."
 150   `(car (gnus-gethash ,group gnus-newsrc-hashtb)))
 151
 152 (defmacro gnus-group-entry (group)
 153   "Get the newsrc entry for GROUP."
 154   `(gnus-gethash ,group gnus-newsrc-hashtb))
 155
 156 (defmacro gnus-active (group)
 157   "Get active info on GROUP."
 158   `(gnus-gethash ,group gnus-active-hashtb))
 159
 160 (defmacro gnus-set-active (group active)
 161   "Set GROUP's active info."
 162   `(gnus-sethash ,group ,active gnus-active-hashtb))
 163
 164 (defun gnus-alive-p ()
 165   "Say whether Gnus is running or not."
 166   (and gnus-group-buffer
 167        (get-buffer gnus-group-buffer)
 168        (save-excursion
 169          (set-buffer gnus-group-buffer)
 170          (eq major-mode 'gnus-group-mode))))
 171
 172 ;; Info access macros.
 173
 174 (defmacro gnus-info-group (info)
 175   `(nth 0 ,info))
 176 (defmacro gnus-info-rank (info)
 177   `(nth 1 ,info))
 178 (defmacro gnus-info-read (info)
 179   `(nth 2 ,info))
 180 (defmacro gnus-info-marks (info)
 181   `(nth 3 ,info))
 182 (defmacro gnus-info-method (info)
 183   `(nth 4 ,info))
 184 (defmacro gnus-info-params (info)
 185   `(nth 5 ,info))
 186
 187 (defmacro gnus-info-level (info)
 188   `(let ((rank (gnus-info-rank ,info)))
 189      (if (consp rank)
 190          (car rank)
 191        rank)))
 192 (defmacro gnus-info-score (info)
 193   `(let ((rank (gnus-info-rank ,info)))
 194      (or (and (consp rank) (cdr rank)) 0)))
 195
 196 (defmacro gnus-info-set-group (info group)
 197   `(setcar ,info ,group))
 198 (defmacro gnus-info-set-rank (info rank)
 199   `(setcar (nthcdr 1 ,info) ,rank))
 200 (defmacro gnus-info-set-read (info read)
 201   `(setcar (nthcdr 2 ,info) ,read))
 202 (defmacro gnus-info-set-marks (info marks &optional extend)
 203   (if extend
 204       `(gnus-info-set-entry ,info ,marks 3)
 205     `(setcar (nthcdr 3 ,info) ,marks)))
 206 (defmacro gnus-info-set-method (info method &optional extend)
 207   (if extend
 208       `(gnus-info-set-entry ,info ,method 4)
 209     `(setcar (nthcdr 4 ,info) ,method)))
 210 (defmacro gnus-info-set-params (info params &optional extend)
 211   (if extend
 212       `(gnus-info-set-entry ,info ,params 5)
 213     `(setcar (nthcdr 5 ,info) ,params)))
 214
 215 (defun gnus-info-set-entry (info entry number)
 216   ;; Extend the info until we have enough elements.
 217   (while (< (length info) number)
 218     (nconc info (list nil)))
 219   ;; Set the entry.
 220   (setcar (nthcdr number info) entry))
 221
 222 (defmacro gnus-info-set-level (info level)
 223   `(let ((rank (cdr ,info)))
 224      (if (consp (car rank))
 225          (setcar (car rank) ,level)
 226        (setcar rank ,level))))
 227 (defmacro gnus-info-set-score (info score)
 228   `(let ((rank (cdr ,info)))
 229      (if (consp (car rank))
 230          (setcdr (car rank) ,score)
 231        (setcar rank (cons (car rank) ,score)))))
 232
 233 (defmacro gnus-get-info (group)
 234   `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb)))
 235
 236 ;; Byte-compiler warning.
 237 (defvar gnus-visual)
 238 ;; Find out whether the gnus-visual TYPE is wanted.
 239 (defun gnus-visual-p (&optional type class)
 240   (and gnus-visual                      ; Has to be non-nil, at least.
 241        (if (not type)                   ; We don't care about type.
 242            gnus-visual
 243          (if (listp gnus-visual)        ; It's a list, so we check it.
 244              (or (memq type gnus-visual)
 245                  (memq class gnus-visual))
 246            t))))
 247
 248 ;;; Load the compatability functions.
 249
 250 (require 'gnus-cus)
 251 (require 'gnus-ems)
 252
 253 \f
 254 ;;;
 255 ;;; Shutdown
 256 ;;;
 257
 258 (defvar gnus-shutdown-alist nil)
 259
 260 (defun gnus-add-shutdown (function &rest symbols)
 261   "Run FUNCTION whenever one of SYMBOLS is shut down."
 262   (push (cons function symbols) gnus-shutdown-alist))
 263
 264 (defun gnus-shutdown (symbol)
 265   "Shut down everything that waits for SYMBOL."
 266   (let ((alist gnus-shutdown-alist)
 267         entry)
 268     (while (setq entry (pop alist))
 269       (when (memq symbol (cdr entry))
 270         (funcall (car entry))))))
 271
 272 \f
 273 ;;;
 274 ;;; Gnus Utility Functions
 275 ;;;
 276
 277 ;; Add the current buffer to the list of buffers to be killed on exit.
 278 (defun gnus-add-current-to-buffer-list ()
 279   (or (memq (current-buffer) gnus-buffer-list)
 280       (setq gnus-buffer-list (cons (current-buffer) gnus-buffer-list))))
 281
 282 (defun gnus-version (&optional arg)
 283   "Version number of this version of Gnus.
 284 If ARG, insert string at point."
 285   (interactive "P")
 286   (let ((methods gnus-valid-select-methods)
 287         (mess gnus-version)
 288         meth)
 289     ;; Go through all the legal select methods and add their version
 290     ;; numbers to the total version string.  Only the backends that are
 291     ;; currently in use will have their message numbers taken into
 292     ;; consideration.
 293     (while methods
 294       (setq meth (intern (concat (caar methods) "-version")))
 295       (and (boundp meth)
 296            (stringp (symbol-value meth))
 297            (setq mess (concat mess "; " (symbol-value meth))))
 298       (setq methods (cdr methods)))
 299     (if arg
 300         (insert (message mess))
 301       (message mess))))
 302
 303 (defun gnus-continuum-version (version)
 304   "Return VERSION as a floating point number."
 305   (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version)
 306             (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version))
 307     (let* ((alpha (and (match-beginning 1) (match-string 1 version)))
 308            (number (match-string 2 version))
 309            major minor least)
 310       (string-match "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number)
 311       (setq major (string-to-number (match-string 1 number)))
 312       (setq minor (string-to-number (match-string 2 number)))
 313       (setq least (if (match-beginning 3)
 314                       (string-to-number (match-string 3 number))
 315                     0))
 316       (string-to-number
 317        (if (zerop major)
 318            (format "%s00%02d%02d"
 319                    (cond
 320                     ((member alpha '("(ding)" "d")) "4.99")
 321                     ((member alpha '("September" "s")) "5.01")
 322                     ((member alpha '("Red" "r")) "5.03"))
 323                    minor least)
 324          (format "%d.%02d%02d" major minor least))))))
 325
 326 (defun gnus-info-find-node ()
 327   "Find Info documentation of Gnus."
 328   (interactive)
 329   ;; Enlarge info window if needed.
 330   (let (gnus-info-buffer)
 331     (Info-goto-node (cadr (assq major-mode gnus-info-nodes)))
 332     (setq gnus-info-buffer (current-buffer))
 333     (gnus-configure-windows 'info)))
 334
 335 ;;; More various functions.
 336
 337 (defun gnus-group-read-only-p (&optional group)
 338   "Check whether GROUP supports editing or not.
 339 If GROUP is nil, `gnus-newsgroup-name' will be checked instead.  Note
 340 that that variable is buffer-local to the summary buffers."
 341   (let ((group (or group gnus-newsgroup-name)))
 342     (not (gnus-check-backend-function 'request-replace-article group))))
 343
 344 (defun gnus-group-total-expirable-p (group)
 345   "Check whether GROUP is total-expirable or not."
 346   (let ((params (gnus-group-find-parameter group))
 347         val)
 348     (cond
 349      ((memq 'total-expire params)
 350       t)
 351      ((setq val (assq 'total-expire params)) ; (auto-expire . t)
 352       (cdr val))
 353      (gnus-total-expirable-newsgroups   ; Check var.
 354       (string-match gnus-total-expirable-newsgroups group)))))
 355
 356 (defun gnus-group-auto-expirable-p (group)
 357   "Check whether GROUP is total-expirable or not."
 358   (let ((params (gnus-group-find-parameter group))
 359         val)
 360     (cond
 361      ((memq 'auto-expire params)
 362       t)
 363      ((setq val (assq 'auto-expire params)) ; (auto-expire . t)
 364       (cdr val))
 365      (gnus-auto-expirable-newsgroups    ; Check var.
 366       (string-match gnus-auto-expirable-newsgroups group)))))
 367
 368 (defun gnus-virtual-group-p (group)
 369   "Say whether GROUP is virtual or not."
 370   (memq 'virtual (assoc (symbol-name (car (gnus-find-method-for-group group)))
 371                         gnus-valid-select-methods)))
 372
 373 (defun gnus-news-group-p (group &optional article)
 374   "Return non-nil if GROUP (and ARTICLE) come from a news server."
 375   (or (gnus-member-of-valid 'post group) ; Ordinary news group.
 376       (and (gnus-member-of-valid 'post-mail group) ; Combined group.
 377            (eq (gnus-request-type group article) 'news))))
 378
 379 ;; Returns a list of writable groups.
 380 (defun gnus-writable-groups ()
 381   (let ((alist gnus-newsrc-alist)
 382         groups group)
 383     (while (setq group (car (pop alist)))
 384       (unless (gnus-group-read-only-p group)
 385         (push group groups)))
 386     (nreverse groups)))
 387
 388 ;; Check whether to use long file names.
 389 (defun gnus-use-long-file-name (symbol)
 390   ;; The variable has to be set...
 391   (and gnus-use-long-file-name
 392        ;; If it isn't a list, then we return t.
 393        (or (not (listp gnus-use-long-file-name))
 394            ;; If it is a list, and the list contains `symbol', we
 395            ;; return nil.
 396            (not (memq symbol gnus-use-long-file-name)))))
 397
 398 ;; Generate a unique new group name.
 399 (defun gnus-generate-new-group-name (leaf)
 400   (let ((name leaf)
 401         (num 0))
 402     (while (gnus-gethash name gnus-newsrc-hashtb)
 403       (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">")))
 404     name))
 405
 406 (defun gnus-ephemeral-group-p (group)
 407   "Say whether GROUP is ephemeral or not."
 408   (gnus-group-get-parameter group 'quit-config))
 409
 410 (defun gnus-group-quit-config (group)
 411   "Return the quit-config of GROUP."
 412   (gnus-group-get-parameter group 'quit-config))
 413
 414 (defun gnus-simplify-mode-line ()
 415   "Make mode lines a bit simpler."
 416   (setq mode-line-modified "-- ")
 417   (when (listp mode-line-format)
 418     (make-local-variable 'mode-line-format)
 419     (setq mode-line-format (copy-sequence mode-line-format))
 420     (when (equal (nth 3 mode-line-format) "   ")
 421       (setcar (nthcdr 3 mode-line-format) " "))))
 422
 423 ;;; Servers and groups.
 424
 425 (defsubst gnus-server-add-address (method)
 426   (let ((method-name (symbol-name (car method))))
 427     (if (and (memq 'address (assoc method-name gnus-valid-select-methods))
 428              (not (assq (intern (concat method-name "-address")) method)))
 429         (append method (list (list (intern (concat method-name "-address"))
 430                                    (nth 1 method))))
 431       method)))
 432
 433 (defsubst gnus-server-get-method (group method)
 434   ;; Input either a server name, and extended server name, or a
 435   ;; select method, and return a select method.
 436   (cond ((stringp method)
 437          (gnus-server-to-method method))
 438         ((equal method gnus-select-method)
 439          gnus-select-method)
 440         ((and (stringp (car method)) group)
 441          (gnus-server-extend-method group method))
 442         ((and method (not group)
 443               (equal (cadr method) ""))
 444          method)
 445         (t
 446          (gnus-server-add-address method))))
 447
 448 (defun gnus-server-to-method (server)
 449   "Map virtual server names to select methods."
 450   (or
 451    ;; Is this a method, perhaps?
 452    (and server (listp server) server)
 453    ;; Perhaps this is the native server?
 454    (and (equal server "native") gnus-select-method)
 455    ;; It should be in the server alist.
 456    (cdr (assoc server gnus-server-alist))
 457    ;; It could be in the predefined server alist.
 458    (cdr (assoc server gnus-predefined-server-alist))
 459    ;; If not, we look through all the opened server
 460    ;; to see whether we can find it there.
 461    (let ((opened gnus-opened-servers))
 462      (while (and opened
 463                  (not (equal server (format "%s:%s" (caaar opened)
 464                                             (cadaar opened)))))
 465        (pop opened))
 466      (caar opened))))
 467
 468 (defmacro gnus-method-equal (ss1 ss2)
 469   "Say whether two servers are equal."
 470   `(let ((s1 ,ss1)
 471          (s2 ,ss2))
 472      (or (equal s1 s2)
 473          (and (= (length s1) (length s2))
 474               (progn
 475                 (while (and s1 (member (car s1) s2))
 476                   (setq s1 (cdr s1)))
 477                 (null s1))))))
 478
 479 (defun gnus-server-equal (m1 m2)
 480   "Say whether two methods are equal."
 481   (let ((m1 (cond ((null m1) gnus-select-method)
 482                   ((stringp m1) (gnus-server-to-method m1))
 483                   (t m1)))
 484         (m2 (cond ((null m2) gnus-select-method)
 485                   ((stringp m2) (gnus-server-to-method m2))
 486                   (t m2))))
 487     (gnus-method-equal m1 m2)))
 488
 489 (defun gnus-servers-using-backend (backend)
 490   "Return a list of known servers using BACKEND."
 491   (let ((opened gnus-opened-servers)
 492         out)
 493     (while opened
 494       (when (eq backend (caaar opened))
 495         (push (caar opened) out))
 496       (pop opened))
 497     out))
 498
 499 (defun gnus-archive-server-wanted-p ()
 500   "Say whether the user wants to use the archive server."
 501   (cond
 502    ((or (not gnus-message-archive-method)
 503         (not gnus-message-archive-group))
 504     nil)
 505    ((and gnus-message-archive-method gnus-message-archive-group)
 506     t)
 507    (t
 508     (let ((active (cadr (assq 'nnfolder-active-file
 509                               gnus-message-archive-method))))
 510       (and active
 511            (file-exists-p active))))))
 512
 513 (defun gnus-group-prefixed-name (group method)
 514   "Return the whole name from GROUP and METHOD."
 515   (and (stringp method) (setq method (gnus-server-to-method method)))
 516   (if (not method)
 517       group
 518     (concat (format "%s" (car method))
 519             (if (and
 520                  (or (assoc (format "%s" (car method))
 521                             (gnus-methods-using 'address))
 522                      (gnus-server-equal method gnus-message-archive-method))
 523                  (nth 1 method)
 524                  (not (string= (nth 1 method) "")))
 525                 (concat "+" (nth 1 method)))
 526             ":" group)))
 527
 528 (defun gnus-group-real-prefix (group)
 529   "Return the prefix of the current group name."
 530   (if (string-match "^[^:]+:" group)
 531       (substring group 0 (match-end 0))
 532     ""))
 533
 534 (defun gnus-group-method (group)
 535   "Return the server or method used for selecting GROUP."
 536   (let ((prefix (gnus-group-real-prefix group)))
 537     (if (equal prefix "")
 538         gnus-select-method
 539       (let ((servers gnus-opened-servers)
 540             (server "")
 541             backend possible found)
 542         (if (string-match "^[^\\+]+\\+" prefix)
 543             (setq backend (intern (substring prefix 0 (1- (match-end 0))))
 544                   server (substring prefix (match-end 0) (1- (length prefix))))
 545           (setq backend (intern (substring prefix 0 (1- (length prefix))))))
 546         (while servers
 547           (when (eq (caaar servers) backend)
 548             (setq possible (caar servers))
 549             (when (equal (cadaar servers) server)
 550               (setq found (caar servers))))
 551           (pop servers))
 552         (or (car (rassoc found gnus-server-alist))
 553             found
 554             (car (rassoc possible gnus-server-alist))
 555             possible
 556             (list backend server))))))
 557
 558 (defsubst gnus-secondary-method-p (method)
 559   "Return whether METHOD is a secondary select method."
 560   (let ((methods gnus-secondary-select-methods)
 561         (gmethod (gnus-server-get-method nil method)))
 562     (while (and methods
 563                 (not (equal (gnus-server-get-method nil (car methods))
 564                             gmethod)))
 565       (setq methods (cdr methods)))
 566     methods))
 567
 568 (defun gnus-group-foreign-p (group)
 569   "Say whether a group is foreign or not."
 570   (and (not (gnus-group-native-p group))
 571        (not (gnus-group-secondary-p group))))
 572
 573 (defun gnus-group-native-p (group)
 574   "Say whether the group is native or not."
 575   (not (string-match ":" group)))
 576
 577 (defun gnus-group-secondary-p (group)
 578   "Say whether the group is secondary or not."
 579   (gnus-secondary-method-p (gnus-find-method-for-group group)))
 580
 581 (defun gnus-group-find-parameter (group &optional symbol)
 582   "Return the group parameters for GROUP.
 583 If SYMBOL, return the value of that symbol in the group parameters."
 584   (save-excursion
 585     (set-buffer gnus-group-buffer)
 586     (let ((parameters (funcall gnus-group-get-parameter-function group)))
 587       (if symbol
 588           (gnus-group-parameter-value parameters symbol)
 589         parameters))))
 590
 591 (defun gnus-group-get-parameter (group &optional symbol)
 592   "Return the group parameters for GROUP.
 593 If SYMBOL, return the value of that symbol in the group parameters."
 594   (let ((params (gnus-info-params (gnus-get-info group))))
 595     (if symbol
 596         (gnus-group-parameter-value params symbol)
 597       params)))
 598
 599 (defun gnus-group-parameter-value (params symbol)
 600   "Return the value of SYMBOL in group PARAMS."
 601   (or (car (memq symbol params))        ; It's either a simple symbol
 602       (cdr (assq symbol params))))      ; or a cons.
 603
 604 (defun gnus-group-add-parameter (group param)
 605   "Add parameter PARAM to GROUP."
 606   (let ((info (gnus-get-info group)))
 607     (if (not info)
 608         ()                              ; This is a dead group.  We just ignore it.
 609       ;; Cons the new param to the old one and update.
 610       (gnus-group-set-info (cons param (gnus-info-params info))
 611                            group 'params))))
 612
 613 (defun gnus-group-set-parameter (group name value)
 614   "Set parameter NAME to VALUE in GROUP."
 615   (let ((info (gnus-get-info group)))
 616     (if (not info)
 617         ()                              ; This is a dead group.  We just ignore it.
 618       (let ((old-params (gnus-info-params info))
 619             (new-params (list (cons name value))))
 620         (while old-params
 621           (if (or (not (listp (car old-params)))
 622                   (not (eq (caar old-params) name)))
 623               (setq new-params (append new-params (list (car old-params)))))
 624           (setq old-params (cdr old-params)))
 625         (gnus-group-set-info new-params group 'params)))))
 626
 627 (defun gnus-group-add-score (group &optional score)
 628   "Add SCORE to the GROUP score.
 629 If SCORE is nil, add 1 to the score of GROUP."
 630   (let ((info (gnus-get-info group)))
 631     (when info
 632       (gnus-info-set-score info (+ (gnus-info-score info) (or score 1))))))
 633
 634 ;; Function written by Stainless Steel Rat <ratinox@peorth.gweep.net>
 635 (defun gnus-short-group-name (group &optional levels)
 636   "Collapse GROUP name LEVELS.
 637 Select methods are stripped and any remote host name is stripped down to
 638 just the host name."
 639   (let* ((name "") (foreign "") (depth -1) (skip 1)
 640          (levels (or levels
 641                      (progn
 642                        (while (string-match "\\." group skip)
 643                          (setq skip (match-end 0)
 644                                depth (+ depth 1)))
 645                        depth))))
 646     ;; separate foreign select method from group name and collapse.
 647     ;; if method contains a server, collapse to non-domain server name,
 648     ;; otherwise collapse to select method
 649     (if (string-match ":" group)
 650         (cond ((string-match "+" group)
 651                (let* ((plus (string-match "+" group))
 652                       (colon (string-match ":" group))
 653                       (dot (string-match "\\." group)))
 654                  (setq foreign (concat
 655                                 (substring group (+ 1 plus)
 656                                            (cond ((null dot) colon)
 657                                                  ((< colon dot) colon)
 658                                                  ((< dot colon) dot))) ":")
 659                        group (substring group (+ 1 colon))
 660                        )))
 661               (t
 662                (let* ((colon (string-match ":" group)))
 663                  (setq foreign (concat (substring group 0 (+ 1 colon)))
 664                        group (substring group (+ 1 colon)))
 665                  ))))
 666     ;; collapse group name leaving LEVELS uncollapsed elements
 667     (while group
 668       (if (and (string-match "\\." group) (> levels 0))
 669           (setq name (concat name (substring group 0 1))
 670                 group (substring group (match-end 0))
 671                 levels (- levels 1)
 672                 name (concat name "."))
 673         (setq name (concat foreign name group)
 674               group nil)))
 675     name))
 676
 677
 678 \f
 679 ;;;
 680 ;;; Kill file handling.
 681 ;;;
 682
 683 (defun gnus-apply-kill-file ()
 684   "Apply a kill file to the current newsgroup.
 685 Returns the number of articles marked as read."
 686   (if (or (file-exists-p (gnus-newsgroup-kill-file nil))
 687           (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
 688       (gnus-apply-kill-file-internal)
 689     0))
 690
 691 (defun gnus-kill-save-kill-buffer ()
 692   (let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name)))
 693     (when (get-file-buffer file)
 694       (save-excursion
 695         (set-buffer (get-file-buffer file))
 696         (and (buffer-modified-p) (save-buffer))
 697         (kill-buffer (current-buffer))))))
 698
 699 (defvar gnus-kill-file-name "KILL"
 700   "Suffix of the kill files.")
 701
 702 (defun gnus-newsgroup-kill-file (newsgroup)
 703   "Return the name of a kill file name for NEWSGROUP.
 704 If NEWSGROUP is nil, return the global kill file name instead."
 705   (cond
 706    ;; The global KILL file is placed at top of the directory.
 707    ((or (null newsgroup)
 708         (string-equal newsgroup ""))
 709     (expand-file-name gnus-kill-file-name
 710                       gnus-kill-files-directory))
 711    ;; Append ".KILL" to newsgroup name.
 712    ((gnus-use-long-file-name 'not-kill)
 713     (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
 714                               "." gnus-kill-file-name)
 715                       gnus-kill-files-directory))
 716    ;; Place "KILL" under the hierarchical directory.
 717    (t
 718     (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
 719                               "/" gnus-kill-file-name)
 720                       gnus-kill-files-directory))))
 721
 722 ;;; Server things.
 723
 724 (defun gnus-member-of-valid (symbol group)
 725   "Find out if GROUP has SYMBOL as part of its \"valid\" spec."
 726   (memq symbol (assoc
 727                 (symbol-name (car (gnus-find-method-for-group group)))
 728                 gnus-valid-select-methods)))
 729
 730 (defun gnus-method-option-p (method option)
 731   "Return non-nil if select METHOD has OPTION as a parameter."
 732   (when (stringp method)
 733     (setq method (gnus-server-to-method method)))
 734   (memq option (assoc (format "%s" (car method))
 735                       gnus-valid-select-methods)))
 736
 737 (defun gnus-server-extend-method (group method)
 738   ;; This function "extends" a virtual server.  If the server is
 739   ;; "hello", and the select method is ("hello" (my-var "something"))
 740   ;; in the group "alt.alt", this will result in a new virtual server
 741   ;; called "hello+alt.alt".
 742   (let ((entry
 743          (gnus-copy-sequence
 744           (if (gnus-server-equal method gnus-select-method) gnus-select-method
 745             (cdr (assoc (car method) gnus-server-alist))))))
 746     (if (not entry)
 747         method
 748       (setcar (cdr entry) (concat (nth 1 entry) "+" group))
 749       (nconc entry (cdr method)))))
 750
 751 (defun gnus-server-status (method)
 752   "Return the status of METHOD."
 753   (nth 1 (assoc method gnus-opened-servers)))
 754
 755 (defun gnus-group-name-to-method (group)
 756   "Return a select method suitable for GROUP."
 757   (if (string-match ":" group)
 758       (let ((server (substring group 0 (match-beginning 0))))
 759         (if (string-match "\\+" server)
 760             (list (intern (substring server 0 (match-beginning 0)))
 761                   (substring server (match-end 0)))
 762           (list (intern server) "")))
 763     gnus-select-method))
 764
 765 (defun gnus-find-method-for-group (group &optional info)
 766   "Find the select method that GROUP uses."
 767   (or gnus-override-method
 768       (and (not group)
 769            gnus-select-method)
 770       (let ((info (or info (gnus-get-info group)))
 771             method)
 772         (if (or (not info)
 773                 (not (setq method (gnus-info-method info)))
 774                 (equal method "native"))
 775             gnus-select-method
 776           (setq method
 777                 (cond ((stringp method)
 778                        (gnus-server-to-method method))
 779                       ((stringp (car method))
 780                        (gnus-server-extend-method group method))
 781                       (t
 782                        method)))
 783           (cond ((equal (cadr method) "")
 784                  method)
 785                 ((null (cadr method))
 786                  (list (car method) ""))
 787                 (t
 788                  (gnus-server-add-address method)))))))
 789
 790 (defun gnus-check-backend-function (func group)
 791   "Check whether GROUP supports function FUNC."
 792   (let ((method (if (stringp group) (car (gnus-find-method-for-group group))
 793                   group)))
 794     (fboundp (intern (format "%s-%s" method func)))))
 795
 796 (defun gnus-methods-using (feature)
 797   "Find all methods that have FEATURE."
 798   (let ((valids gnus-valid-select-methods)
 799         outs)
 800     (while valids
 801       (if (memq feature (car valids))
 802           (setq outs (cons (car valids) outs)))
 803       (setq valids (cdr valids)))
 804     outs))
 805
 806 (defun gnus-read-method (prompt)
 807   "Prompt the user for a method.
 808 Allow completion over sensible values."
 809   (let ((method
 810          (completing-read
 811           prompt (append gnus-valid-select-methods gnus-predefined-server-alist
 812                          gnus-server-alist)
 813           nil t nil 'gnus-method-history)))
 814     (cond
 815      ((equal method "")
 816       (setq method gnus-select-method))
 817      ((assoc method gnus-valid-select-methods)
 818       (list (intern method)
 819             (if (memq 'prompt-address
 820                       (assoc method gnus-valid-select-methods))
 821                 (read-string "Address: ")
 822               "")))
 823      ((assoc method gnus-server-alist)
 824       method)
 825      (t
 826       (list (intern method) "")))))
 827
 828 ;;; User-level commands.
 829
 830 ;;;###autoload
 831 (defun gnus-slave-no-server (&optional arg)
 832   "Read network news as a slave, without connecting to local server"
 833   (interactive "P")
 834   (gnus-no-server arg t))
 835
 836 ;;;###autoload
 837 (defun gnus-no-server (&optional arg slave)
 838   "Read network news.
 839 If ARG is a positive number, Gnus will use that as the
 840 startup level.  If ARG is nil, Gnus will be started at level 2.
 841 If ARG is non-nil and not a positive number, Gnus will
 842 prompt the user for the name of an NNTP server to use.
 843 As opposed to `gnus', this command will not connect to the local server."
 844   (interactive "P")
 845   (gnus-no-server-1 arg slave))
 846
 847 ;;;###autoload
 848 (defun gnus-slave (&optional arg)
 849   "Read news as a slave."
 850   (interactive "P")
 851   (gnus arg nil 'slave))
 852
 853 ;;;###autoload
 854 (defun gnus-other-frame (&optional arg)
 855   "Pop up a frame to read news."
 856   (interactive "P")
 857   (if (get-buffer gnus-group-buffer)
 858       (let ((pop-up-frames t))
 859         (gnus arg))
 860     (select-frame (make-frame))
 861     (gnus arg)))
 862
 863 ;;;###autoload
 864 (defun gnus (&optional arg dont-connect slave)
 865   "Read network news.
 866 If ARG is non-nil and a positive number, Gnus will use that as the
 867 startup level.  If ARG is non-nil and not a positive number, Gnus will
 868 prompt the user for the name of an NNTP server to use."
 869   (interactive "P")
 870   (gnus-1 arg dont-connect slave))
 871
 872 ;; Allow redefinition of Gnus functions.
 873
 874 (gnus-ems-redefine)
 875
 876 (provide 'gnus)
 877
 878 ;;; gnus.el ends here