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