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