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