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