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