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