2000-10-05 12:25:08 ShengHuo ZHU <zsh@cs.rochester.edu>

[gnus] / lisp / gnus.el

diff --git a/lisp/gnus.el b/lisp/gnus.el
index 58d66fc..251f5f7 100644 (file)
--- a/lisp/gnus.el
+++ b/lisp/gnus.el
@@ -1,5 +1,6 @@
 ;;; gnus.el --- a newsreader for GNU Emacs
 ;;; gnus.el --- a newsreader for GNU Emacs

-;; Copyright (C) 1987-1990,1993-1999 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
+;;        1997, 1998, 2000 Free Software Foundation, Inc.

 
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;;     Lars Magne Ingebrigtsen <larsi@gnus.org>
 
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;;     Lars Magne Ingebrigtsen <larsi@gnus.org>


@@ -31,12 +32,6 @@
 (eval-when-compile (require 'cl))
 (require 'mm-util)
 
 (eval-when-compile (require 'cl))
 (require 'mm-util)
 

-(require 'custom)
-(eval-and-compile
-  (if (< emacs-major-version 20)
-      (require 'gnus-load)))
-(require 'message)
-

 (defgroup gnus nil
   "The coffee-brewing, all singing, all dancing, kitchen sink newsreader."
   :group 'news
 (defgroup gnus nil
   "The coffee-brewing, all singing, all dancing, kitchen sink newsreader."
   :group 'news


@@ -260,7 +255,7 @@ is restarted, and sometimes reloaded."
   :link '(custom-manual "(gnus)Exiting Gnus")
   :group 'gnus)
 
   :link '(custom-manual "(gnus)Exiting Gnus")
   :group 'gnus)
 

-(defconst gnus-version-number "5.8.4"
+(defconst gnus-version-number "5.8.8"

   "Version number for this version of Gnus.")
 
 (defconst gnus-version (format "Gnus v%s" gnus-version-number)
   "Version number for this version of Gnus.")
 
 (defconst gnus-version (format "Gnus v%s" gnus-version-number)


@@ -293,7 +288,28 @@ be set in `.emacs' instead."
   (defalias 'gnus-character-to-event 'identity)
   (defalias 'gnus-add-text-properties 'add-text-properties)
   (defalias 'gnus-put-text-property 'put-text-property)
   (defalias 'gnus-character-to-event 'identity)
   (defalias 'gnus-add-text-properties 'add-text-properties)
   (defalias 'gnus-put-text-property 'put-text-property)

-  (defalias 'gnus-mode-line-buffer-identification 'identity)
+  (defvar gnus-mode-line-image-cache t)
+  (if (fboundp 'find-image)
+      (defun gnus-mode-line-buffer-identification (line)
+       (let ((str (car-safe line)))
+         (if (and (stringp str)
+                  (string-match "^Gnus:" str))
+             (progn (add-text-properties
+                     0 5
+                     (list 'display
+                           (if (eq t gnus-mode-line-image-cache)
+                               (setq gnus-mode-line-image-cache
+                                     (find-image
+                                      '((:type xpm :file "gnus-pointer.xpm"
+                                               :ascent 80)
+                                        (:type xbm :file "gnus-pointer.xbm"
+                                               :ascent 80))))
+                             gnus-mode-line-image-cache)
+                           'help-echo "This is Gnus")
+                     str)
+                    (list str))
+           line)))
+    (defalias 'gnus-mode-line-buffer-identification 'identity))

   (defalias 'gnus-characterp 'numberp)
   (defalias 'gnus-deactivate-mark 'deactivate-mark)
   (defalias 'gnus-window-edges 'window-edges)
   (defalias 'gnus-characterp 'numberp)
   (defalias 'gnus-deactivate-mark 'deactivate-mark)
   (defalias 'gnus-window-edges 'window-edges)


@@ -750,8 +766,28 @@ be set in `.emacs' instead."
   "Insert startup message in current buffer."
   ;; Insert the message.
   (erase-buffer)
   "Insert startup message in current buffer."
   ;; Insert the message.
   (erase-buffer)

-  (insert
-   (format "              %s
+  (cond
+   ((and
+     (fboundp 'find-image)
+     (display-graphic-p)
+     (let ((image (find-image
+                  `((:type xpm :file "gnus.xpm")
+                    (:type xbm :file "gnus.xbm"
+                           ;; Account for the xbm's blackground.
+                           :background ,(face-foreground 'gnus-splash-face)
+                           :foreground ,(face-background 'default))))))
+       (when image
+        (let ((size (image-size image)))
+          (insert-char ?\n (max 0 (round (- (window-height)
+                                            (or y (cdr size)) 1) 2)))
+          (insert-char ?\  (max 0 (round (- (window-width)
+                                            (or x (car size))) 2)))
+          (insert-image image))
+        (setq gnus-simple-splash nil)
+        t))))
+   (t
+    (insert
+     (format "              %s

           _    ___ _             _
           _ ___ __ ___  __    _ ___
           __   _     ___    __  ___
           _    ___ _             _
           _ ___ __ ___  __    _ ___
           __   _     ___    __  ___


@@ -771,21 +807,21 @@ be set in `.emacs' instead."
           __
 
 "
           __
 
 "

-           ""))
-  ;; And then hack it.
-  (gnus-indent-rigidly (point-min) (point-max)
-                      (/ (max (- (window-width) (or x 46)) 0) 2))
-  (goto-char (point-min))
-  (forward-line 1)
-  (let* ((pheight (count-lines (point-min) (point-max)))
-        (wheight (window-height))
-        (rest (- wheight pheight)))
-    (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
-  ;; Fontify some.
-  (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
+            ""))
+    ;; And then hack it.
+    (gnus-indent-rigidly (point-min) (point-max)
+                        (/ (max (- (window-width) (or x 46)) 0) 2))
+    (goto-char (point-min))
+    (forward-line 1)
+    (let* ((pheight (count-lines (point-min) (point-max)))
+          (wheight (window-height))
+          (rest (- wheight pheight)))
+      (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
+    ;; Fontify some.
+    (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
+    (setq gnus-simple-splash t)))

   (goto-char (point-min))
   (setq mode-line-buffer-identification (concat " " gnus-version))
   (goto-char (point-min))
   (setq mode-line-buffer-identification (concat " " gnus-version))

-  (setq gnus-simple-splash t)

   (set-buffer-modified-p t))
 
 (eval-when (load)
   (set-buffer-modified-p t))
 
 (eval-when (load)


@@ -797,7 +833,6 @@ be set in `.emacs' instead."
 
 ;;; Do the rest.
 
 
 ;;; Do the rest.
 

-(require 'custom)

 (require 'gnus-util)
 (require 'nnheader)
 
 (require 'gnus-util)
 (require 'nnheader)
 


@@ -901,17 +936,20 @@ see the manual for details."
   :type 'gnus-select-method)
 
 (defcustom gnus-message-archive-method
   :type 'gnus-select-method)
 
 (defcustom gnus-message-archive-method

-  `(nnfolder
-    "archive"
-    (nnfolder-directory ,(nnheader-concat message-directory "archive"))
-    (nnfolder-active-file
-     ,(nnheader-concat message-directory "archive/active"))
-    (nnfolder-get-new-mail nil)
-    (nnfolder-inhibit-expiry t))
+  (progn
+    ;; Don't require it at top level to avoid circularity.
+    (require 'message)
+    `(nnfolder
+      "archive"
+      (nnfolder-directory ,(nnheader-concat message-directory "archive"))
+      (nnfolder-active-file
+       ,(nnheader-concat message-directory "archive/active"))
+      (nnfolder-get-new-mail nil)
+      (nnfolder-inhibit-expiry t)))

   "*Method used for archiving messages you've sent.
 This should be a mail method.
 
   "*Method used for archiving messages you've sent.
 This should be a mail method.
 

-It's probably not a very effective to change this variable once you've
+It's probably not very effective to change this variable once you've

 run Gnus once.  After doing that, you must edit this server from the
 server buffer."
   :group 'gnus-server
 run Gnus once.  After doing that, you must edit this server from the
 server buffer."
   :group 'gnus-server


@@ -1007,12 +1045,12 @@ list, Gnus will try all the methods in the list until it finds a match."
   :type '(choice (const :tag "default" nil)
                 (const :tag "DejaNews" (nnweb "refer" (nnweb-type dejanews)))
                 gnus-select-method
   :type '(choice (const :tag "default" nil)
                 (const :tag "DejaNews" (nnweb "refer" (nnweb-type dejanews)))
                 gnus-select-method

-                (repeat :menu-tag "Try multiple" 
+                (repeat :menu-tag "Try multiple"

                         :tag "Multiple"
                         :value (current (nnweb "refer" (nnweb-type dejanews)))
                         (choice :tag "Method"
                                 (const current)
                         :tag "Multiple"
                         :value (current (nnweb "refer" (nnweb-type dejanews)))
                         (choice :tag "Method"
                                 (const current)

-                                (const :tag "DejaNews" 
+                                (const :tag "DejaNews"

                                        (nnweb "refer" (nnweb-type dejanews)))
                                 gnus-select-method))))
 
                                        (nnweb "refer" (nnweb-type dejanews)))
                                 gnus-select-method))))
 


@@ -1073,11 +1111,6 @@ newsgroups."
   :group 'gnus-summary-marks
   :type 'character)
 
   :group 'gnus-summary-marks
   :type 'character)
 

-(defcustom gnus-asynchronous nil
-  "*If non-nil, Gnus will supply backends with data needed for async article fetching."
-  :group 'gnus-asynchronous
-  :type 'boolean)
-

 (defcustom gnus-large-newsgroup 200
   "*The number of articles which indicates a large newsgroup.
 If the number of articles in a newsgroup is greater than this value,
 (defcustom gnus-large-newsgroup 200
   "*The number of articles which indicates a large newsgroup.
 If the number of articles in a newsgroup is greater than this value,


@@ -1274,21 +1307,28 @@ this variable.  I think."
                                   (const :format "%v " virtual)
                                   (const respool)))))
 
                                   (const :format "%v " virtual)
                                   (const respool)))))
 

-(define-widget 'gnus-select-method 'list
-  "Widget for entering a select method."
-  :value '(nntp "")
-  :tag "Select Method"
-  :args `((choice :tag "Method"
-                 ,@(mapcar (lambda (entry)
-                             (list 'const :format "%v\n"
-                                   (intern (car entry))))
-                           gnus-valid-select-methods))
-         (string :tag "Address")
-         (repeat :tag "Options"
-                 :inline t
-                 (list :format "%v"
-                       variable
-                       (sexp :tag "Value")))))
+(defun gnus-redefine-select-method-widget ()
+  "Recomputes the select-method widget based on the value of
+`gnus-valid-select-methods'."
+  (define-widget 'gnus-select-method 'list
+    "Widget for entering a select method."
+    :value '(nntp "")
+    :tag "Select Method"
+    :args `((choice :tag "Method"
+                   ,@(mapcar (lambda (entry)
+                               (list 'const :format "%v\n"
+                                     (intern (car entry))))
+                             gnus-valid-select-methods)
+                   (symbol :tag "other"))
+           (string :tag "Address")
+           (repeat :tag "Options"
+                   :inline t
+                   (list :format "%v"
+                         variable
+                         (sexp :tag "Value"))))
+    ))
+
+(gnus-redefine-select-method-widget)

 
 (defcustom gnus-updated-mode-lines '(group article summary tree)
   "List of buffers that should update their mode lines.
 
 (defcustom gnus-updated-mode-lines '(group article summary tree)
   "List of buffers that should update their mode lines.


@@ -1461,6 +1501,7 @@ If nil, no default charset is assumed when posting."
 \f
 ;;; Internal variables
 
 \f
 ;;; Internal variables
 

+(defvar gnus-agent-gcc-header "X-Gnus-Agent-Gcc")

 (defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information")
 (defvar gnus-group-get-parameter-function 'gnus-group-get-parameter)
 (defvar gnus-original-article-buffer " *Original Article*")
 (defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information")
 (defvar gnus-group-get-parameter-function 'gnus-group-get-parameter)
 (defvar gnus-original-article-buffer " *Original Article*")


@@ -1600,6 +1641,9 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
 
 (defvar gnus-dead-summary nil)
 
 
 (defvar gnus-dead-summary nil)
 

+(defvar gnus-invalid-group-regexp "[: `'\"/]\\|^$"
+  "Regexp matching invalid groups.")
+

 ;;; End of variables.
 
 ;; Define some autoload functions Gnus might use.
 ;;; End of variables.
 
 ;; Define some autoload functions Gnus might use.


@@ -1616,17 +1660,16 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
            (when (consp function)
              (setq keymap (car (memq 'keymap function)))
              (setq function (car function)))
            (when (consp function)
              (setq keymap (car (memq 'keymap function)))
              (setq function (car function)))

-           (autoload function (car package) nil interactive keymap)))
+           (unless (fboundp function)
+             (autoload function (car package) nil interactive keymap))))

        (if (eq (nth 1 package) ':interactive)
        (if (eq (nth 1 package) ':interactive)

-           (cdddr package)
+           (nthcdr 3 package)

          (cdr package)))))
          (cdr package)))))

-   '(("metamail" metamail-buffer)
-     ("info" Info-goto-node)
+   '(("info" :interactive t Info-goto-node)

      ("pp" pp pp-to-string pp-eval-expression)
      ("qp" quoted-printable-decode-region quoted-printable-decode-string)
      ("ps-print" ps-print-preprint)
      ("pp" pp pp-to-string pp-eval-expression)
      ("qp" quoted-printable-decode-region quoted-printable-decode-string)
      ("ps-print" ps-print-preprint)

-     ("mail-extr" mail-extract-address-components)
-     ("browse-url" browse-url)
+     ("browse-url" :interactive t browse-url)

      ("message" :interactive t
       message-send-and-exit message-yank-original)
      ("babel" babel-as-string)
      ("message" :interactive t
       message-send-and-exit message-yank-original)
      ("babel" babel-as-string)


@@ -1670,7 +1713,8 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
       gnus-cache-possibly-remove-articles gnus-cache-request-article
       gnus-cache-retrieve-headers gnus-cache-possibly-alter-active
       gnus-cache-enter-remove-article gnus-cached-article-p
       gnus-cache-possibly-remove-articles gnus-cache-request-article
       gnus-cache-retrieve-headers gnus-cache-possibly-alter-active
       gnus-cache-enter-remove-article gnus-cached-article-p

-      gnus-cache-open gnus-cache-close gnus-cache-update-article)
+      gnus-cache-open gnus-cache-close gnus-cache-update-article
+      gnus-cache-articles-in-group)

      ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
       gnus-cache-remove-article gnus-summary-insert-cached-articles)
      ("gnus-score" :interactive t
      ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
       gnus-cache-remove-article gnus-summary-insert-cached-articles)
      ("gnus-score" :interactive t


@@ -1750,10 +1794,12 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
       gnus-article-delete-invisible-text gnus-treat-article)
      ("gnus-art" :interactive t
       gnus-article-hide-headers gnus-article-hide-boring-headers
       gnus-article-delete-invisible-text gnus-treat-article)
      ("gnus-art" :interactive t
       gnus-article-hide-headers gnus-article-hide-boring-headers

-      gnus-article-treat-overstrike 
+      gnus-article-treat-overstrike

       gnus-article-remove-cr gnus-article-remove-trailing-blank-lines
       gnus-article-display-x-face gnus-article-de-quoted-unreadable
       gnus-article-remove-cr gnus-article-remove-trailing-blank-lines
       gnus-article-display-x-face gnus-article-de-quoted-unreadable

+      gnus-article-de-base64-unreadable

       gnus-article-decode-HZ
       gnus-article-decode-HZ

+      gnus-article-wash-html

       gnus-article-hide-pgp
       gnus-article-hide-pem gnus-article-hide-signature
       gnus-article-strip-leading-blank-lines gnus-article-date-local
       gnus-article-hide-pgp
       gnus-article-hide-pem gnus-article-hide-signature
       gnus-article-strip-leading-blank-lines gnus-article-date-local


@@ -2621,9 +2667,21 @@ just the host name."
                group (substring group (+ 1 colon))))
        (setq foreign (concat foreign ":")))
       ;; Collapse group name leaving LEVELS uncollapsed elements
                group (substring group (+ 1 colon))))
        (setq foreign (concat foreign ":")))
       ;; Collapse group name leaving LEVELS uncollapsed elements

-      (let* ((glist (split-string group "\\."))
-            (glen (length glist))
+      (let* ((slist (split-string group "/"))
+            (slen (length slist))
+            (dlist (split-string group "\\."))
+            (dlen (length dlist))
+            glist
+            glen
+            gsep

             res)
             res)

+       (if (> slen dlen)
+           (setq glist slist
+                 glen slen
+                 gsep "/")
+         (setq glist dlist
+               glen dlen
+               gsep "."))

        (setq levels (- glen levels))
        (dolist (g glist)
          (push (if (>= (decf levels) 0)
        (setq levels (- glen levels))
        (dolist (g glist)
          (push (if (>= (decf levels) 0)


@@ -2632,7 +2690,7 @@ just the host name."
                      (substring g 0 1))
                  g)
                res))
                      (substring g 0 1))
                  g)
                res))

-       (concat foreign (mapconcat 'identity (nreverse res) "."))))))
+       (concat foreign (mapconcat 'identity (nreverse res) gsep))))))

 
 (defun gnus-narrow-to-body ()
   "Narrow to the body of an article."
 
 (defun gnus-narrow-to-body ()
   "Narrow to the body of an article."


@@ -2785,8 +2843,8 @@ Disallow invalid group names."
   (let ((prefix "")
        group)
     (while (not group)
   (let ((prefix "")
        group)
     (while (not group)

-      (when (string-match
-            "[: `'\"/]\\|^$"
+      (when (string-match 
+            gnus-invalid-group-regexp

             (setq group (read-string (concat prefix prompt)
                                      (cons (or default "") 0)
                                      'gnus-group-history)))
             (setq group (read-string (concat prefix prompt)
                                      (cons (or default "") 0)
                                      'gnus-group-history)))


@@ -2819,7 +2877,7 @@ Allow completion over sensible values."
        (or (let ((opened gnus-opened-servers))
              (while (and opened
                          (not (equal (format "%s:%s" method address)
        (or (let ((opened gnus-opened-servers))
              (while (and opened
                          (not (equal (format "%s:%s" method address)

-                                     (format "%s:%s" (caaar opened) 
+                                     (format "%s:%s" (caaar opened)

                                              (cadaar opened)))))
                (pop opened))
              (caar opened))
                                              (cadaar opened)))))
                (pop opened))
              (caar opened))


@@ -2862,12 +2920,12 @@ As opposed to `gnus', this command will not connect to the local server."
     (cond (window
           (select-frame (window-frame window)))
          (t
     (cond (window
           (select-frame (window-frame window)))
          (t

-          (select-frame (make-frame)))
+          (select-frame (make-frame)))))

   (gnus arg))
 
   (gnus arg))
 

-(setq thing ?                          ; this is a comment
-      more 'yes)
-    
+;;(setq thing ?                                ; this is a comment
+;;      more 'yes)
+

 ;;;###autoload
 (defun gnus (&optional arg dont-connect slave)
   "Read network news.
 ;;;###autoload
 (defun gnus (&optional arg dont-connect slave)
   "Read network news.