aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorDave Love2000-09-20 11:46:48 +0000
committerDave Love2000-09-20 11:46:48 +0000
commitf4c1c47c5b311c19b4cd0c3296783fc83b6c19b9 (patch)
tree763d0b6a222a27b2823fc943695e9361e0bf151a
parent2ef8202d39ed4f70406cd74b22f5a8e0bc166e4d (diff)
downloademacs-old-branches/branch-5_8.tar.gz
emacs-old-branches/branch-5_8.zip
Merge from Gnus trunk.old-branches/branch-5_8
-rw-r--r--lisp/gnus/gnus-art.el2780
-rw-r--r--lisp/gnus/gnus-group.el834
-rw-r--r--lisp/gnus/gnus-msg.el513
-rw-r--r--lisp/gnus/gnus-sum.el1822
-rw-r--r--lisp/gnus/gnus-topic.el337
-rw-r--r--lisp/gnus/gnus-util.el385
-rw-r--r--lisp/gnus/nnheader.el329
-rw-r--r--lisp/gnus/nnkiboze.el259
8 files changed, 5105 insertions, 2154 deletions
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index ac2aed4ba71..4bc1e3fe708 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -1,5 +1,5 @@
1;;; gnus-art.el --- article mode commands for Gnus 1;;; gnus-art.el --- article mode commands for Gnus
2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. 2;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
3 3
4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 5;; Keywords: news
@@ -27,20 +27,27 @@
27 27
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(eval-when-compile (require 'cl))
31
32(require 'custom)
33(require 'gnus) 30(require 'gnus)
34(require 'gnus-sum) 31(require 'gnus-sum)
35(require 'gnus-spec) 32(require 'gnus-spec)
36(require 'gnus-int) 33(require 'gnus-int)
37(require 'browse-url) 34(require 'mm-bodies)
35(require 'mail-parse)
36(require 'mm-decode)
37(require 'mm-view)
38(require 'wid-edit)
39(require 'mm-uu)
38 40
39(defgroup gnus-article nil 41(defgroup gnus-article nil
40 "Article display." 42 "Article display."
41 :link '(custom-manual "(gnus)The Article Buffer") 43 :link '(custom-manual "(gnus)The Article Buffer")
42 :group 'gnus) 44 :group 'gnus)
43 45
46(defgroup gnus-article-treat nil
47 "Treating article parts."
48 :link '(custom-manual "(gnus)Article Hiding")
49 :group 'gnus-article)
50
44(defgroup gnus-article-hiding nil 51(defgroup gnus-article-hiding nil
45 "Hiding article parts." 52 "Hiding article parts."
46 :link '(custom-manual "(gnus)Article Hiding") 53 :link '(custom-manual "(gnus)Article Hiding")
@@ -107,11 +114,19 @@
107 "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" 114 "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
108 "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" 115 "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
109 "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" 116 "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
110 "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" 117 "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
111 "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
112 "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" 118 "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
113 "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" 119 "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
114 "^Status:") 120 "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
121 "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
122 "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
123 "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
124 "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
125 "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
126 "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
127 "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
128 "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
129 "^X-Received:" "^Content-length:" "X-precedence:")
115 "*All headers that start with this regexp will be hidden. 130 "*All headers that start with this regexp will be hidden.
116This variable can also be a list of regexps of headers to be ignored. 131This variable can also be a list of regexps of headers to be ignored.
117If `gnus-visible-headers' is non-nil, this variable will be ignored." 132If `gnus-visible-headers' is non-nil, this variable will be ignored."
@@ -121,7 +136,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored."
121 :group 'gnus-article-hiding) 136 :group 'gnus-article-hiding)
122 137
123(defcustom gnus-visible-headers 138(defcustom gnus-visible-headers
124 "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" 139 "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
125 "*All headers that do not match this regexp will be hidden. 140 "*All headers that do not match this regexp will be hidden.
126This variable can also be a list of regexp of headers to remain visible. 141This variable can also be a list of regexp of headers to remain visible.
127If this variable is non-nil, `gnus-ignored-headers' will be ignored." 142If this variable is non-nil, `gnus-ignored-headers' will be ignored."
@@ -152,8 +167,8 @@ Possible values in this list are `empty', `newsgroups', `followup-to',
152 (const :tag "Followup-to identical to newsgroups." followup-to) 167 (const :tag "Followup-to identical to newsgroups." followup-to)
153 (const :tag "Reply-to identical to from." reply-to) 168 (const :tag "Reply-to identical to from." reply-to)
154 (const :tag "Date less than four days old." date) 169 (const :tag "Date less than four days old." date)
155 (const :tag "Very long To header." long-to) 170 (const :tag "Very long To and/or Cc header." long-to)
156 (const :tag "Multiple To headers." many-to)) 171 (const :tag "Multiple To and/or Cc headers." many-to))
157 :group 'gnus-article-hiding) 172 :group 'gnus-article-hiding)
158 173
159(defcustom gnus-signature-separator '("^-- $" "^-- *$") 174(defcustom gnus-signature-separator '("^-- $" "^-- *$")
@@ -165,7 +180,7 @@ the end of the buffer."
165 :group 'gnus-article-signature) 180 :group 'gnus-article-signature)
166 181
167(defcustom gnus-signature-limit nil 182(defcustom gnus-signature-limit nil
168 "Provide a limit to what is considered a signature. 183 "Provide a limit to what is considered a signature.
169If it is a number, no signature may not be longer (in characters) than 184If it is a number, no signature may not be longer (in characters) than
170that number. If it is a floating point number, no signature may be 185that number. If it is a floating point number, no signature may be
171longer (in lines) than that number. If it is a function, the function 186longer (in lines) than that number. If it is a function, the function
@@ -183,12 +198,20 @@ regexp. If it matches, the text in question is not a signature."
183 :type 'sexp 198 :type 'sexp
184 :group 'gnus-article-hiding) 199 :group 'gnus-article-hiding)
185 200
201;; Fixme: This isn't the right thing for mixed graphical and and
202;; non-graphical frames in a session.
203;; gnus-xmas.el overrides this for XEmacs.
186(defcustom gnus-article-x-face-command 204(defcustom gnus-article-x-face-command
187 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" 205 (if (and (fboundp 'image-type-available-p)
206 (image-type-available-p 'xbm))
207 'gnus-article-display-xface
208 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -")
188 "*String or function to be executed to display an X-Face header. 209 "*String or function to be executed to display an X-Face header.
189If it is a string, the command will be executed in a sub-shell 210If it is a string, the command will be executed in a sub-shell
190asynchronously. The compressed face will be piped to this command." 211asynchronously. The compressed face will be piped to this command."
191 :type 'string ;Leave function case to Lisp. 212 :type '(choice string
213 (function-item gnus-article-display-xface)
214 function)
192 :group 'gnus-article-washing) 215 :group 'gnus-article-washing)
193 216
194(defcustom gnus-article-x-face-too-ugly nil 217(defcustom gnus-article-x-face-too-ugly nil
@@ -198,7 +221,7 @@ asynchronously. The compressed face will be piped to this command."
198 221
199(defcustom gnus-emphasis-alist 222(defcustom gnus-emphasis-alist
200 (let ((format 223 (let ((format
201 "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") 224 "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
202 (types 225 (types
203 '(("_" "_" underline) 226 '(("_" "_" underline)
204 ("/" "/" italic) 227 ("/" "/" italic)
@@ -232,6 +255,14 @@ is the face used for highlighting."
232 face)) 255 face))
233 :group 'gnus-article-emphasis) 256 :group 'gnus-article-emphasis)
234 257
258(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
259 "A regexp to describe whitespace which should not be emphasized.
260Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
261The former avoids underlining of leading and trailing whitespace,
262and the latter avoids underlining any whitespace at all."
263 :group 'gnus-article-emphasis
264 :type 'regexp)
265
235(defface gnus-emphasis-bold '((t (:bold t))) 266(defface gnus-emphasis-bold '((t (:bold t)))
236 "Face used for displaying strong emphasized text (*word*)." 267 "Face used for displaying strong emphasized text (*word*)."
237 :group 'gnus-article-emphasis) 268 :group 'gnus-article-emphasis)
@@ -262,6 +293,11 @@ is the face used for highlighting."
262Esample: (_/*word*/_)." 293Esample: (_/*word*/_)."
263 :group 'gnus-article-emphasis) 294 :group 'gnus-article-emphasis)
264 295
296(defface gnus-emphasis-highlight-words
297 '((t (:background "black" :foreground "yellow")))
298 "Face used for displaying highlighted words."
299 :group 'gnus-article-emphasis)
300
265(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" 301(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
266 "Format for display of Date headers in article bodies. 302 "Format for display of Date headers in article bodies.
267See `format-time-string' for the possible values. 303See `format-time-string' for the possible values.
@@ -274,8 +310,6 @@ be fed to `format-time-string'."
274 :group 'gnus-article-washing) 310 :group 'gnus-article-washing)
275 311
276(eval-and-compile 312(eval-and-compile
277 (autoload 'hexl-hex-string-to-integer "hexl")
278 (autoload 'timezone-make-date-arpa-standard "timezone")
279 (autoload 'mail-extract-address-components "mail-extr")) 313 (autoload 'mail-extract-address-components "mail-extr"))
280 314
281(defcustom gnus-save-all-headers t 315(defcustom gnus-save-all-headers t
@@ -377,34 +411,6 @@ be used as possible file names."
377 (cons :value ("" "") regexp (repeat string)) 411 (cons :value ("" "") regexp (repeat string))
378 (sexp :value nil)))) 412 (sexp :value nil))))
379 413
380(defcustom gnus-strict-mime t
381 "*If nil, MIME-decode even if there is no Mime-Version header."
382 :group 'gnus-article-mime
383 :type 'boolean)
384
385(defcustom gnus-show-mime-method 'metamail-buffer
386 "Function to process a MIME message.
387The function is called from the article buffer."
388 :group 'gnus-article-mime
389 :type 'function)
390
391(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable
392 "*Function to decode MIME encoded words.
393The function is called from the article buffer."
394 :group 'gnus-article-mime
395 :type 'function)
396
397(defcustom gnus-show-traditional-method
398 (if (and (featurep 'mule)
399 (boundp 'enable-multibyte-characters))
400 (lambda ()
401 (if enable-multibyte-characters (gnus-mule-decode-article)))
402 (lambda ()))
403 "Function to decode ``localized RFC 822 messages''.
404The function is called from the article buffer."
405 :group 'gnus-article-mime
406 :type 'function)
407
408(defcustom gnus-page-delimiter "^\^L" 414(defcustom gnus-page-delimiter "^\^L"
409 "*Regexp describing what to use as article page delimiters. 415 "*Regexp describing what to use as article page delimiters.
410The default value is \"^\^L\", which is a form linefeed at the 416The default value is \"^\^L\", which is a form linefeed at the
@@ -412,9 +418,14 @@ beginning of a line."
412 :type 'regexp 418 :type 'regexp
413 :group 'gnus-article-various) 419 :group 'gnus-article-various)
414 420
415(defcustom gnus-article-mode-line-format "Gnus: %%b %S" 421(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
416 "*The format specification for the article mode line. 422 "*The format specification for the article mode line.
417See `gnus-summary-mode-line-format' for a closer description." 423See `gnus-summary-mode-line-format' for a closer description.
424
425The following additional specs are available:
426
427%w The article washing status.
428%m The number of MIME parts in the article."
418 :type 'string 429 :type 'string
419 :group 'gnus-article-various) 430 :group 'gnus-article-various)
420 431
@@ -429,8 +440,7 @@ See `gnus-summary-mode-line-format' for a closer description."
429 :group 'gnus-article-various) 440 :group 'gnus-article-various)
430 441
431(defcustom gnus-article-prepare-hook nil 442(defcustom gnus-article-prepare-hook nil
432 "*A hook called after an article has been prepared in the article buffer. 443 "*A hook called after an article has been prepared in the article buffer."
433If you want to run a special decoding program like nkf, use this hook."
434 :type 'hook 444 :type 'hook
435 :group 'gnus-article-various) 445 :group 'gnus-article-various)
436 446
@@ -559,8 +569,413 @@ displayed by the first non-nil matching CONTENT face."
559 (item :tag "skip" nil) 569 (item :tag "skip" nil)
560 (face :value default))))) 570 (face :value default)))))
561 571
572(defcustom gnus-article-decode-hook
573 '(article-decode-charset article-decode-encoded-words)
574 "*Hook run to decode charsets in articles."
575 :group 'gnus-article-headers
576 :type 'hook)
577
578(defcustom gnus-display-mime-function 'gnus-display-mime
579 "Function to display MIME articles."
580 :group 'gnus-article-mime
581 :type 'function)
582
583(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
584 "Function used to decode headers.")
585
586(defvar gnus-article-dumbquotes-map
587 '(("\202" ",")
588 ("\203" "f")
589 ("\204" ",,")
590 ("\205" "...")
591 ("\213" "<")
592 ("\214" "OE")
593 ("\221" "`")
594 ("\222" "'")
595 ("\223" "``")
596 ("\224" "\"")
597 ("\225" "*")
598 ("\226" "---")
599 ("\227" "-")
600 ("\231" "(TM)")
601 ("\233" ">")
602 ("\234" "oe")
603 ("\264" "'"))
604 "Table for MS-to-Latin1 translation.")
605
606(defcustom gnus-ignored-mime-types nil
607 "List of MIME types that should be ignored by Gnus."
608 :group 'gnus-article-mime
609 :type '(repeat regexp))
610
611(defcustom gnus-unbuttonized-mime-types '(".*/.*")
612 "List of MIME types that should not be given buttons when rendered inline."
613 :group 'gnus-article-mime
614 :type '(repeat regexp))
615
616(defcustom gnus-article-mime-part-function nil
617 "Function called with a MIME handle as the argument.
618This is meant for people who want to do something automatic based
619on parts -- for instance, adding Vcard info to a database."
620 :group 'gnus-article-mime
621 :type 'function)
622
623(defcustom gnus-mime-multipart-functions nil
624 "An alist of MIME types to functions to display them.")
625
626(defcustom gnus-article-date-lapsed-new-header nil
627 "Whether the X-Sent and Date headers can coexist.
628When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
629either replace the old \"Date:\" header (if this variable is nil), or
630be added below it (otherwise)."
631 :group 'gnus-article-headers
632 :type 'boolean)
633
634(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
635 "Function called with a MIME handle as the argument.
636This is meant for people who want to view first matched part.
637For `undisplayed-alternative' (default), the first undisplayed
638part or alternative part is used. For `undisplayed', the first
639undisplayed part is used. For a function, the first part which
640the function return `t' is used. For `nil', the first part is
641used."
642 :group 'gnus-article-mime
643 :type '(choice
644 (item :tag "first" :value nil)
645 (item :tag "undisplayed" :value undisplayed)
646 (item :tag "undisplayed or alternative"
647 :value undisplayed-alternative)
648 (function)))
649
650;;;
651;;; The treatment variables
652;;;
653
654(defvar gnus-part-display-hook nil
655 "Hook called on parts that are to receive treatment.")
656
657(defvar gnus-article-treat-custom
658 '(choice (const :tag "Off" nil)
659 (const :tag "On" t)
660 (const :tag "Header" head)
661 (const :tag "Last" last)
662 (integer :tag "Less")
663 (repeat :tag "Groups" regexp)
664 (sexp :tag "Predicate")))
665
666(defvar gnus-article-treat-head-custom
667 '(choice (const :tag "Off" nil)
668 (const :tag "Header" head)))
669
670(defvar gnus-article-treat-types '("text/plain")
671 "Parts to treat.")
672
673(defvar gnus-inhibit-treatment nil
674 "Whether to inhibit treatment.")
675
676(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
677 "Highlight the signature.
678Valid values are nil, t, `head', `last', an integer or a predicate.
679See the manual for details."
680 :group 'gnus-article-treat
681 :type gnus-article-treat-custom)
682(put 'gnus-treat-highlight-signature 'highlight t)
683
684(defcustom gnus-treat-buttonize 100000
685 "Add buttons.
686Valid values are nil, t, `head', `last', an integer or a predicate.
687See the manual for details."
688 :group 'gnus-article-treat
689 :type gnus-article-treat-custom)
690(put 'gnus-treat-buttonize 'highlight t)
691
692(defcustom gnus-treat-buttonize-head 'head
693 "Add buttons to the head.
694Valid values are nil, t, `head', `last', an integer or a predicate.
695See the manual for details."
696 :group 'gnus-article-treat
697 :type gnus-article-treat-head-custom)
698(put 'gnus-treat-buttonize-head 'highlight t)
699
700(defcustom gnus-treat-emphasize 50000
701 "Emphasize text.
702Valid values are nil, t, `head', `last', an integer or a predicate.
703See the manual for details."
704 :group 'gnus-article-treat
705 :type gnus-article-treat-custom)
706(put 'gnus-treat-emphasize 'highlight t)
707
708(defcustom gnus-treat-strip-cr nil
709 "Remove carriage returns.
710Valid values are nil, t, `head', `last', an integer or a predicate.
711See the manual for details."
712 :group 'gnus-article-treat
713 :type gnus-article-treat-custom)
714
715(defcustom gnus-treat-hide-headers 'head
716 "Hide headers.
717Valid values are nil, t, `head', `last', an integer or a predicate.
718See the manual for details."
719 :group 'gnus-article-treat
720 :type gnus-article-treat-head-custom)
721
722(defcustom gnus-treat-hide-boring-headers nil
723 "Hide boring headers.
724Valid values are nil, t, `head', `last', an integer or a predicate.
725See the manual for details."
726 :group 'gnus-article-treat
727 :type gnus-article-treat-head-custom)
728
729(defcustom gnus-treat-hide-signature nil
730 "Hide the signature.
731Valid values are nil, t, `head', `last', an integer or a predicate.
732See the manual for details."
733 :group 'gnus-article-treat
734 :type gnus-article-treat-custom)
735
736(defcustom gnus-treat-fill-article nil
737 "Fill the article.
738Valid values are nil, t, `head', `last', an integer or a predicate.
739See the manual for details."
740 :group 'gnus-article-treat
741 :type gnus-article-treat-custom)
742
743(defcustom gnus-treat-hide-citation nil
744 "Hide cited text.
745Valid values are nil, t, `head', `last', an integer or a predicate.
746See the manual for details."
747 :group 'gnus-article-treat
748 :type gnus-article-treat-custom)
749
750(defcustom gnus-treat-strip-list-identifiers 'head
751 "Strip list identifiers from `gnus-list-identifiers`.
752Valid values are nil, t, `head', `last', an integer or a predicate.
753See the manual for details."
754 :group 'gnus-article-treat
755 :type gnus-article-treat-custom)
756
757(defcustom gnus-treat-strip-pgp t
758 "Strip PGP signatures.
759Valid values are nil, t, `head', `last', an integer or a predicate.
760See the manual for details."
761 :group 'gnus-article-treat
762 :type gnus-article-treat-custom)
763
764(defcustom gnus-treat-strip-pem nil
765 "Strip PEM signatures.
766Valid values are nil, t, `head', `last', an integer or a predicate.
767See the manual for details."
768 :group 'gnus-article-treat
769 :type gnus-article-treat-custom)
770
771(defcustom gnus-treat-strip-banner t
772 "Strip banners from articles.
773The banner to be stripped is specified in the `banner' group parameter.
774Valid values are nil, t, `head', `last', an integer or a predicate.
775See the manual for details."
776 :group 'gnus-article-treat
777 :type gnus-article-treat-custom)
778
779(defcustom gnus-treat-highlight-headers 'head
780 "Highlight the headers.
781Valid values are nil, t, `head', `last', an integer or a predicate.
782See the manual for details."
783 :group 'gnus-article-treat
784 :type gnus-article-treat-head-custom)
785(put 'gnus-treat-highlight-headers 'highlight t)
786
787(defcustom gnus-treat-highlight-citation t
788 "Highlight cited text.
789Valid values are nil, t, `head', `last', an integer or a predicate.
790See the manual for details."
791 :group 'gnus-article-treat
792 :type gnus-article-treat-custom)
793(put 'gnus-treat-highlight-citation 'highlight t)
794
795(defcustom gnus-treat-date-ut nil
796 "Display the Date in UT (GMT).
797Valid values are nil, t, `head', `last', an integer or a predicate.
798See the manual for details."
799 :group 'gnus-article-treat
800 :type gnus-article-treat-head-custom)
801
802(defcustom gnus-treat-date-local nil
803 "Display the Date in the local timezone.
804Valid values are nil, t, `head', `last', an integer or a predicate.
805See the manual for details."
806 :group 'gnus-article-treat
807 :type gnus-article-treat-head-custom)
808
809(defcustom gnus-treat-date-lapsed nil
810 "Display the Date header in a way that says how much time has elapsed.
811Valid values are nil, t, `head', `last', an integer or a predicate.
812See the manual for details."
813 :group 'gnus-article-treat
814 :type gnus-article-treat-head-custom)
815
816(defcustom gnus-treat-date-original nil
817 "Display the date in the original timezone.
818Valid values are nil, t, `head', `last', an integer or a predicate.
819See the manual for details."
820 :group 'gnus-article-treat
821 :type gnus-article-treat-head-custom)
822
823(defcustom gnus-treat-date-iso8601 nil
824 "Display the date in the ISO8601 format.
825Valid values are nil, t, `head', `last', an integer or a predicate.
826See the manual for details."
827 :group 'gnus-article-treat
828 :type gnus-article-treat-head-custom)
829
830(defcustom gnus-treat-date-user-defined nil
831 "Display the date in a user-defined format.
832The format is defined by the `gnus-article-time-format' variable.
833Valid values are nil, t, `head', `last', an integer or a predicate.
834See the manual for details."
835 :group 'gnus-article-treat
836 :type gnus-article-treat-head-custom)
837
838(defcustom gnus-treat-strip-headers-in-body t
839 "Strip the X-No-Archive header line from the beginning of the body.
840Valid values are nil, t, `head', `last', an integer or a predicate.
841See the manual for details."
842 :group 'gnus-article-treat
843 :type gnus-article-treat-custom)
844
845(defcustom gnus-treat-strip-trailing-blank-lines nil
846 "Strip trailing blank lines.
847Valid values are nil, t, `head', `last', an integer or a predicate.
848See the manual for details."
849 :group 'gnus-article-treat
850 :type gnus-article-treat-custom)
851
852(defcustom gnus-treat-strip-leading-blank-lines nil
853 "Strip leading blank lines.
854Valid values are nil, t, `head', `last', an integer or a predicate.
855See the manual for details."
856 :group 'gnus-article-treat
857 :type gnus-article-treat-custom)
858
859(defcustom gnus-treat-strip-multiple-blank-lines nil
860 "Strip multiple blank lines.
861Valid values are nil, t, `head', `last', an integer or a predicate.
862See the manual for details."
863 :group 'gnus-article-treat
864 :type gnus-article-treat-custom)
865
866(defcustom gnus-treat-overstrike t
867 "Treat overstrike highlighting.
868Valid values are nil, t, `head', `last', an integer or a predicate.
869See the manual for details."
870 :group 'gnus-article-treat
871 :type gnus-article-treat-custom)
872(put 'gnus-treat-overstrike 'highlight t)
873
874(defcustom gnus-treat-display-xface
875 (and (or (and (fboundp 'image-type-available-p)
876 (image-type-available-p 'xbm))
877 (and gnus-xemacs (featurep 'xface)))
878 'head)
879 "Display X-Face headers.
880Valid values are nil, t, `head', `last', an integer or a predicate.
881See the manual for details."
882 :group 'gnus-article-treat
883 :type gnus-article-treat-head-custom)
884(put 'gnus-treat-display-xface 'highlight t)
885
886(defcustom gnus-treat-display-smileys (if (and gnus-xemacs
887 (featurep 'xpm))
888 t nil)
889 "Display smileys.
890Valid values are nil, t, `head', `last', an integer or a predicate.
891See the manual for details."
892 :group 'gnus-article-treat
893 :type gnus-article-treat-custom)
894(put 'gnus-treat-display-smileys 'highlight t)
895
896(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil)
897 "Display picons.
898Valid values are nil, t, `head', `last', an integer or a predicate.
899See the manual for details."
900 :group 'gnus-article-treat
901 :type gnus-article-treat-head-custom)
902(put 'gnus-treat-display-picons 'highlight t)
903
904(defcustom gnus-treat-capitalize-sentences nil
905 "Capitalize sentence-starting words.
906Valid values are nil, t, `head', `last', an integer or a predicate.
907See the manual for details."
908 :group 'gnus-article-treat
909 :type gnus-article-treat-custom)
910
911(defcustom gnus-treat-fill-long-lines nil
912 "Fill long lines.
913Valid values are nil, t, `head', `last', an integer or a predicate.
914See the manual for details."
915 :group 'gnus-article-treat
916 :type gnus-article-treat-custom)
917
918(defcustom gnus-treat-play-sounds nil
919 "Play sounds.
920Valid values are nil, t, `head', `last', an integer or a predicate.
921See the manual for details."
922 :group 'gnus-article-treat
923 :type gnus-article-treat-custom)
924
925(defcustom gnus-treat-translate nil
926 "Translate articles from one language to another.
927Valid values are nil, t, `head', `last', an integer or a predicate.
928See the manual for details."
929 :group 'gnus-article-treat
930 :type gnus-article-treat-custom)
931
562;;; Internal variables 932;;; Internal variables
563 933
934(defvar article-goto-body-goes-to-point-min-p nil)
935(defvar gnus-article-wash-types nil)
936(defvar gnus-article-emphasis-alist nil)
937
938(defvar gnus-article-mime-handle-alist-1 nil)
939(defvar gnus-treatment-function-alist
940 '((gnus-treat-strip-banner gnus-article-strip-banner)
941 (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
942 (gnus-treat-highlight-signature gnus-article-highlight-signature)
943 (gnus-treat-buttonize gnus-article-add-buttons)
944 (gnus-treat-fill-article gnus-article-fill-cited-article)
945 (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
946 (gnus-treat-strip-cr gnus-article-remove-cr)
947 (gnus-treat-emphasize gnus-article-emphasize)
948 (gnus-treat-display-xface gnus-article-display-x-face)
949 (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
950 (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
951 (gnus-treat-hide-signature gnus-article-hide-signature)
952 (gnus-treat-hide-citation gnus-article-hide-citation)
953 (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
954 (gnus-treat-strip-pgp gnus-article-hide-pgp)
955 (gnus-treat-strip-pem gnus-article-hide-pem)
956 (gnus-treat-highlight-headers gnus-article-highlight-headers)
957 (gnus-treat-highlight-citation gnus-article-highlight-citation)
958 (gnus-treat-highlight-signature gnus-article-highlight-signature)
959 (gnus-treat-date-ut gnus-article-date-ut)
960 (gnus-treat-date-local gnus-article-date-local)
961 (gnus-treat-date-lapsed gnus-article-date-lapsed)
962 (gnus-treat-date-original gnus-article-date-original)
963 (gnus-treat-date-user-defined gnus-article-date-user)
964 (gnus-treat-date-iso8601 gnus-article-date-iso8601)
965 (gnus-treat-strip-trailing-blank-lines
966 gnus-article-remove-trailing-blank-lines)
967 (gnus-treat-strip-leading-blank-lines
968 gnus-article-strip-leading-blank-lines)
969 (gnus-treat-strip-multiple-blank-lines
970 gnus-article-strip-multiple-blank-lines)
971 (gnus-treat-overstrike gnus-article-treat-overstrike)
972 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
973 (gnus-treat-display-smileys gnus-smiley-display)
974 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
975 (gnus-treat-display-picons gnus-article-display-picons)
976 (gnus-treat-play-sounds gnus-earcon-display)))
977
978(defvar gnus-article-mime-handle-alist nil)
564(defvar article-lapsed-timer nil) 979(defvar article-lapsed-timer nil)
565(defvar gnus-article-current-summary nil) 980(defvar gnus-article-current-summary nil)
566 981
@@ -576,7 +991,8 @@ Initialized from `text-mode-syntax-table.")
576(defvar gnus-save-article-buffer nil) 991(defvar gnus-save-article-buffer nil)
577 992
578(defvar gnus-article-mode-line-format-alist 993(defvar gnus-article-mode-line-format-alist
579 (nconc '((?w (gnus-article-wash-status) ?s)) 994 (nconc '((?w (gnus-article-wash-status) ?s)
995 (?m (gnus-article-mime-part-status) ?s))
580 gnus-summary-mode-line-format-alist)) 996 gnus-summary-mode-line-format-alist))
581 997
582(defvar gnus-number-of-articles-to-be-saved nil) 998(defvar gnus-number-of-articles-to-be-saved nil)
@@ -590,7 +1006,6 @@ Initialized from `text-mode-syntax-table.")
590 (put-text-property 1006 (put-text-property
591 (max (1- b) (point-min)) 1007 (max (1- b) (point-min))
592 b 'intangible (cddr (memq 'intangible props))))) 1008 b 'intangible (cddr (memq 'intangible props)))))
593
594(defsubst gnus-article-unhide-text (b e) 1009(defsubst gnus-article-unhide-text (b e)
595 "Remove hidden text properties from region between B and E." 1010 "Remove hidden text properties from region between B and E."
596 (remove-text-properties b e gnus-hidden-properties) 1011 (remove-text-properties b e gnus-hidden-properties)
@@ -600,11 +1015,14 @@ Initialized from `text-mode-syntax-table.")
600 1015
601(defun gnus-article-hide-text-type (b e type) 1016(defun gnus-article-hide-text-type (b e type)
602 "Hide text of TYPE between B and E." 1017 "Hide text of TYPE between B and E."
1018 (push type gnus-article-wash-types)
603 (gnus-article-hide-text 1019 (gnus-article-hide-text
604 b e (cons 'article-type (cons type gnus-hidden-properties)))) 1020 b e (cons 'article-type (cons type gnus-hidden-properties))))
605 1021
606(defun gnus-article-unhide-text-type (b e type) 1022(defun gnus-article-unhide-text-type (b e type)
607 "Unhide text of TYPE between B and E." 1023 "Unhide text of TYPE between B and E."
1024 (setq gnus-article-wash-types
1025 (delq type gnus-article-wash-types))
608 (remove-text-properties 1026 (remove-text-properties
609 b e (cons 'article-type (cons type gnus-hidden-properties))) 1027 b e (cons 'article-type (cons type gnus-hidden-properties)))
610 (when (memq 'intangible gnus-hidden-properties) 1028 (when (memq 'intangible gnus-hidden-properties)
@@ -653,79 +1071,60 @@ Initialized from `text-mode-syntax-table.")
653 i)) 1071 i))
654 1072
655(defun article-hide-headers (&optional arg delete) 1073(defun article-hide-headers (&optional arg delete)
656 "Toggle whether to hide unwanted headers and possibly sort them as well. 1074 "Hide unwanted headers and possibly sort them as well."
657If given a negative prefix, always show; if given a positive prefix, 1075 (interactive)
658always hide." 1076 ;; This function might be inhibited.
659 (interactive (gnus-article-hidden-arg)) 1077 (unless gnus-inhibit-hiding
660 (current-buffer) 1078 (save-excursion
661 (if (gnus-article-check-hidden-text 'headers arg) 1079 (save-restriction
662 ;; Show boring headers as well. 1080 (let ((buffer-read-only nil)
663 (gnus-article-show-hidden-text 'boring-headers) 1081 (case-fold-search t)
664 ;; This function might be inhibited. 1082 (max (1+ (length gnus-sorted-header-list)))
665 (unless gnus-inhibit-hiding 1083 (ignored (when (not gnus-visible-headers)
666 (save-excursion 1084 (cond ((stringp gnus-ignored-headers)
667 (save-restriction 1085 gnus-ignored-headers)
668 (let ((buffer-read-only nil) 1086 ((listp gnus-ignored-headers)
669 (case-fold-search t) 1087 (mapconcat 'identity gnus-ignored-headers
670 (props (nconc (list 'article-type 'headers) 1088 "\\|")))))
671 gnus-hidden-properties)) 1089 (visible
672 (max (1+ (length gnus-sorted-header-list))) 1090 (cond ((stringp gnus-visible-headers)
673 (ignored (when (not gnus-visible-headers) 1091 gnus-visible-headers)
674 (cond ((stringp gnus-ignored-headers) 1092 ((and gnus-visible-headers
675 gnus-ignored-headers) 1093 (listp gnus-visible-headers))
676 ((listp gnus-ignored-headers) 1094 (mapconcat 'identity gnus-visible-headers "\\|"))))
677 (mapconcat 'identity gnus-ignored-headers 1095 (inhibit-point-motion-hooks t)
678 "\\|"))))) 1096 beg)
679 (visible 1097 ;; First we narrow to just the headers.
680 (cond ((stringp gnus-visible-headers) 1098 (article-narrow-to-head)
681 gnus-visible-headers) 1099 ;; Hide any "From " lines at the beginning of (mail) articles.
682 ((and gnus-visible-headers 1100 (while (looking-at "From ")
683 (listp gnus-visible-headers)) 1101 (forward-line 1))
684 (mapconcat 'identity gnus-visible-headers "\\|")))) 1102 (unless (bobp)
685 (inhibit-point-motion-hooks t) 1103 (delete-region (point-min) (point)))
686 beg) 1104 ;; Then treat the rest of the header lines.
687 ;; First we narrow to just the headers. 1105 ;; Then we use the two regular expressions
688 (widen) 1106 ;; `gnus-ignored-headers' and `gnus-visible-headers' to
689 (goto-char (point-min)) 1107 ;; select which header lines is to remain visible in the
690 ;; Hide any "From " lines at the beginning of (mail) articles. 1108 ;; article buffer.
691 (while (looking-at "From ") 1109 (while (re-search-forward "^[^ \t]*:" nil t)
692 (forward-line 1)) 1110 (beginning-of-line)
693 (unless (bobp) 1111 ;; Mark the rank of the header.
694 (if delete 1112 (put-text-property
695 (delete-region (point-min) (point)) 1113 (point) (1+ (point)) 'message-rank
696 (gnus-article-hide-text (point-min) (point) props))) 1114 (if (or (and visible (looking-at visible))
697 ;; Then treat the rest of the header lines. 1115 (and ignored
698 (narrow-to-region 1116 (not (looking-at ignored))))
699 (point) 1117 (gnus-article-header-rank)
700 (if (search-forward "\n\n" nil t) ; if there's a body 1118 (+ 2 max)))
701 (progn (forward-line -1) (point)) 1119 (forward-line 1))
702 (point-max))) 1120 (message-sort-headers-1)
703 ;; Then we use the two regular expressions 1121 (when (setq beg (text-property-any
704 ;; `gnus-ignored-headers' and `gnus-visible-headers' to 1122 (point-min) (point-max) 'message-rank (+ 2 max)))
705 ;; select which header lines is to remain visible in the 1123 ;; We delete the unwanted headers.
706 ;; article buffer. 1124 (push 'headers gnus-article-wash-types)
707 (goto-char (point-min)) 1125 (add-text-properties (point-min) (+ 5 (point-min))
708 (while (re-search-forward "^[^ \t]*:" nil t) 1126 '(article-type headers dummy-invisible t))
709 (beginning-of-line) 1127 (delete-region beg (point-max))))))))
710 ;; Mark the rank of the header.
711 (put-text-property
712 (point) (1+ (point)) 'message-rank
713 (if (or (and visible (looking-at visible))
714 (and ignored
715 (not (looking-at ignored))))
716 (gnus-article-header-rank)
717 (+ 2 max)))
718 (forward-line 1))
719 (message-sort-headers-1)
720 (when (setq beg (text-property-any
721 (point-min) (point-max) 'message-rank (+ 2 max)))
722 ;; We make the unwanted headers invisible.
723 (if delete
724 (delete-region beg (point-max))
725 ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
726 (gnus-article-hide-text-type beg (point-max) 'headers))
727 ;; Work around XEmacs lossage.
728 (put-text-property (point-min) beg 'invisible nil))))))))
729 1128
730(defun article-hide-boring-headers (&optional arg) 1129(defun article-hide-boring-headers (&optional arg)
731 "Toggle hiding of headers that aren't very interesting. 1130 "Toggle hiding of headers that aren't very interesting.
@@ -740,14 +1139,14 @@ always hide."
740 (list gnus-boring-article-headers) 1139 (list gnus-boring-article-headers)
741 (inhibit-point-motion-hooks t) 1140 (inhibit-point-motion-hooks t)
742 elem) 1141 elem)
743 (nnheader-narrow-to-headers) 1142 (article-narrow-to-head)
744 (while list 1143 (while list
745 (setq elem (pop list)) 1144 (setq elem (pop list))
746 (goto-char (point-min)) 1145 (goto-char (point-min))
747 (cond 1146 (cond
748 ;; Hide empty headers. 1147 ;; Hide empty headers.
749 ((eq elem 'empty) 1148 ((eq elem 'empty)
750 (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) 1149 (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
751 (forward-line -1) 1150 (forward-line -1)
752 (gnus-article-hide-text-type 1151 (gnus-article-hide-text-type
753 (progn (beginning-of-line) (point)) 1152 (progn (beginning-of-line) (point))
@@ -782,15 +1181,19 @@ always hide."
782 ((eq elem 'date) 1181 ((eq elem 'date)
783 (let ((date (message-fetch-field "date"))) 1182 (let ((date (message-fetch-field "date")))
784 (when (and date 1183 (when (and date
785 (< (gnus-days-between (current-time-string) date) 1184 (< (days-between (current-time-string) date)
786 4)) 1185 4))
787 (gnus-article-hide-header "date")))) 1186 (gnus-article-hide-header "date"))))
788 ((eq elem 'long-to) 1187 ((eq elem 'long-to)
789 (let ((to (message-fetch-field "to"))) 1188 (let ((to (message-fetch-field "to"))
1189 (cc (message-fetch-field "cc")))
790 (when (> (length to) 1024) 1190 (when (> (length to) 1024)
791 (gnus-article-hide-header "to")))) 1191 (gnus-article-hide-header "to"))
1192 (when (> (length cc) 1024)
1193 (gnus-article-hide-header "cc"))))
792 ((eq elem 'many-to) 1194 ((eq elem 'many-to)
793 (let ((to-count 0)) 1195 (let ((to-count 0)
1196 (cc-count 0))
794 (goto-char (point-min)) 1197 (goto-char (point-min))
795 (while (re-search-forward "^to:" nil t) 1198 (while (re-search-forward "^to:" nil t)
796 (setq to-count (1+ to-count))) 1199 (setq to-count (1+ to-count)))
@@ -802,7 +1205,19 @@ always hide."
802 (forward-line -1) 1205 (forward-line -1)
803 (narrow-to-region (point) (point-max)) 1206 (narrow-to-region (point) (point-max))
804 (gnus-article-hide-header "to")) 1207 (gnus-article-hide-header "to"))
805 (setq to-count (1- to-count))))))))))))) 1208 (setq to-count (1- to-count))))
1209 (goto-char (point-min))
1210 (while (re-search-forward "^cc:" nil t)
1211 (setq cc-count (1+ cc-count)))
1212 (when (> cc-count 1)
1213 (while (> cc-count 0)
1214 (goto-char (point-min))
1215 (save-restriction
1216 (re-search-forward "^cc:" nil nil cc-count)
1217 (forward-line -1)
1218 (narrow-to-region (point) (point-max))
1219 (gnus-article-hide-header "cc"))
1220 (setq cc-count (1- cc-count)))))))))))))
806 1221
807(defun gnus-article-hide-header (header) 1222(defun gnus-article-hide-header (header)
808 (save-excursion 1223 (save-excursion
@@ -817,18 +1232,50 @@ always hide."
817 (point-max))) 1232 (point-max)))
818 'boring-headers)))) 1233 'boring-headers))))
819 1234
1235(defvar gnus-article-normalized-header-length 40
1236 "Length of normalized headers.")
1237
1238(defun article-normalize-headers ()
1239 "Make all header lines 40 characters long."
1240 (interactive)
1241 (let ((buffer-read-only nil)
1242 column)
1243 (save-excursion
1244 (save-restriction
1245 (article-narrow-to-head)
1246 (while (not (eobp))
1247 (cond
1248 ((< (setq column (- (gnus-point-at-eol) (point)))
1249 gnus-article-normalized-header-length)
1250 (end-of-line)
1251 (insert (make-string
1252 (- gnus-article-normalized-header-length column)
1253 ? )))
1254 ((> column gnus-article-normalized-header-length)
1255 (gnus-put-text-property
1256 (progn
1257 (forward-char gnus-article-normalized-header-length)
1258 (point))
1259 (gnus-point-at-eol)
1260 'invisible t))
1261 (t
1262 ;; Do nothing.
1263 ))
1264 (forward-line 1))))))
1265
820(defun article-treat-dumbquotes () 1266(defun article-treat-dumbquotes ()
821 "Translate M******** sm*rtq**t*s into proper text." 1267 "Translate M******** sm*rtq**t*s into proper text.
1268Note that this function guesses whether a character is a sm*rtq**t* or
1269not, so it should only be used interactively."
822 (interactive) 1270 (interactive)
823 (article-translate-characters "\221\222\223\223" "`'\"\"")) 1271 (article-translate-strings gnus-article-dumbquotes-map))
824 1272
825(defun article-translate-characters (from to) 1273(defun article-translate-characters (from to)
826 "Translate all characters in the body of the article according to FROM and TO. 1274 "Translate all characters in the body of the article according to FROM and TO.
827FROM is a string of characters to translate from; to is a string of 1275FROM is a string of characters to translate from; to is a string of
828characters to translate to." 1276characters to translate to."
829 (save-excursion 1277 (save-excursion
830 (goto-char (point-min)) 1278 (when (article-goto-body)
831 (when (search-forward "\n\n" nil t)
832 (let ((buffer-read-only nil) 1279 (let ((buffer-read-only nil)
833 (x (make-string 225 ?x)) 1280 (x (make-string 225 ?x))
834 (i -1)) 1281 (i -1))
@@ -840,15 +1287,26 @@ characters to translate to."
840 (incf i)) 1287 (incf i))
841 (translate-region (point) (point-max) x))))) 1288 (translate-region (point) (point-max) x)))))
842 1289
1290(defun article-translate-strings (map)
1291 "Translate all string in the body of the article according to MAP.
1292MAP is an alist where the elements are on the form (\"from\" \"to\")."
1293 (save-excursion
1294 (when (article-goto-body)
1295 (let ((buffer-read-only nil)
1296 elem)
1297 (while (setq elem (pop map))
1298 (save-excursion
1299 (while (search-forward (car elem) nil t)
1300 (replace-match (cadr elem)))))))))
1301
843(defun article-treat-overstrike () 1302(defun article-treat-overstrike ()
844 "Translate overstrikes into bold text." 1303 "Translate overstrikes into bold text."
845 (interactive) 1304 (interactive)
846 (save-excursion 1305 (save-excursion
847 (goto-char (point-min)) 1306 (when (article-goto-body)
848 (when (search-forward "\n\n" nil t)
849 (let ((buffer-read-only nil)) 1307 (let ((buffer-read-only nil))
850 (while (search-forward "\b" nil t) 1308 (while (search-forward "\b" nil t)
851 (let ((next (following-char)) 1309 (let ((next (char-after))
852 (previous (char-after (- (point) 2)))) 1310 (previous (char-after (- (point) 2))))
853 ;; We do the boldification/underlining by hiding the 1311 ;; We do the boldification/underlining by hiding the
854 ;; overstrikes and putting the proper text property 1312 ;; overstrikes and putting the proper text property
@@ -867,32 +1325,46 @@ characters to translate to."
867 (put-text-property 1325 (put-text-property
868 (point) (1+ (point)) 'face 'underline))))))))) 1326 (point) (1+ (point)) 'face 'underline)))))))))
869 1327
870(defun article-fill () 1328(defun article-fill-long-lines ()
871 "Format too long lines." 1329 "Fill lines that are wider than the window width."
872 (interactive) 1330 (interactive)
873 (save-excursion 1331 (save-excursion
874 (let ((buffer-read-only nil)) 1332 (let ((buffer-read-only nil)
875 (widen) 1333 (width (window-width (get-buffer-window (current-buffer)))))
876 (goto-char (point-min)) 1334 (save-restriction
877 (search-forward "\n\n" nil t) 1335 (article-goto-body)
878 (end-of-line 1) 1336 (let ((adaptive-fill-mode nil))
879 (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") 1337 (while (not (eobp))
880 (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") 1338 (end-of-line)
881 (adaptive-fill-mode t)) 1339 (when (>= (current-column) (min fill-column width))
882 (while (not (eobp)) 1340 (narrow-to-region (point) (gnus-point-at-bol))
883 (and (>= (current-column) (min fill-column (window-width))) 1341 (fill-paragraph nil)
884 (/= (preceding-char) ?:) 1342 (goto-char (point-max))
885 (fill-paragraph nil)) 1343 (widen))
886 (end-of-line 2)))))) 1344 (forward-line 1)))))))
1345
1346(defun article-capitalize-sentences ()
1347 "Capitalize the first word in each sentence."
1348 (interactive)
1349 (save-excursion
1350 (let ((buffer-read-only nil)
1351 (paragraph-start "^[\n\^L]"))
1352 (article-goto-body)
1353 (while (not (eobp))
1354 (capitalize-word 1)
1355 (forward-sentence)))))
887 1356
888(defun article-remove-cr () 1357(defun article-remove-cr ()
889 "Remove carriage returns from an article." 1358 "Remove trailing CRs and then translate remaining CRs into LFs."
890 (interactive) 1359 (interactive)
891 (save-excursion 1360 (save-excursion
892 (let ((buffer-read-only nil)) 1361 (let ((buffer-read-only nil))
893 (goto-char (point-min)) 1362 (goto-char (point-min))
1363 (while (re-search-forward "\r+$" nil t)
1364 (replace-match "" t t))
1365 (goto-char (point-min))
894 (while (search-forward "\r" nil t) 1366 (while (search-forward "\r" nil t)
895 (replace-match "" t t))))) 1367 (replace-match "\n" t t)))))
896 1368
897(defun article-remove-trailing-blank-lines () 1369(defun article-remove-trailing-blank-lines ()
898 "Remove all trailing blank lines from the article." 1370 "Remove all trailing blank lines from the article."
@@ -904,7 +1376,9 @@ characters to translate to."
904 (point) 1376 (point)
905 (progn 1377 (progn
906 (while (and (not (bobp)) 1378 (while (and (not (bobp))
907 (looking-at "^[ \t]*$")) 1379 (looking-at "^[ \t]*$")
1380 (not (gnus-annotation-in-region-p
1381 (point) (gnus-point-at-eol))))
908 (forward-line -1)) 1382 (forward-line -1))
909 (forward-line 1) 1383 (forward-line 1)
910 (point)))))) 1384 (point))))))
@@ -920,7 +1394,8 @@ characters to translate to."
920 (case-fold-search t) 1394 (case-fold-search t)
921 from last) 1395 from last)
922 (save-restriction 1396 (save-restriction
923 (nnheader-narrow-to-headers) 1397 (article-narrow-to-head)
1398 (goto-char (point-min))
924 (setq from (message-fetch-field "from")) 1399 (setq from (message-fetch-field "from"))
925 (goto-char (point-min)) 1400 (goto-char (point-min))
926 (while (and gnus-article-x-face-command 1401 (while (and gnus-article-x-face-command
@@ -959,99 +1434,212 @@ characters to translate to."
959 (process-send-region "article-x-face" beg end) 1434 (process-send-region "article-x-face" beg end)
960 (process-send-eof "article-x-face")))))))))) 1435 (process-send-eof "article-x-face"))))))))))
961 1436
962(defun gnus-hack-decode-rfc1522 () 1437(defun article-decode-mime-words ()
963 "Emergency hack function for avoiding problems when decoding." 1438 "Decode all MIME-encoded words in the article."
964 (let ((buffer-read-only nil)) 1439 (interactive)
965 (goto-char (point-min)) 1440 (save-excursion
966 ;; Remove encoded TABs. 1441 (set-buffer gnus-article-buffer)
967 (while (search-forward "=09" nil t) 1442 (let ((inhibit-point-motion-hooks t)
968 (replace-match " " t t)) 1443 buffer-read-only
969 ;; Remove encoded newlines. 1444 (mail-parse-charset gnus-newsgroup-charset)
970 (goto-char (point-min)) 1445 (mail-parse-ignored-charsets
971 (while (search-forward "=10" nil t) 1446 (save-excursion (set-buffer gnus-summary-buffer)
972 (replace-match " " t t)))) 1447 gnus-newsgroup-ignored-charsets)))
973 1448 (mail-decode-encoded-word-region (point-min) (point-max)))))
974(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) 1449
975(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) 1450(defun article-decode-charset (&optional prompt)
976(defun article-decode-rfc1522 () 1451 "Decode charset-encoded text in the article.
977 "Hack to remove QP encoding from headers." 1452If PROMPT (the prefix), prompt for a coding system to use."
978 (let ((case-fold-search t) 1453 (interactive "P")
979 (inhibit-point-motion-hooks t) 1454 (let ((inhibit-point-motion-hooks t) (case-fold-search t)
980 (buffer-read-only nil) 1455 buffer-read-only
981 string) 1456 (mail-parse-charset gnus-newsgroup-charset)
1457 (mail-parse-ignored-charsets
1458 (save-excursion (condition-case nil
1459 (set-buffer gnus-summary-buffer)
1460 (error))
1461 gnus-newsgroup-ignored-charsets))
1462 ct cte ctl charset format)
1463 (save-excursion
982 (save-restriction 1464 (save-restriction
983 (narrow-to-region 1465 (article-narrow-to-head)
984 (goto-char (point-min)) 1466 (setq ct (message-fetch-field "Content-Type" t)
985 (or (search-forward "\n\n" nil t) (point-max))) 1467 cte (message-fetch-field "Content-Transfer-Encoding" t)
986 (goto-char (point-min)) 1468 ctl (and ct (ignore-errors
987 (while (re-search-forward 1469 (mail-header-parse-content-type ct)))
988 "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) 1470 charset (cond
989 (setq string (match-string 1)) 1471 (prompt
990 (save-restriction 1472 (mm-read-coding-system "Charset to decode: "))
991 (narrow-to-region (match-beginning 0) (match-end 0)) 1473 (ctl
992 (delete-region (point-min) (point-max)) 1474 (mail-content-type-get ctl 'charset)))
993 (insert string) 1475 format (and ctl (mail-content-type-get ctl 'format)))
994 (article-mime-decode-quoted-printable 1476 (when cte
995 (goto-char (point-min)) (point-max)) 1477 (setq cte (mail-header-strip cte)))
996 (subst-char-in-region (point-min) (point-max) ?_ ? ) 1478 (if (and ctl (not (string-match "/" (car ctl))))
997 (goto-char (point-max))) 1479 (setq ctl nil))
998 (goto-char (point-min)))))) 1480 (goto-char (point-max)))
1481 (forward-line 1)
1482 (save-restriction
1483 (narrow-to-region (point) (point-max))
1484 (when (and (eq mail-parse-charset 'gnus-decoded)
1485 (eq (mm-body-7-or-8) '8bit))
1486 ;; The text code could have been decoded.
1487 (setq charset mail-parse-charset))
1488 (when (and (or (not ctl)
1489 (equal (car ctl) "text/plain"))
1490 (not format)) ;; article with format will decode later.
1491 (mm-decode-body
1492 charset (and cte (intern (downcase
1493 (gnus-strip-whitespace cte))))
1494 (car ctl)))))))
1495
1496(defun article-decode-encoded-words ()
1497 "Remove encoded-word encoding from headers."
1498 (let ((inhibit-point-motion-hooks t)
1499 (mail-parse-charset gnus-newsgroup-charset)
1500 (mail-parse-ignored-charsets
1501 (save-excursion (condition-case nil
1502 (set-buffer gnus-summary-buffer)
1503 (error))
1504 gnus-newsgroup-ignored-charsets))
1505 buffer-read-only)
1506 (save-restriction
1507 (article-narrow-to-head)
1508 (funcall gnus-decode-header-function (point-min) (point-max)))))
999 1509
1000(defun article-de-quoted-unreadable (&optional force) 1510(defun article-de-quoted-unreadable (&optional force)
1001 "Do a naive translation of a quoted-printable-encoded article. 1511 "Translate a quoted-printable-encoded article.
1002This is in no way, shape or form meant as a replacement for real MIME
1003processing, but is simply a stop-gap measure until MIME support is
1004written.
1005If FORCE, decode the article whether it is marked as quoted-printable 1512If FORCE, decode the article whether it is marked as quoted-printable
1006or not." 1513or not."
1007 (interactive (list 'force)) 1514 (interactive (list 'force))
1008 (save-excursion 1515 (save-excursion
1009 (let ((case-fold-search t) 1516 (let ((buffer-read-only nil) type charset)
1010 (buffer-read-only nil) 1517 (if (gnus-buffer-live-p gnus-original-article-buffer)
1011 (type (gnus-fetch-field "content-transfer-encoding"))) 1518 (with-current-buffer gnus-original-article-buffer
1012 (gnus-article-decode-rfc1522) 1519 (setq type
1520 (gnus-fetch-field "content-transfer-encoding"))
1521 (let* ((ct (gnus-fetch-field "content-type"))
1522 (ctl (and ct
1523 (ignore-errors
1524 (mail-header-parse-content-type ct)))))
1525 (setq charset (and ctl
1526 (mail-content-type-get ctl 'charset)))
1527 (if (stringp charset)
1528 (setq charset (intern (downcase charset)))))))
1529 (unless charset
1530 (setq charset gnus-newsgroup-charset))
1013 (when (or force 1531 (when (or force
1014 (and type (string-match "quoted-printable" (downcase type)))) 1532 (and type (string-match "quoted-printable" (downcase type))))
1015 (goto-char (point-min)) 1533 (article-goto-body)
1016 (search-forward "\n\n" nil 'move) 1534 (quoted-printable-decode-region (point) (point-max) charset)))))
1017 (article-mime-decode-quoted-printable (point) (point-max)))))) 1535
1018 1536(defun article-de-base64-unreadable (&optional force)
1019(defun article-mime-decode-quoted-printable-buffer () 1537 "Translate a base64 article.
1020 "Decode Quoted-Printable in the current buffer." 1538If FORCE, decode the article whether it is marked as base64 not."
1021 (article-mime-decode-quoted-printable (point-min) (point-max))) 1539 (interactive (list 'force))
1022 1540 (save-excursion
1023(defun article-mime-decode-quoted-printable (from to) 1541 (let ((buffer-read-only nil) type charset)
1024 "Decode Quoted-Printable in the region between FROM and TO." 1542 (if (gnus-buffer-live-p gnus-original-article-buffer)
1025 (interactive "r") 1543 (with-current-buffer gnus-original-article-buffer
1026 (goto-char from) 1544 (setq type
1027 (while (search-forward "=" to t) 1545 (gnus-fetch-field "content-transfer-encoding"))
1028 (cond ((eq (following-char) ?\n) 1546 (let* ((ct (gnus-fetch-field "content-type"))
1029 (delete-char -1) 1547 (ctl (and ct
1030 (delete-char 1)) 1548 (ignore-errors
1031 ((looking-at "[0-9A-F][0-9A-F]") 1549 (mail-header-parse-content-type ct)))))
1032 (subst-char-in-region 1550 (setq charset (and ctl
1033 (1- (point)) (point) ?= 1551 (mail-content-type-get ctl 'charset)))
1034 (hexl-hex-string-to-integer 1552 (if (stringp charset)
1035 (buffer-substring (point) (+ 2 (point))))) 1553 (setq charset (intern (downcase charset)))))))
1036 (delete-char 2)) 1554 (unless charset
1037 ((looking-at "=") 1555 (setq charset gnus-newsgroup-charset))
1038 (delete-char 1)) 1556 (when (or force
1039 ((gnus-message 3 "Malformed MIME quoted-printable message"))))) 1557 (and type (string-match "base64" (downcase type))))
1040 1558 (article-goto-body)
1041(defun article-hide-pgp (&optional arg) 1559 (save-restriction
1042 "Toggle hiding of any PGP headers and signatures in the current article. 1560 (narrow-to-region (point) (point-max))
1043If given a negative prefix, always show; if given a positive prefix, 1561 (base64-decode-region (point-min) (point-max))
1044always hide." 1562 (if (mm-coding-system-p charset)
1045 (interactive (gnus-article-hidden-arg)) 1563 (mm-decode-coding-region (point-min) (point-max) charset)))))))
1046 (unless (gnus-article-check-hidden-text 'pgp arg) 1564
1047 (save-excursion 1565(eval-when-compile
1566 (require 'rfc1843))
1567
1568(defun article-decode-HZ ()
1569 "Translate a HZ-encoded article."
1570 (interactive)
1571 (require 'rfc1843)
1572 (save-excursion
1573 (let ((buffer-read-only nil))
1574 (rfc1843-decode-region (point-min) (point-max)))))
1575
1576(defun article-wash-html ()
1577 "Format an html article."
1578 (interactive)
1579 (save-excursion
1580 (let ((buffer-read-only nil)
1581 charset)
1582 (if (gnus-buffer-live-p gnus-original-article-buffer)
1583 (with-current-buffer gnus-original-article-buffer
1584 (let* ((ct (gnus-fetch-field "content-type"))
1585 (ctl (and ct
1586 (ignore-errors
1587 (mail-header-parse-content-type ct)))))
1588 (setq charset (and ctl
1589 (mail-content-type-get ctl 'charset)))
1590 (if (stringp charset)
1591 (setq charset (intern (downcase charset)))))))
1592 (unless charset
1593 (setq charset gnus-newsgroup-charset))
1594 (article-goto-body)
1595 (save-window-excursion
1596 (save-restriction
1597 (narrow-to-region (point) (point-max))
1598 (mm-setup-w3)
1599 (let ((w3-strict-width (window-width))
1600 (url-standalone-mode t))
1601 (condition-case var
1602 (w3-region (point-min) (point-max))
1603 (error))))))))
1604
1605(defun article-hide-list-identifiers ()
1606 "Remove list identifies from the Subject header.
1607The `gnus-list-identifiers' variable specifies what to do."
1608 (interactive)
1609 (save-excursion
1610 (save-restriction
1611 (let ((inhibit-point-motion-hooks t)
1612 buffer-read-only)
1613 (article-narrow-to-head)
1614 (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers
1615 (mapconcat 'identity gnus-list-identifiers " *\\|"))))
1616 (when regexp
1617 (goto-char (point-min))
1618 (when (re-search-forward
1619 (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp
1620 " *\\)\\)+\\(Re: +\\)?\\)")
1621 nil t)
1622 (let ((s (or (match-string 3) (match-string 5))))
1623 (delete-region (match-beginning 1) (match-end 1))
1624 (when s
1625 (goto-char (match-beginning 1))
1626 (insert s))))))))))
1627
1628(defun article-hide-pgp ()
1629 "Remove any PGP headers and signatures in the current article."
1630 (interactive)
1631 (save-excursion
1632 (save-restriction
1048 (let ((inhibit-point-motion-hooks t) 1633 (let ((inhibit-point-motion-hooks t)
1049 buffer-read-only beg end) 1634 buffer-read-only beg end)
1050 (widen) 1635 (article-goto-body)
1051 (goto-char (point-min))
1052 ;; Hide the "header". 1636 ;; Hide the "header".
1053 (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) 1637 (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
1054 (delete-region (1+ (match-beginning 0)) (match-end 0)) 1638 (push 'pgp gnus-article-wash-types)
1639 (delete-region (match-beginning 0) (match-end 0))
1640 ;; Remove armor headers (rfc2440 6.2)
1641 (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
1642 (point)))
1055 (setq beg (point)) 1643 (setq beg (point))
1056 ;; Hide the actual signature. 1644 ;; Hide the actual signature.
1057 (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) 1645 (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
@@ -1081,25 +1669,62 @@ always hide."
1081 (unless (gnus-article-check-hidden-text 'pem arg) 1669 (unless (gnus-article-check-hidden-text 'pem arg)
1082 (save-excursion 1670 (save-excursion
1083 (let (buffer-read-only end) 1671 (let (buffer-read-only end)
1084 (widen)
1085 (goto-char (point-min)) 1672 (goto-char (point-min))
1086 ;; hide the horrendously ugly "header". 1673 ;; Hide the horrendously ugly "header".
1087 (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" 1674 (when (and (search-forward
1088 nil 1675 "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
1089 t) 1676 nil t)
1090 (setq end (1+ (match-beginning 0))) 1677 (setq end (1+ (match-beginning 0))))
1091 (gnus-article-hide-text-type 1678 (push 'pem gnus-article-wash-types)
1092 end 1679 (gnus-article-hide-text-type
1093 (if (search-forward "\n\n" nil t) 1680 end
1094 (match-end 0) 1681 (if (search-forward "\n\n" nil t)
1095 (point-max)) 1682 (match-end 0)
1096 'pem)) 1683 (point-max))
1097 ;; hide the trailer as well 1684 'pem)
1098 (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" 1685 ;; Hide the trailer as well
1099 nil 1686 (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
1100 t) 1687 nil t)
1101 (gnus-article-hide-text-type 1688 (gnus-article-hide-text-type
1102 (match-beginning 0) (match-end 0) 'pem)))))) 1689 (match-beginning 0) (match-end 0) 'pem)))))))
1690
1691(defun article-strip-banner ()
1692 "Strip the banner specified by the `banner' group parameter."
1693 (interactive)
1694 (save-excursion
1695 (save-restriction
1696 (let ((inhibit-point-motion-hooks t)
1697 (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner))
1698 (gnus-signature-limit nil)
1699 buffer-read-only beg end)
1700 (when banner
1701 (article-goto-body)
1702 (cond
1703 ((eq banner 'signature)
1704 (when (gnus-article-narrow-to-signature)
1705 (widen)
1706 (forward-line -1)
1707 (delete-region (point) (point-max))))
1708 ((stringp banner)
1709 (while (re-search-forward banner nil t)
1710 (delete-region (match-beginning 0) (match-end 0))))))))))
1711
1712(defun article-babel ()
1713 "Translate article using an online translation service."
1714 (interactive)
1715 (require 'babel)
1716 (save-excursion
1717 (set-buffer gnus-article-buffer)
1718 (when (article-goto-body)
1719 (let* ((buffer-read-only nil)
1720 (start (point))
1721 (end (point-max))
1722 (orig (buffer-substring start end))
1723 (trans (babel-as-string orig)))
1724 (save-restriction
1725 (narrow-to-region start end)
1726 (delete-region start end)
1727 (insert trans))))))
1103 1728
1104(defun article-hide-signature (&optional arg) 1729(defun article-hide-signature (&optional arg)
1105 "Hide the signature in the current article. 1730 "Hide the signature in the current article.
@@ -1114,18 +1739,50 @@ always hide."
1114 (gnus-article-hide-text-type 1739 (gnus-article-hide-text-type
1115 (point-min) (point-max) 'signature))))))) 1740 (point-min) (point-max) 'signature)))))))
1116 1741
1742(defun article-strip-headers-in-body ()
1743 "Strip offensive headers from bodies."
1744 (interactive)
1745 (save-excursion
1746 (article-goto-body)
1747 (let ((case-fold-search t))
1748 (when (looking-at "x-no-archive:")
1749 (gnus-delete-line)))))
1750
1117(defun article-strip-leading-blank-lines () 1751(defun article-strip-leading-blank-lines ()
1118 "Remove all blank lines from the beginning of the article." 1752 "Remove all blank lines from the beginning of the article."
1119 (interactive) 1753 (interactive)
1120 (save-excursion 1754 (save-excursion
1121 (let ((inhibit-point-motion-hooks t) 1755 (let ((inhibit-point-motion-hooks t)
1122 buffer-read-only) 1756 buffer-read-only)
1123 (goto-char (point-min)) 1757 (when (article-goto-body)
1124 (when (search-forward "\n\n" nil t)
1125 (while (and (not (eobp)) 1758 (while (and (not (eobp))
1126 (looking-at "[ \t]*$")) 1759 (looking-at "[ \t]*$"))
1127 (gnus-delete-line)))))) 1760 (gnus-delete-line))))))
1128 1761
1762(defun article-narrow-to-head ()
1763 "Narrow the buffer to the head of the message.
1764Point is left at the beginning of the narrowed-to region."
1765 (narrow-to-region
1766 (goto-char (point-min))
1767 (if (search-forward "\n\n" nil 1)
1768 (1- (point))
1769 (point-max)))
1770 (goto-char (point-min)))
1771
1772(defun article-goto-body ()
1773 "Place point at the start of the body."
1774 (goto-char (point-min))
1775 (cond
1776 ;; This variable is only bound when dealing with separate
1777 ;; MIME body parts.
1778 (article-goto-body-goes-to-point-min-p
1779 t)
1780 ((search-forward "\n\n" nil t)
1781 t)
1782 (t
1783 (goto-char (point-max))
1784 nil)))
1785
1129(defun article-strip-multiple-blank-lines () 1786(defun article-strip-multiple-blank-lines ()
1130 "Replace consecutive blank lines with one empty line." 1787 "Replace consecutive blank lines with one empty line."
1131 (interactive) 1788 (interactive)
@@ -1133,15 +1790,17 @@ always hide."
1133 (let ((inhibit-point-motion-hooks t) 1790 (let ((inhibit-point-motion-hooks t)
1134 buffer-read-only) 1791 buffer-read-only)
1135 ;; First make all blank lines empty. 1792 ;; First make all blank lines empty.
1136 (goto-char (point-min)) 1793 (article-goto-body)
1137 (search-forward "\n\n" nil t)
1138 (while (re-search-forward "^[ \t]+$" nil t) 1794 (while (re-search-forward "^[ \t]+$" nil t)
1139 (replace-match "" nil t)) 1795 (unless (gnus-annotation-in-region-p
1796 (match-beginning 0) (match-end 0))
1797 (replace-match "" nil t)))
1140 ;; Then replace multiple empty lines with a single empty line. 1798 ;; Then replace multiple empty lines with a single empty line.
1141 (goto-char (point-min)) 1799 (article-goto-body)
1142 (search-forward "\n\n" nil t)
1143 (while (re-search-forward "\n\n\n+" nil t) 1800 (while (re-search-forward "\n\n\n+" nil t)
1144 (replace-match "\n\n" t t))))) 1801 (unless (gnus-annotation-in-region-p
1802 (match-beginning 0) (match-end 0))
1803 (replace-match "\n\n" t t))))))
1145 1804
1146(defun article-strip-leading-space () 1805(defun article-strip-leading-space ()
1147 "Remove all white space from the beginning of the lines in the article." 1806 "Remove all white space from the beginning of the lines in the article."
@@ -1149,11 +1808,20 @@ always hide."
1149 (save-excursion 1808 (save-excursion
1150 (let ((inhibit-point-motion-hooks t) 1809 (let ((inhibit-point-motion-hooks t)
1151 buffer-read-only) 1810 buffer-read-only)
1152 (goto-char (point-min)) 1811 (article-goto-body)
1153 (search-forward "\n\n" nil t)
1154 (while (re-search-forward "^[ \t]+" nil t) 1812 (while (re-search-forward "^[ \t]+" nil t)
1155 (replace-match "" t t))))) 1813 (replace-match "" t t)))))
1156 1814
1815(defun article-strip-trailing-space ()
1816 "Remove all white space from the end of the lines in the article."
1817 (interactive)
1818 (save-excursion
1819 (let ((inhibit-point-motion-hooks t)
1820 buffer-read-only)
1821 (article-goto-body)
1822 (while (re-search-forward "[ \t]+$" nil t)
1823 (replace-match "" t t)))))
1824
1157(defun article-strip-blank-lines () 1825(defun article-strip-blank-lines ()
1158 "Strip leading, trailing and multiple blank lines." 1826 "Strip leading, trailing and multiple blank lines."
1159 (interactive) 1827 (interactive)
@@ -1167,26 +1835,13 @@ always hide."
1167 (save-excursion 1835 (save-excursion
1168 (let ((inhibit-point-motion-hooks t) 1836 (let ((inhibit-point-motion-hooks t)
1169 buffer-read-only) 1837 buffer-read-only)
1170 (goto-char (point-min)) 1838 (article-goto-body)
1171 (search-forward "\n\n" nil t)
1172 (while (re-search-forward "^[ \t]*\n" nil t) 1839 (while (re-search-forward "^[ \t]*\n" nil t)
1173 (replace-match "" t t))))) 1840 (replace-match "" t t)))))
1174 1841
1175(defvar mime::preview/content-list)
1176(defvar mime::preview-content-info/point-min)
1177(defun gnus-article-narrow-to-signature () 1842(defun gnus-article-narrow-to-signature ()
1178 "Narrow to the signature; return t if a signature is found, else nil." 1843 "Narrow to the signature; return t if a signature is found, else nil."
1179 (widen)
1180 (let ((inhibit-point-motion-hooks t)) 1844 (let ((inhibit-point-motion-hooks t))
1181 (when (and (boundp 'mime::preview/content-list)
1182 mime::preview/content-list)
1183 ;; We have a MIMEish article, so we use the MIME data to narrow.
1184 (let ((pcinfo (car (last mime::preview/content-list))))
1185 (ignore-errors
1186 (narrow-to-region
1187 (funcall (intern "mime::preview-content-info/point-min") pcinfo)
1188 (point-max)))))
1189
1190 (when (gnus-article-search-signature) 1845 (when (gnus-article-search-signature)
1191 (forward-line 1) 1846 (forward-line 1)
1192 ;; Check whether we have some limits to what we consider 1847 ;; Check whether we have some limits to what we consider
@@ -1226,38 +1881,6 @@ Put point at the beginning of the signature separator."
1226 (goto-char cur) 1881 (goto-char cur)
1227 nil))) 1882 nil)))
1228 1883
1229(eval-and-compile
1230 (autoload 'w3-display "w3-parse")
1231 (autoload 'w3-do-setup "w3" "" t)
1232 (autoload 'w3-region "w3-display" "" t))
1233
1234(defun gnus-article-treat-html ()
1235 "Render HTML."
1236 (interactive)
1237 (let ((cbuf (current-buffer)))
1238 (set-buffer gnus-article-buffer)
1239 (let (buf buffer-read-only b e)
1240 (w3-do-setup)
1241 (goto-char (point-min))
1242 (narrow-to-region
1243 (if (search-forward "\n\n" nil t)
1244 (setq b (point))
1245 (point-max))
1246 (setq e (point-max)))
1247 (nnheader-temp-write nil
1248 (insert-buffer-substring gnus-article-buffer b e)
1249 (require 'url)
1250 (save-window-excursion
1251 (w3-region (point-min) (point-max))
1252 (setq buf (buffer-substring-no-properties (point-min) (point-max)))))
1253 (when buf
1254 (delete-region (point-min) (point-max))
1255 (insert buf))
1256 (widen)
1257 (goto-char (point-min))
1258 (set-window-start (get-buffer-window (current-buffer)) (point-min))
1259 (set-buffer cbuf))))
1260
1261(defun gnus-article-hidden-arg () 1884(defun gnus-article-hidden-arg ()
1262 "Return the current prefix arg as a number, or 0 if no prefix." 1885 "Return the current prefix arg as a number, or 0 if no prefix."
1263 (list (if current-prefix-arg 1886 (list (if current-prefix-arg
@@ -1270,7 +1893,6 @@ Arg can be nil or a number. Nil and positive means hide, negative
1270means show, 0 means toggle." 1893means show, 0 means toggle."
1271 (save-excursion 1894 (save-excursion
1272 (save-restriction 1895 (save-restriction
1273 (widen)
1274 (let ((hide (gnus-article-hidden-text-p type))) 1896 (let ((hide (gnus-article-hidden-text-p type)))
1275 (cond 1897 (cond
1276 ((or (null arg) 1898 ((or (null arg)
@@ -1287,12 +1909,13 @@ means show, 0 means toggle."
1287 "Say whether the current buffer contains hidden text of type TYPE." 1909 "Say whether the current buffer contains hidden text of type TYPE."
1288 (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) 1910 (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
1289 (while (and pos 1911 (while (and pos
1290 (not (get-text-property pos 'invisible))) 1912 (not (get-text-property pos 'invisible))
1913 (not (get-text-property pos 'dummy-invisible)))
1291 (setq pos 1914 (setq pos
1292 (text-property-any (1+ pos) (point-max) 'article-type type))) 1915 (text-property-any (1+ pos) (point-max) 'article-type type)))
1293 (if pos 1916 (if pos
1294 'hidden 1917 'hidden
1295 'shown))) 1918 nil)))
1296 1919
1297(defun gnus-article-show-hidden-text (type &optional hide) 1920(defun gnus-article-show-hidden-text (type &optional hide)
1298 "Show all hidden text of type TYPE. 1921 "Show all hidden text of type TYPE.
@@ -1325,144 +1948,158 @@ If HIDE, hide the text instead."
1325(defun article-date-ut (&optional type highlight header) 1948(defun article-date-ut (&optional type highlight header)
1326 "Convert DATE date to universal time in the current article. 1949 "Convert DATE date to universal time in the current article.
1327If TYPE is `local', convert to local time; if it is `lapsed', output 1950If TYPE is `local', convert to local time; if it is `lapsed', output
1328how much time has lapsed since DATE." 1951how much time has lapsed since DATE. For `lapsed', the value of
1952`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
1953should replace the \"Date:\" one, or should be added below it."
1329 (interactive (list 'ut t)) 1954 (interactive (list 'ut t))
1330 (let* ((header (or header 1955 (let* ((header (or header
1331 (mail-header-date gnus-current-headers)
1332 (message-fetch-field "date") 1956 (message-fetch-field "date")
1333 "")) 1957 ""))
1958 (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
1959 (date-regexp
1960 (cond
1961 ((not gnus-article-date-lapsed-new-header)
1962 tdate-regexp)
1963 ((eq type 'lapsed)
1964 "^X-Sent:[ \t]")
1965 (t
1966 "^Date:[ \t]")))
1334 (date (if (vectorp header) (mail-header-date header) 1967 (date (if (vectorp header) (mail-header-date header)
1335 header)) 1968 header))
1336 (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
1337 (inhibit-point-motion-hooks t) 1969 (inhibit-point-motion-hooks t)
1338 bface eface newline) 1970 pos
1339 (when (and date (not (string= date ""))) 1971 bface eface)
1340 (save-excursion 1972 (save-excursion
1341 (save-restriction 1973 (save-restriction
1342 (nnheader-narrow-to-headers) 1974 (article-narrow-to-head)
1975 (when (re-search-forward tdate-regexp nil t)
1976 (setq bface (get-text-property (gnus-point-at-bol) 'face)
1977 date (or (get-text-property (gnus-point-at-bol)
1978 'original-date)
1979 date)
1980 eface (get-text-property (1- (gnus-point-at-eol)) 'face))
1981 (forward-line 1))
1982 (when (and date (not (string= date "")))
1983 (goto-char (point-min))
1343 (let ((buffer-read-only nil)) 1984 (let ((buffer-read-only nil))
1344 ;; Delete any old Date headers. 1985 ;; Delete any old Date headers.
1345 (if (re-search-forward date-regexp nil t) 1986 (while (re-search-forward date-regexp nil t)
1346 (progn 1987 (if pos
1347 (setq bface (get-text-property (gnus-point-at-bol) 'face)
1348 eface (get-text-property (1- (gnus-point-at-eol))
1349 'face))
1350 (delete-region (progn (beginning-of-line) (point)) 1988 (delete-region (progn (beginning-of-line) (point))
1351 (progn (end-of-line) (point))) 1989 (progn (forward-line 1) (point)))
1352 (beginning-of-line)) 1990 (delete-region (progn (beginning-of-line) (point))
1353 (goto-char (point-max)) 1991 (progn (end-of-line) (point)))
1354 (setq newline t)) 1992 (setq pos (point))))
1355 (insert (article-make-date-line date type)) 1993 (when (and (not pos) (re-search-forward tdate-regexp nil t))
1994 (forward-line 1))
1995 (if pos (goto-char pos))
1996 (insert (article-make-date-line date (or type 'ut)))
1997 (when (not pos)
1998 (insert "\n")
1999 (forward-line -1))
1356 ;; Do highlighting. 2000 ;; Do highlighting.
1357 (beginning-of-line) 2001 (beginning-of-line)
1358 (when (looking-at "\\([^:]+\\): *\\(.*\\)$") 2002 (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
1359 (put-text-property (match-beginning 1) (1+ (match-end 1)) 2003 (put-text-property (match-beginning 1) (1+ (match-end 1))
2004 'original-date date)
2005 (put-text-property (match-beginning 1) (1+ (match-end 1))
1360 'face bface) 2006 'face bface)
1361 (put-text-property (match-beginning 2) (match-end 2) 2007 (put-text-property (match-beginning 2) (match-end 2)
1362 'face eface)) 2008 'face eface))))))))
1363 (when newline
1364 (end-of-line)
1365 (insert "\n"))))))))
1366 2009
1367(defun article-make-date-line (date type) 2010(defun article-make-date-line (date type)
1368 "Return a DATE line of TYPE." 2011 "Return a DATE line of TYPE."
1369 (cond 2012 (let ((time (condition-case ()
1370 ;; Convert to the local timezone. We have to slap a 2013 (date-to-time date)
1371 ;; `condition-case' round the calls to the timezone 2014 (error '(0 0)))))
1372 ;; functions since they aren't particularly resistant to 2015 (cond
1373 ;; buggy dates. 2016 ;; Convert to the local timezone. We have to slap a
1374 ((eq type 'local) 2017 ;; `condition-case' round the calls to the timezone
1375 (concat "Date: " (condition-case () 2018 ;; functions since they aren't particularly resistant to
1376 (timezone-make-date-arpa-standard date) 2019 ;; buggy dates.
1377 (error date)))) 2020 ((eq type 'local)
1378 ;; Convert to Universal Time. 2021 (let ((tz (car (current-time-zone time))))
1379 ((eq type 'ut) 2022 (format "Date: %s %s%02d%02d" (current-time-string time)
1380 (concat "Date: " 2023 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
1381 (condition-case () 2024 (/ (% (abs tz) 3600) 60))))
1382 (timezone-make-date-arpa-standard date nil "UT") 2025 ;; Convert to Universal Time.
1383 (error date)))) 2026 ((eq type 'ut)
1384 ;; Get the original date from the article. 2027 (concat "Date: "
1385 ((eq type 'original) 2028 (current-time-string
1386 (concat "Date: " date)) 2029 (let* ((e (parse-time-string date))
1387 ;; Let the user define the format. 2030 (tm (apply 'encode-time e))
1388 ((eq type 'user) 2031 (ms (car tm))
1389 (if (gnus-functionp gnus-article-time-format) 2032 (ls (- (cadr tm) (car (current-time-zone time)))))
1390 (funcall 2033 (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
1391 gnus-article-time-format 2034 ((> ls 65535) (list (1+ ms) (- ls 65536)))
1392 (ignore-errors 2035 (t (list ms ls)))))
1393 (gnus-encode-date 2036 " UT"))
1394 (timezone-make-date-arpa-standard 2037 ;; Get the original date from the article.
1395 date nil "UT")))) 2038 ((eq type 'original)
1396 (concat 2039 (concat "Date: " (if (string-match "\n+$" date)
1397 "Date: " 2040 (substring date 0 (match-beginning 0))
1398 (format-time-string gnus-article-time-format 2041 date)))
1399 (ignore-errors 2042 ;; Let the user define the format.
1400 (gnus-encode-date 2043 ((eq type 'user)
1401 (timezone-make-date-arpa-standard 2044 (if (gnus-functionp gnus-article-time-format)
1402 date nil "UT"))))))) 2045 (funcall gnus-article-time-format time)
1403 ;; ISO 8601.
1404 ((eq type 'iso8601)
1405 (concat
1406 "Date: "
1407 (format-time-string "%Y%M%DT%h%m%s"
1408 (ignore-errors
1409 (gnus-encode-date
1410 (timezone-make-date-arpa-standard
1411 date nil "UT"))))))
1412 ;; Do an X-Sent lapsed format.
1413 ((eq type 'lapsed)
1414 ;; If the date is seriously mangled, the timezone functions are
1415 ;; liable to bug out, so we ignore all errors.
1416 (let* ((now (current-time))
1417 (real-time
1418 (ignore-errors
1419 (gnus-time-minus
1420 (gnus-encode-date
1421 (timezone-make-date-arpa-standard
1422 (current-time-string now)
1423 (current-time-zone now) "UT"))
1424 (gnus-encode-date
1425 (timezone-make-date-arpa-standard
1426 date nil "UT")))))
1427 (real-sec (and real-time
1428 (+ (* (float (car real-time)) 65536)
1429 (cadr real-time))))
1430 (sec (and real-time (abs real-sec)))
1431 num prev)
1432 (cond
1433 ((null real-time)
1434 "X-Sent: Unknown")
1435 ((zerop sec)
1436 "X-Sent: Now")
1437 (t
1438 (concat 2046 (concat
1439 "X-Sent: " 2047 "Date: "
1440 ;; This is a bit convoluted, but basically we go 2048 (format-time-string gnus-article-time-format time))))
1441 ;; through the time units for years, weeks, etc, 2049 ;; ISO 8601.
1442 ;; and divide things to see whether that results 2050 ((eq type 'iso8601)
1443 ;; in positive answers. 2051 (let ((tz (car (current-time-zone time))))
1444 (mapconcat 2052 (concat
1445 (lambda (unit) 2053 "Date: "
1446 (if (zerop (setq num (ffloor (/ sec (cdr unit))))) 2054 (format-time-string "%Y%m%dT%H%M%S" time)
1447 ;; The (remaining) seconds are too few to 2055 (format "%s%02d%02d"
1448 ;; be divided into this time unit. 2056 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
1449 "" 2057 (/ (% (abs tz) 3600) 60)))))
1450 ;; It's big enough, so we output it. 2058 ;; Do an X-Sent lapsed format.
1451 (setq sec (- sec (* num (cdr unit)))) 2059 ((eq type 'lapsed)
1452 (prog1 2060 ;; If the date is seriously mangled, the timezone functions are
1453 (concat (if prev ", " "") (int-to-string 2061 ;; liable to bug out, so we ignore all errors.
1454 (floor num)) 2062 (let* ((now (current-time))
1455 " " (symbol-name (car unit)) 2063 (real-time (subtract-time now time))
1456 (if (> num 1) "s" "")) 2064 (real-sec (and real-time
1457 (setq prev t)))) 2065 (+ (* (float (car real-time)) 65536)
1458 article-time-units "") 2066 (cadr real-time))))
1459 ;; If dates are odd, then it might appear like the 2067 (sec (and real-time (abs real-sec)))
1460 ;; article was sent in the future. 2068 num prev)
1461 (if (> real-sec 0) 2069 (cond
1462 " ago" 2070 ((null real-time)
1463 " in the future")))))) 2071 "X-Sent: Unknown")
1464 (t 2072 ((zerop sec)
1465 (error "Unknown conversion type: %s" type)))) 2073 "X-Sent: Now")
2074 (t
2075 (concat
2076 "X-Sent: "
2077 ;; This is a bit convoluted, but basically we go
2078 ;; through the time units for years, weeks, etc,
2079 ;; and divide things to see whether that results
2080 ;; in positive answers.
2081 (mapconcat
2082 (lambda (unit)
2083 (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2084 ;; The (remaining) seconds are too few to
2085 ;; be divided into this time unit.
2086 ""
2087 ;; It's big enough, so we output it.
2088 (setq sec (- sec (* num (cdr unit))))
2089 (prog1
2090 (concat (if prev ", " "") (int-to-string
2091 (floor num))
2092 " " (symbol-name (car unit))
2093 (if (> num 1) "s" ""))
2094 (setq prev t))))
2095 article-time-units "")
2096 ;; If dates are odd, then it might appear like the
2097 ;; article was sent in the future.
2098 (if (> real-sec 0)
2099 " ago"
2100 " in the future"))))))
2101 (t
2102 (error "Unknown conversion type: %s" type)))))
1466 2103
1467(defun article-date-local (&optional highlight) 2104(defun article-date-local (&optional highlight)
1468 "Convert the current article date to the local timezone." 2105 "Convert the current article date to the local timezone."
@@ -1486,11 +2123,14 @@ function and want to see what the date was before converting."
1486 (let (deactivate-mark) 2123 (let (deactivate-mark)
1487 (save-excursion 2124 (save-excursion
1488 (ignore-errors 2125 (ignore-errors
1489 (when (gnus-buffer-live-p gnus-article-buffer) 2126 (walk-windows
1490 (set-buffer gnus-article-buffer) 2127 (lambda (w)
1491 (goto-char (point-min)) 2128 (set-buffer (window-buffer w))
1492 (when (re-search-forward "^X-Sent:" nil t) 2129 (when (eq major-mode 'gnus-article-mode)
1493 (article-date-lapsed t))))))) 2130 (goto-char (point-min))
2131 (when (re-search-forward "^X-Sent:" nil t)
2132 (article-date-lapsed t))))
2133 nil 'visible)))))
1494 2134
1495(defun gnus-start-date-timer (&optional n) 2135(defun gnus-start-date-timer (&optional n)
1496 "Start a timer to update the X-Sent header in the article buffers. 2136 "Start a timer to update the X-Sent header in the article buffers.
@@ -1533,13 +2173,17 @@ This format is defined by the `gnus-article-time-format' variable."
1533 (interactive (gnus-article-hidden-arg)) 2173 (interactive (gnus-article-hidden-arg))
1534 (unless (gnus-article-check-hidden-text 'emphasis arg) 2174 (unless (gnus-article-check-hidden-text 'emphasis arg)
1535 (save-excursion 2175 (save-excursion
1536 (let ((alist gnus-emphasis-alist) 2176 (let ((alist (or
2177 (condition-case nil
2178 (with-current-buffer gnus-summary-buffer
2179 gnus-article-emphasis-alist)
2180 (error))
2181 gnus-emphasis-alist))
1537 (buffer-read-only nil) 2182 (buffer-read-only nil)
1538 (props (append '(article-type emphasis) 2183 (props (append '(article-type emphasis)
1539 gnus-hidden-properties)) 2184 gnus-hidden-properties))
1540 regexp elem beg invisible visible face) 2185 regexp elem beg invisible visible face)
1541 (goto-char (point-min)) 2186 (article-goto-body)
1542 (search-forward "\n\n" nil t)
1543 (setq beg (point)) 2187 (setq beg (point))
1544 (while (setq elem (pop alist)) 2188 (while (setq elem (pop alist))
1545 (goto-char beg) 2189 (goto-char beg)
@@ -1549,6 +2193,7 @@ This format is defined by the `gnus-article-time-format' variable."
1549 face (nth 3 elem)) 2193 face (nth 3 elem))
1550 (while (re-search-forward regexp nil t) 2194 (while (re-search-forward regexp nil t)
1551 (when (and (match-beginning visible) (match-beginning invisible)) 2195 (when (and (match-beginning visible) (match-beginning invisible))
2196 (push 'emphasis gnus-article-wash-types)
1552 (gnus-article-hide-text 2197 (gnus-article-hide-text
1553 (match-beginning invisible) (match-end invisible) props) 2198 (match-beginning invisible) (match-end invisible) props)
1554 (gnus-article-unhide-text-type 2199 (gnus-article-unhide-text-type
@@ -1557,6 +2202,26 @@ This format is defined by the `gnus-article-time-format' variable."
1557 (match-beginning visible) (match-end visible) 'face face) 2202 (match-beginning visible) (match-end visible) 'face face)
1558 (goto-char (match-end invisible))))))))) 2203 (goto-char (match-end invisible)))))))))
1559 2204
2205(defun gnus-article-setup-highlight-words (&optional highlight-words)
2206 "Setup newsgroup emphasis alist."
2207 (unless gnus-article-emphasis-alist
2208 (let ((name (and gnus-newsgroup-name
2209 (gnus-group-real-name gnus-newsgroup-name))))
2210 (make-local-variable 'gnus-article-emphasis-alist)
2211 (setq gnus-article-emphasis-alist
2212 (nconc
2213 (let ((alist gnus-group-highlight-words-alist) elem highlight)
2214 (while (setq elem (pop alist))
2215 (when (and name (string-match (car elem) name))
2216 (setq alist nil
2217 highlight (copy-sequence (cdr elem)))))
2218 highlight)
2219 (copy-sequence highlight-words)
2220 (if gnus-newsgroup-name
2221 (copy-sequence (gnus-group-find-parameter
2222 gnus-newsgroup-name 'highlight-words t)))
2223 gnus-emphasis-alist)))))
2224
1560(defvar gnus-summary-article-menu) 2225(defvar gnus-summary-article-menu)
1561(defvar gnus-summary-post-menu) 2226(defvar gnus-summary-post-menu)
1562 2227
@@ -1576,7 +2241,7 @@ This format is defined by the `gnus-article-time-format' variable."
1576 (if (not gnus-default-article-saver) 2241 (if (not gnus-default-article-saver)
1577 (error "No default saver is defined") 2242 (error "No default saver is defined")
1578 ;; !!! Magic! The saving functions all save 2243 ;; !!! Magic! The saving functions all save
1579 ;; `gnus-original-article-buffer' (or so they think), but we 2244 ;; `gnus-save-article-buffer' (or so they think), but we
1580 ;; bind that variable to our save-buffer. 2245 ;; bind that variable to our save-buffer.
1581 (set-buffer gnus-article-buffer) 2246 (set-buffer gnus-article-buffer)
1582 (let* ((gnus-save-article-buffer save-buffer) 2247 (let* ((gnus-save-article-buffer save-buffer)
@@ -1662,8 +2327,8 @@ This format is defined by the `gnus-article-time-format' variable."
1662 (gnus-make-directory (file-name-directory file)) 2327 (gnus-make-directory (file-name-directory file))
1663 ;; If we have read a directory, we append the default file name. 2328 ;; If we have read a directory, we append the default file name.
1664 (when (file-directory-p file) 2329 (when (file-directory-p file)
1665 (setq file (concat (file-name-as-directory file) 2330 (setq file (expand-file-name (file-name-nondirectory default-name)
1666 (file-name-nondirectory default-name)))) 2331 (file-name-as-directory file))))
1667 ;; Possibly translate some characters. 2332 ;; Possibly translate some characters.
1668 (nnheader-translate-file-chars file))))) 2333 (nnheader-translate-file-chars file)))))
1669 (gnus-make-directory (file-name-directory result)) 2334 (gnus-make-directory (file-name-directory result))
@@ -1710,7 +2375,7 @@ Directory to save to is default to `gnus-article-save-directory'."
1710 (widen) 2375 (widen)
1711 (if (and (file-readable-p filename) 2376 (if (and (file-readable-p filename)
1712 (mail-file-babyl-p filename)) 2377 (mail-file-babyl-p filename))
1713 (gnus-output-to-rmail filename t) 2378 (rmail-output-to-rmail-file filename t)
1714 (gnus-output-to-mail filename))))) 2379 (gnus-output-to-mail filename)))))
1715 filename) 2380 filename)
1716 2381
@@ -1750,8 +2415,7 @@ The directory to save in defaults to `gnus-article-save-directory'."
1750 (save-excursion 2415 (save-excursion
1751 (save-restriction 2416 (save-restriction
1752 (widen) 2417 (widen)
1753 (goto-char (point-min)) 2418 (when (article-goto-body)
1754 (when (search-forward "\n\n" nil t)
1755 (narrow-to-region (point) (point-max))) 2419 (narrow-to-region (point) (point-max)))
1756 (gnus-output-to-file filename)))) 2420 (gnus-output-to-file filename))))
1757 filename) 2421 filename)
@@ -1759,7 +2423,8 @@ The directory to save in defaults to `gnus-article-save-directory'."
1759(defun gnus-summary-save-in-pipe (&optional command) 2423(defun gnus-summary-save-in-pipe (&optional command)
1760 "Pipe this article to subprocess." 2424 "Pipe this article to subprocess."
1761 (setq command 2425 (setq command
1762 (cond ((eq command 'default) 2426 (cond ((and (eq command 'default)
2427 gnus-last-shell-command)
1763 gnus-last-shell-command) 2428 gnus-last-shell-command)
1764 (command command) 2429 (command command)
1765 (t (read-string 2430 (t (read-string
@@ -1823,17 +2488,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1823 default 2488 default
1824 (or last-file default)))) 2489 (or last-file default))))
1825 2490
1826(defun gnus-Plain-save-name (newsgroup headers &optional last-file)
1827 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
1828If variable `gnus-use-long-file-name' is non-nil, it is
1829~/News/News.group. Otherwise, it is like ~/News/news/group/news."
1830 (or last-file
1831 (expand-file-name
1832 (if (gnus-use-long-file-name 'not-save)
1833 (gnus-capitalize-newsgroup newsgroup)
1834 (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
1835 gnus-article-save-directory)))
1836
1837(defun gnus-plain-save-name (newsgroup headers &optional last-file) 2491(defun gnus-plain-save-name (newsgroup headers &optional last-file)
1838 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. 2492 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
1839If variable `gnus-use-long-file-name' is non-nil, it is 2493If variable `gnus-use-long-file-name' is non-nil, it is
@@ -1842,7 +2496,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1842 (expand-file-name 2496 (expand-file-name
1843 (if (gnus-use-long-file-name 'not-save) 2497 (if (gnus-use-long-file-name 'not-save)
1844 newsgroup 2498 newsgroup
1845 (concat (gnus-newsgroup-directory-form newsgroup) "/news")) 2499 (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))
1846 gnus-article-save-directory))) 2500 gnus-article-save-directory)))
1847 2501
1848(eval-and-compile 2502(eval-and-compile
@@ -1854,42 +2508,53 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1854 gfunc (cdr func)) 2508 gfunc (cdr func))
1855 (setq afunc func 2509 (setq afunc func
1856 gfunc (intern (format "gnus-%s" func)))) 2510 gfunc (intern (format "gnus-%s" func))))
1857 (fset gfunc 2511 (defalias gfunc
1858 (if (not (fboundp afunc)) 2512 (if (fboundp afunc)
1859 nil 2513 `(lambda (&optional interactive &rest args)
1860 `(lambda (&optional interactive &rest args) 2514 ,(documentation afunc t)
1861 ,(documentation afunc t) 2515 (interactive (list t))
1862 (interactive (list t)) 2516 (save-excursion
1863 (save-excursion 2517 (set-buffer gnus-article-buffer)
1864 (set-buffer gnus-article-buffer) 2518 (if interactive
1865 (if interactive 2519 (call-interactively ',afunc)
1866 (call-interactively ',afunc) 2520 (apply ',afunc args))))))))
1867 (apply ',afunc args))))))))
1868 '(article-hide-headers 2521 '(article-hide-headers
1869 article-hide-boring-headers 2522 article-hide-boring-headers
1870 article-treat-overstrike 2523 article-treat-overstrike
1871 (article-fill . gnus-article-word-wrap) 2524 article-fill-long-lines
2525 article-capitalize-sentences
1872 article-remove-cr 2526 article-remove-cr
1873 article-display-x-face 2527 article-display-x-face
1874 article-de-quoted-unreadable 2528 article-de-quoted-unreadable
1875 article-mime-decode-quoted-printable 2529 article-de-base64-unreadable
2530 article-decode-HZ
2531 article-wash-html
2532 article-hide-list-identifiers
1876 article-hide-pgp 2533 article-hide-pgp
2534 article-strip-banner
2535 article-babel
1877 article-hide-pem 2536 article-hide-pem
1878 article-hide-signature 2537 article-hide-signature
2538 article-strip-headers-in-body
1879 article-remove-trailing-blank-lines 2539 article-remove-trailing-blank-lines
1880 article-strip-leading-blank-lines 2540 article-strip-leading-blank-lines
1881 article-strip-multiple-blank-lines 2541 article-strip-multiple-blank-lines
1882 article-strip-leading-space 2542 article-strip-leading-space
2543 article-strip-trailing-space
1883 article-strip-blank-lines 2544 article-strip-blank-lines
1884 article-strip-all-blank-lines 2545 article-strip-all-blank-lines
1885 article-date-local 2546 article-date-local
1886 article-date-iso8601 2547 article-date-iso8601
1887 article-date-original 2548 article-date-original
1888 article-date-ut 2549 article-date-ut
2550 article-decode-mime-words
2551 article-decode-charset
2552 article-decode-encoded-words
1889 article-date-user 2553 article-date-user
1890 article-date-lapsed 2554 article-date-lapsed
1891 article-emphasize 2555 article-emphasize
1892 article-treat-dumbquotes 2556 article-treat-dumbquotes
2557 article-normalize-headers
1893 (article-show-all . gnus-article-show-all-headers)))) 2558 (article-show-all . gnus-article-show-all-headers))))
1894 2559
1895;;; 2560;;;
@@ -1898,20 +2563,19 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1898 2563
1899(put 'gnus-article-mode 'mode-class 'special) 2564(put 'gnus-article-mode 'mode-class 'special)
1900 2565
2566(set-keymap-parent gnus-article-mode-map widget-keymap)
2567
1901(gnus-define-keys gnus-article-mode-map 2568(gnus-define-keys gnus-article-mode-map
1902 " " gnus-article-goto-next-page 2569 " " gnus-article-goto-next-page
1903 "\177" gnus-article-goto-prev-page 2570 "\177" gnus-article-goto-prev-page
1904 [delete] gnus-article-goto-prev-page 2571 [delete] gnus-article-goto-prev-page
2572 [backspace] gnus-article-goto-prev-page
1905 "\C-c^" gnus-article-refer-article 2573 "\C-c^" gnus-article-refer-article
1906 "h" gnus-article-show-summary 2574 "h" gnus-article-show-summary
1907 "s" gnus-article-show-summary 2575 "s" gnus-article-show-summary
1908 "\C-c\C-m" gnus-article-mail 2576 "\C-c\C-m" gnus-article-mail
1909 "?" gnus-article-describe-briefly 2577 "?" gnus-article-describe-briefly
1910 gnus-mouse-2 gnus-article-push-button 2578 "e" gnus-summary-edit-article
1911 "\r" gnus-article-press-button
1912 "\t" gnus-article-next-button
1913 "\M-\t" gnus-article-prev-button
1914 "e" gnus-article-edit
1915 "<" beginning-of-buffer 2579 "<" beginning-of-buffer
1916 ">" end-of-buffer 2580 ">" end-of-buffer
1917 "\C-c\C-i" gnus-info-find-node 2581 "\C-c\C-i" gnus-info-find-node
@@ -1947,7 +2611,10 @@ If variable `gnus-use-long-file-name' is non-nil, it is
1947 ["Hide citation" gnus-article-hide-citation t] 2611 ["Hide citation" gnus-article-hide-citation t]
1948 ["Treat overstrike" gnus-article-treat-overstrike t] 2612 ["Treat overstrike" gnus-article-treat-overstrike t]
1949 ["Remove carriage return" gnus-article-remove-cr t] 2613 ["Remove carriage return" gnus-article-remove-cr t]
1950 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) 2614 ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
2615 ["Remove base64" gnus-article-de-base64-unreadable t]
2616 ["Treat html" gnus-article-wash-html t]
2617 ["Decode HZ" gnus-article-decode-HZ t]))
1951 2618
1952 ;; Note "Commands" menu is defined in gnus-sum.el for consistency 2619 ;; Note "Commands" menu is defined in gnus-sum.el for consistency
1953 2620
@@ -1979,18 +2646,21 @@ commands:
1979 (setq mode-name "Article") 2646 (setq mode-name "Article")
1980 (setq major-mode 'gnus-article-mode) 2647 (setq major-mode 'gnus-article-mode)
1981 (make-local-variable 'minor-mode-alist) 2648 (make-local-variable 'minor-mode-alist)
1982 (unless (assq 'gnus-show-mime minor-mode-alist)
1983 (push (list 'gnus-show-mime " MIME") minor-mode-alist))
1984 (use-local-map gnus-article-mode-map) 2649 (use-local-map gnus-article-mode-map)
1985 (gnus-update-format-specifications nil 'article-mode) 2650 (gnus-update-format-specifications nil 'article-mode)
1986 (set (make-local-variable 'page-delimiter) gnus-page-delimiter) 2651 (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
1987 (make-local-variable 'gnus-page-broken) 2652 (make-local-variable 'gnus-page-broken)
1988 (make-local-variable 'gnus-button-marker-list) 2653 (make-local-variable 'gnus-button-marker-list)
1989 (make-local-variable 'gnus-article-current-summary) 2654 (make-local-variable 'gnus-article-current-summary)
2655 (make-local-variable 'gnus-article-mime-handles)
2656 (make-local-variable 'gnus-article-decoded-p)
2657 (make-local-variable 'gnus-article-mime-handle-alist)
2658 (make-local-variable 'gnus-article-wash-types)
1990 (gnus-set-default-directory) 2659 (gnus-set-default-directory)
1991 (buffer-disable-undo (current-buffer)) 2660 (buffer-disable-undo)
1992 (setq buffer-read-only t) 2661 (setq buffer-read-only t)
1993 (set-syntax-table gnus-article-mode-syntax-table) 2662 (set-syntax-table gnus-article-mode-syntax-table)
2663 (mm-enable-multibyte)
1994 (gnus-run-hooks 'gnus-article-mode-hook)) 2664 (gnus-run-hooks 'gnus-article-mode-hook))
1995 2665
1996(defun gnus-article-setup-buffer () 2666(defun gnus-article-setup-buffer ()
@@ -2003,6 +2673,7 @@ commands:
2003 (substring name (match-end 0)))))) 2673 (substring name (match-end 0))))))
2004 (setq gnus-article-buffer name) 2674 (setq gnus-article-buffer name)
2005 (setq gnus-original-article-buffer original) 2675 (setq gnus-original-article-buffer original)
2676 (setq gnus-article-mime-handle-alist nil)
2006 ;; This might be a variable local to the summary buffer. 2677 ;; This might be a variable local to the summary buffer.
2007 (unless gnus-single-article-buffer 2678 (unless gnus-single-article-buffer
2008 (save-excursion 2679 (save-excursion
@@ -2010,16 +2681,22 @@ commands:
2010 (setq gnus-article-buffer name) 2681 (setq gnus-article-buffer name)
2011 (setq gnus-original-article-buffer original) 2682 (setq gnus-original-article-buffer original)
2012 (gnus-set-global-variables))) 2683 (gnus-set-global-variables)))
2684 (gnus-article-setup-highlight-words)
2013 ;; Init original article buffer. 2685 ;; Init original article buffer.
2014 (save-excursion 2686 (save-excursion
2015 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) 2687 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
2016 (buffer-disable-undo (current-buffer)) 2688 (mm-enable-multibyte)
2017 (setq major-mode 'gnus-original-article-mode) 2689 (setq major-mode 'gnus-original-article-mode)
2018 (make-local-variable 'gnus-original-article)) 2690 (make-local-variable 'gnus-original-article))
2019 (if (get-buffer name) 2691 (if (get-buffer name)
2020 (save-excursion 2692 (save-excursion
2021 (set-buffer name) 2693 (set-buffer name)
2022 (buffer-disable-undo (current-buffer)) 2694 (when gnus-article-mime-handles
2695 (mm-destroy-parts gnus-article-mime-handles)
2696 (setq gnus-article-mime-handles nil))
2697 ;; Set it to nil in article-buffer!
2698 (setq gnus-article-mime-handle-alist nil)
2699 (buffer-disable-undo)
2023 (setq buffer-read-only t) 2700 (setq buffer-read-only t)
2024 (unless (eq major-mode 'gnus-article-mode) 2701 (unless (eq major-mode 'gnus-article-mode)
2025 (gnus-article-mode)) 2702 (gnus-article-mode))
@@ -2028,6 +2705,7 @@ commands:
2028 (set-buffer (gnus-get-buffer-create name)) 2705 (set-buffer (gnus-get-buffer-create name))
2029 (gnus-article-mode) 2706 (gnus-article-mode)
2030 (make-local-variable 'gnus-summary-buffer) 2707 (make-local-variable 'gnus-summary-buffer)
2708 (gnus-summary-set-local-parameters gnus-newsgroup-name)
2031 (current-buffer))))) 2709 (current-buffer)))))
2032 2710
2033;; Set article window start at LINE, where LINE is the number of lines 2711;; Set article window start at LINE, where LINE is the number of lines
@@ -2084,8 +2762,7 @@ If ALL-HEADERS is non-nil, no headers are hidden."
2084 (message "Message marked for downloading")) 2762 (message "Message marked for downloading"))
2085 (gnus-summary-mark-article article gnus-canceled-mark) 2763 (gnus-summary-mark-article article gnus-canceled-mark)
2086 (unless (memq article gnus-newsgroup-sparse) 2764 (unless (memq article gnus-newsgroup-sparse)
2087 (gnus-error 1 2765 (gnus-error 1 "No such article (may have expired or been canceled)")))))
2088 "No such article (may have expired or been canceled)")))))
2089 (if (or (eq result 'pseudo) 2766 (if (or (eq result 'pseudo)
2090 (eq result 'nneething)) 2767 (eq result 'nneething))
2091 (progn 2768 (progn
@@ -2100,7 +2777,9 @@ If ALL-HEADERS is non-nil, no headers are hidden."
2100 (gnus-configure-windows 'summary) 2777 (gnus-configure-windows 'summary)
2101 (gnus-configure-windows 'article)) 2778 (gnus-configure-windows 'article))
2102 (gnus-set-global-variables)) 2779 (gnus-set-global-variables))
2103 (gnus-set-mode-line 'article)) 2780 (let ((gnus-article-mime-handle-alist-1
2781 gnus-article-mime-handle-alist))
2782 (gnus-set-mode-line 'article)))
2104 ;; The result from the `request' was an actual article - 2783 ;; The result from the `request' was an actual article -
2105 ;; or at least some text that is now displayed in the 2784 ;; or at least some text that is now displayed in the
2106 ;; article buffer. 2785 ;; article buffer.
@@ -2131,85 +2810,723 @@ If ALL-HEADERS is non-nil, no headers are hidden."
2131 (when (gnus-visual-p 'article-highlight 'highlight) 2810 (when (gnus-visual-p 'article-highlight 'highlight)
2132 (gnus-run-hooks 'gnus-visual-mark-article-hook)) 2811 (gnus-run-hooks 'gnus-visual-mark-article-hook))
2133 ;; Set the global newsgroup variables here. 2812 ;; Set the global newsgroup variables here.
2134 ;; Suggested by Jim Sisolak
2135 ;; <sisolak@trans4.neep.wisc.edu>.
2136 (gnus-set-global-variables) 2813 (gnus-set-global-variables)
2137 (setq gnus-have-all-headers 2814 (setq gnus-have-all-headers
2138 (or all-headers gnus-show-all-headers)))) 2815 (or all-headers gnus-show-all-headers))))
2139 (when (or (numberp article) 2816 (when (or (numberp article)
2140 (stringp article)) 2817 (stringp article))
2141 ;; Hooks for getting information from the article. 2818 (gnus-article-prepare-display)
2142 ;; This hook must be called before being narrowed.
2143 (let (buffer-read-only)
2144 (gnus-run-hooks 'gnus-tmp-internal-hook)
2145 (gnus-run-hooks 'gnus-article-prepare-hook)
2146 ;; Decode MIME message.
2147 (if gnus-show-mime
2148 (if (or (not gnus-strict-mime)
2149 (gnus-fetch-field "Mime-Version"))
2150 (let ((coding-system-for-write 'binary)
2151 (coding-system-for-read 'binary))
2152 (funcall gnus-show-mime-method))
2153 (funcall gnus-decode-encoded-word-method))
2154 (funcall gnus-show-traditional-method))
2155 ;; Perform the article display hooks.
2156 (gnus-run-hooks 'gnus-article-display-hook))
2157 ;; Do page break. 2819 ;; Do page break.
2158 (goto-char (point-min)) 2820 (goto-char (point-min))
2159 (setq gnus-page-broken 2821 (setq gnus-page-broken
2160 (when gnus-break-pages 2822 (when gnus-break-pages
2161 (gnus-narrow-to-page) 2823 (gnus-narrow-to-page)
2162 t))) 2824 t)))
2163 (gnus-set-mode-line 'article) 2825 (let ((gnus-article-mime-handle-alist-1
2164 (gnus-configure-windows 'article) 2826 gnus-article-mime-handle-alist))
2165 (goto-char (point-min)) 2827 (gnus-set-mode-line 'article))
2166 (search-forward "\n\n" nil t) 2828 (article-goto-body)
2167 (set-window-point (get-buffer-window (current-buffer)) (point)) 2829 (set-window-point (get-buffer-window (current-buffer)) (point))
2830 (gnus-configure-windows 'article)
2168 t)))))) 2831 t))))))
2169 2832
2833;;;###autoload
2834(defun gnus-article-prepare-display ()
2835 "Make the current buffer look like a nice article."
2836 ;; Hooks for getting information from the article.
2837 ;; This hook must be called before being narrowed.
2838 (let ((gnus-article-buffer (current-buffer))
2839 buffer-read-only)
2840 (unless (eq major-mode 'gnus-article-mode)
2841 (gnus-article-mode))
2842 (setq buffer-read-only nil
2843 gnus-article-wash-types nil)
2844 (gnus-run-hooks 'gnus-tmp-internal-hook)
2845 (when gnus-display-mime-function
2846 (funcall gnus-display-mime-function))
2847 (gnus-run-hooks 'gnus-article-prepare-hook)))
2848
2849;;;
2850;;; Gnus MIME viewing functions
2851;;;
2852
2853(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
2854 "The following specs can be used:
2855%t The MIME type
2856%T MIME type, along with additional info
2857%n The `name' parameter
2858%d The description, if any
2859%l The length of the encoded part
2860%p The part identifier number
2861%e Dots if the part isn't displayed")
2862
2863(defvar gnus-mime-button-line-format-alist
2864 '((?t gnus-tmp-type ?s)
2865 (?T gnus-tmp-type-long ?s)
2866 (?n gnus-tmp-name ?s)
2867 (?d gnus-tmp-description ?s)
2868 (?p gnus-tmp-id ?s)
2869 (?l gnus-tmp-length ?d)
2870 (?e gnus-tmp-dots ?s)))
2871
2872(defvar gnus-mime-button-commands
2873 '((gnus-article-press-button "\r" "Toggle Display")
2874 (gnus-mime-view-part "v" "View Interactively...")
2875 (gnus-mime-view-part-as-type "t" "View As Type...")
2876 (gnus-mime-save-part "o" "Save...")
2877 (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
2878 (gnus-mime-inline-part "i" "View As Text, In This Buffer")
2879 (gnus-mime-internalize-part "E" "View Internally")
2880 (gnus-mime-externalize-part "e" "View Externally")
2881 (gnus-mime-pipe-part "|" "Pipe To Command...")))
2882
2883(defun gnus-article-mime-part-status ()
2884 (if gnus-article-mime-handle-alist-1
2885 (format " (%d parts)" (length gnus-article-mime-handle-alist-1))
2886 ""))
2887
2888(defvar gnus-mime-button-map
2889 (let ((map (make-sparse-keymap)))
2890 (set-keymap-parent map gnus-article-mode-map)
2891 (define-key map gnus-mouse-2 'gnus-article-push-button)
2892 (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
2893 (dolist (c gnus-mime-button-commands)
2894 (define-key map (cadr c) (car c)))
2895 map))
2896
2897(defun gnus-mime-button-menu (event)
2898 "Construct a context-sensitive menu of MIME commands."
2899 (interactive "e")
2900 (save-excursion
2901 (let ((pos (event-start event)))
2902 (set-buffer (window-buffer (posn-window pos)))
2903 (goto-char (posn-point pos))
2904 (gnus-article-check-buffer)
2905 (let ((response (x-popup-menu
2906 t `("MIME Part"
2907 ("" ,@(mapcar (lambda (c)
2908 (cons (caddr c) (car c)))
2909 gnus-mime-button-commands))))))
2910 (if response
2911 (call-interactively response))))))
2912
2913(defun gnus-mime-view-all-parts (&optional handles)
2914 "View all the MIME parts."
2915 (interactive)
2916 (save-current-buffer
2917 (set-buffer gnus-article-buffer)
2918 (let ((handles (or handles gnus-article-mime-handles))
2919 (mail-parse-charset gnus-newsgroup-charset)
2920 (mail-parse-ignored-charsets
2921 (save-excursion (set-buffer gnus-summary-buffer)
2922 gnus-newsgroup-ignored-charsets)))
2923 (if (stringp (car handles))
2924 (gnus-mime-view-all-parts (cdr handles))
2925 (mapcar 'mm-display-part handles)))))
2926
2927(defun gnus-mime-save-part ()
2928 "Save the MIME part under point."
2929 (interactive)
2930 (gnus-article-check-buffer)
2931 (let ((data (get-text-property (point) 'gnus-data)))
2932 (mm-save-part data)))
2933
2934(defun gnus-mime-pipe-part ()
2935 "Pipe the MIME part under point to a process."
2936 (interactive)
2937 (gnus-article-check-buffer)
2938 (let ((data (get-text-property (point) 'gnus-data)))
2939 (mm-pipe-part data)))
2940
2941(defun gnus-mime-view-part ()
2942 "Interactively choose a viewing method for the MIME part under point."
2943 (interactive)
2944 (gnus-article-check-buffer)
2945 (let ((data (get-text-property (point) 'gnus-data)))
2946 (mm-interactively-view-part data)))
2947
2948(defun gnus-mime-view-part-as-type-internal ()
2949 (gnus-article-check-buffer)
2950 (let* ((name (mail-content-type-get
2951 (mm-handle-type (get-text-property (point) 'gnus-data))
2952 'name))
2953 (def-type (and name (mm-default-file-encoding name))))
2954 (and def-type (cons def-type 0))))
2955
2956(defun gnus-mime-view-part-as-type (mime-type)
2957 "Choose a MIME media type, and view the part as such."
2958 (interactive
2959 (list (completing-read
2960 "View as MIME type: "
2961 (mapcar #'list (mailcap-mime-types))
2962 nil nil
2963 (gnus-mime-view-part-as-type-internal))))
2964 (gnus-article-check-buffer)
2965 (let ((handle (get-text-property (point) 'gnus-data)))
2966 (gnus-mm-display-part
2967 (mm-make-handle (mm-handle-buffer handle)
2968 (cons mime-type (cdr (mm-handle-type handle)))
2969 (mm-handle-encoding handle)
2970 (mm-handle-undisplayer handle)
2971 (mm-handle-disposition handle)
2972 (mm-handle-description handle)
2973 (mm-handle-cache handle)
2974 (mm-handle-id handle)))))
2975
2976(defun gnus-mime-copy-part (&optional handle)
2977 "Put the the MIME part under point into a new buffer."
2978 (interactive)
2979 (gnus-article-check-buffer)
2980 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2981 (contents (mm-get-part handle))|
2982 (base (file-name-nondirectory
2983 (or
2984 (mail-content-type-get (mm-handle-type handle) 'name)
2985 (mail-content-type-get (mm-handle-type handle)
2986 'filename)
2987 "*decoded*")))
2988 (buffer (generate-new-buffer base)))
2989 (switch-to-buffer buffer)
2990 (insert contents)
2991 ;; We do it this way to make `normal-mode' set the appropriate mode.
2992 (unwind-protect
2993 (progn
2994 (setq buffer-file-name (expand-file-name base))
2995 (normal-mode))
2996 (setq buffer-file-name nil))
2997 (goto-char (point-min))))
2998
2999(defun gnus-mime-inline-part (&optional handle)
3000 "Insert the MIME part under point into the current buffer."
3001 (interactive)
3002 (gnus-article-check-buffer)
3003 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3004 contents
3005 (b (point))
3006 buffer-read-only)
3007 (if (mm-handle-undisplayer handle)
3008 (mm-remove-part handle)
3009 (setq contents (mm-get-part handle))
3010 (forward-line 2)
3011 (mm-insert-inline handle contents)
3012 (goto-char b))))
3013
3014(defun gnus-mime-externalize-part (&optional handle)
3015 "View the MIME part under point with an external viewer."
3016 (interactive)
3017 (gnus-article-check-buffer)
3018 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3019 (mm-user-display-methods nil)
3020 (mm-inlined-types nil)
3021 (mail-parse-charset gnus-newsgroup-charset)
3022 (mail-parse-ignored-charsets
3023 (save-excursion (set-buffer gnus-summary-buffer)
3024 gnus-newsgroup-ignored-charsets)))
3025 (if (mm-handle-undisplayer handle)
3026 (mm-remove-part handle)
3027 (mm-display-part handle))))
3028
3029(defun gnus-mime-internalize-part (&optional handle)
3030 "View the MIME part under point with an internal viewer.
3031In no internal viewer is available, use an external viewer."
3032 (interactive)
3033 (gnus-article-check-buffer)
3034 (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3035 (mm-inlined-types '(".*"))
3036 (mm-inline-large-images t)
3037 (mail-parse-charset gnus-newsgroup-charset)
3038 (mail-parse-ignored-charsets
3039 (save-excursion (set-buffer gnus-summary-buffer)
3040 gnus-newsgroup-ignored-charsets)))
3041 (if (mm-handle-undisplayer handle)
3042 (mm-remove-part handle)
3043 (mm-display-part handle))))
3044
3045(defun gnus-article-part-wrapper (n function)
3046 (save-current-buffer
3047 (set-buffer gnus-article-buffer)
3048 (when (> n (length gnus-article-mime-handle-alist))
3049 (error "No such part"))
3050 (gnus-article-goto-part n)
3051 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3052 (funcall function handle))))
3053
3054(defun gnus-article-pipe-part (n)
3055 "Pipe MIME part N, which is the numerical prefix."
3056 (interactive "p")
3057 (gnus-article-part-wrapper n 'mm-pipe-part))
3058
3059(defun gnus-article-save-part (n)
3060 "Save MIME part N, which is the numerical prefix."
3061 (interactive "p")
3062 (gnus-article-part-wrapper n 'mm-save-part))
3063
3064(defun gnus-article-interactively-view-part (n)
3065 "View MIME part N interactively, which is the numerical prefix."
3066 (interactive "p")
3067 (gnus-article-part-wrapper n 'mm-interactively-view-part))
3068
3069(defun gnus-article-copy-part (n)
3070 "Copy MIME part N, which is the numerical prefix."
3071 (interactive "p")
3072 (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3073
3074(defun gnus-article-externalize-part (n)
3075 "View MIME part N externally, which is the numerical prefix."
3076 (interactive "p")
3077 (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
3078
3079(defun gnus-article-inline-part (n)
3080 "Inline MIME part N, which is the numerical prefix."
3081 (interactive "p")
3082 (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3083
3084(defun gnus-article-mime-match-handle-first (condition)
3085 (if condition
3086 (let ((alist gnus-article-mime-handle-alist) ihandle n)
3087 (while (setq ihandle (pop alist))
3088 (if (and (cond
3089 ((functionp condition)
3090 (funcall condition (cdr ihandle)))
3091 ((eq condition 'undisplayed)
3092 (not (or (mm-handle-undisplayer (cdr ihandle))
3093 (equal (mm-handle-media-type (cdr ihandle))
3094 "multipart/alternative"))))
3095 ((eq condition 'undisplayed-alternative)
3096 (not (mm-handle-undisplayer (cdr ihandle))))
3097 (t t))
3098 (gnus-article-goto-part (car ihandle))
3099 (or (not n) (< (car ihandle) n)))
3100 (setq n (car ihandle))))
3101 (or n 1))
3102 1))
3103
3104(defun gnus-article-view-part (&optional n)
3105 "View MIME part N, which is the numerical prefix."
3106 (interactive "P")
3107 (save-current-buffer
3108 (set-buffer gnus-article-buffer)
3109 (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3110 gnus-article-mime-match-handle-function)))
3111 (when (> n (length gnus-article-mime-handle-alist))
3112 (error "No such part"))
3113 (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3114 (when (gnus-article-goto-part n)
3115 (if (equal (car handle) "multipart/alternative")
3116 (gnus-article-press-button)
3117 (when (eq (gnus-mm-display-part handle) 'internal)
3118 (gnus-set-window-start)))))))
3119
3120(defun gnus-mm-display-part (handle)
3121 "Display HANDLE and fix MIME button."
3122 (let ((id (get-text-property (point) 'gnus-part))
3123 (point (point))
3124 buffer-read-only)
3125 (forward-line 1)
3126 (prog1
3127 (let ((window (selected-window))
3128 (mail-parse-charset gnus-newsgroup-charset)
3129 (mail-parse-ignored-charsets
3130 (save-excursion (set-buffer gnus-summary-buffer)
3131 gnus-newsgroup-ignored-charsets)))
3132 (save-excursion
3133 (unwind-protect
3134 (let ((win (get-buffer-window (current-buffer) t))
3135 (beg (point)))
3136 (when win
3137 (select-window win))
3138 (goto-char point)
3139 (forward-line)
3140 (if (mm-handle-displayed-p handle)
3141 ;; This will remove the part.
3142 (mm-display-part handle)
3143 (save-restriction
3144 (narrow-to-region (point) (1+ (point)))
3145 (mm-display-part handle)
3146 ;; We narrow to the part itself and
3147 ;; then call the treatment functions.
3148 (goto-char (point-min))
3149 (forward-line 1)
3150 (narrow-to-region (point) (point-max))
3151 (gnus-treat-article
3152 nil id
3153 (1- (length gnus-article-mime-handles))
3154 (mm-handle-media-type handle)))))
3155 (select-window window))))
3156 (goto-char point)
3157 (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
3158 (gnus-insert-mime-button
3159 handle id (list (mm-handle-displayed-p handle)))
3160 (goto-char point))))
3161
3162(defun gnus-article-goto-part (n)
3163 "Go to MIME part N."
3164 (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
3165 (when point
3166 (goto-char point))))
3167
3168(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
3169 (let ((gnus-tmp-name
3170 (or (mail-content-type-get (mm-handle-type handle)
3171 'name)
3172 (mail-content-type-get (mm-handle-disposition handle)
3173 'filename)
3174 ""))
3175 (gnus-tmp-type (mm-handle-media-type handle))
3176 (gnus-tmp-description
3177 (mail-decode-encoded-word-string (or (mm-handle-description handle)
3178 "")))
3179 (gnus-tmp-dots
3180 (if (if displayed (car displayed)
3181 (mm-handle-displayed-p handle))
3182 "" "..."))
3183 (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
3184 (buffer-size)))
3185 gnus-tmp-type-long b e)
3186 (when (string-match ".*/" gnus-tmp-name)
3187 (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
3188 (setq gnus-tmp-type-long (concat gnus-tmp-type
3189 (and (not (equal gnus-tmp-name ""))
3190 (concat "; " gnus-tmp-name))))
3191 (or (equal gnus-tmp-description "")
3192 (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
3193 (unless (bolp)
3194 (insert "\n"))
3195 (setq b (point))
3196 (gnus-eval-format
3197 gnus-mime-button-line-format gnus-mime-button-line-format-alist
3198 `(local-map ,gnus-mime-button-map
3199 keymap ,gnus-mime-button-map
3200 gnus-callback gnus-mm-display-part
3201 gnus-part ,gnus-tmp-id
3202 article-type annotation
3203 gnus-data ,handle))
3204 (setq e (point))
3205 (widget-convert-button
3206 'link b e
3207 :mime-handle handle
3208 :action 'gnus-widget-press-button
3209 :button-keymap gnus-mime-button-map
3210 :help-echo
3211 (lambda (widget/window &optional overlay pos)
3212 ;; Needed to properly clear the message due to a bug in
3213 ;; wid-edit (XEmacs only).
3214 (if (boundp 'help-echo-owns-message)
3215 (setq help-echo-owns-message t))
3216 (format
3217 "%S: %s the MIME part; %S: more options"
3218 (aref gnus-mouse-2 0)
3219 ;; XEmacs will get a single widget arg; Emacs 21 will get
3220 ;; window, overlay, position.
3221 (if (mm-handle-displayed-p
3222 (if overlay
3223 (with-current-buffer (overlay-buffer overlay)
3224 (widget-get (widget-at (overlay-start overlay))
3225 :mime-handle))
3226 (widget-get widget/window :mime-handle)))
3227 "hide" "show")
3228 (aref gnus-down-mouse-3 0))))))
3229
3230(defun gnus-widget-press-button (elems el)
3231 (goto-char (widget-get elems :from))
3232 (gnus-article-press-button))
3233
3234(defvar gnus-displaying-mime nil)
3235
3236(defun gnus-display-mime (&optional ihandles)
3237 "Display the MIME parts."
3238 (save-excursion
3239 (save-selected-window
3240 (let ((window (get-buffer-window gnus-article-buffer))
3241 (point (point)))
3242 (when window
3243 (select-window window)
3244 ;; We have to do this since selecting the window
3245 ;; may change the point. So we set the window point.
3246 (set-window-point window point)))
3247 (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
3248 buffer-read-only handle name type b e display)
3249 (when (and (not ihandles)
3250 (not gnus-displaying-mime))
3251 ;; Top-level call; we clean up.
3252 (when gnus-article-mime-handles
3253 (mm-destroy-parts gnus-article-mime-handles)
3254 (setq gnus-article-mime-handle-alist nil));; A trick.
3255 (setq gnus-article-mime-handles handles)
3256 ;; We allow users to glean info from the handles.
3257 (when gnus-article-mime-part-function
3258 (gnus-mime-part-function handles)))
3259 (if (and handles
3260 (or (not (stringp (car handles)))
3261 (cdr handles)))
3262 (progn
3263 (when (and (not ihandles)
3264 (not gnus-displaying-mime))
3265 ;; Clean up for mime parts.
3266 (article-goto-body)
3267 (delete-region (point) (point-max)))
3268 (let ((gnus-displaying-mime t))
3269 (gnus-mime-display-part handles)))
3270 (save-restriction
3271 (article-goto-body)
3272 (narrow-to-region (point) (point-max))
3273 (gnus-treat-article nil 1 1)
3274 (widen)))
3275 (unless ihandles
3276 ;; Highlight the headers.
3277 (save-excursion
3278 (save-restriction
3279 (article-goto-body)
3280 (narrow-to-region (point-min) (point))
3281 (gnus-treat-article 'head))))))))
3282
3283(defvar gnus-mime-display-multipart-as-mixed nil)
3284
3285(defun gnus-mime-display-part (handle)
3286 (cond
3287 ;; Single part.
3288 ((not (stringp (car handle)))
3289 (gnus-mime-display-single handle))
3290 ;; User-defined multipart
3291 ((cdr (assoc (car handle) gnus-mime-multipart-functions))
3292 (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
3293 handle))
3294 ;; multipart/alternative
3295 ((and (equal (car handle) "multipart/alternative")
3296 (not gnus-mime-display-multipart-as-mixed))
3297 (let ((id (1+ (length gnus-article-mime-handle-alist))))
3298 (push (cons id handle) gnus-article-mime-handle-alist)
3299 (gnus-mime-display-alternative (cdr handle) nil nil id)))
3300 ;; multipart/related
3301 ((and (equal (car handle) "multipart/related")
3302 (not gnus-mime-display-multipart-as-mixed))
3303 ;;;!!!We should find the start part, but we just default
3304 ;;;!!!to the first part.
3305 (gnus-mime-display-part (cadr handle)))
3306 ;; Other multiparts are handled like multipart/mixed.
3307 (t
3308 (gnus-mime-display-mixed (cdr handle)))))
3309
3310(defun gnus-mime-part-function (handles)
3311 (if (stringp (car handles))
3312 (mapcar 'gnus-mime-part-function (cdr handles))
3313 (funcall gnus-article-mime-part-function handles)))
3314
3315(defun gnus-mime-display-mixed (handles)
3316 (mapcar 'gnus-mime-display-part handles))
3317
3318(defun gnus-mime-display-single (handle)
3319 (let ((type (mm-handle-media-type handle))
3320 (ignored gnus-ignored-mime-types)
3321 (not-attachment t)
3322 (move nil)
3323 display text)
3324 (catch 'ignored
3325 (progn
3326 (while ignored
3327 (when (string-match (pop ignored) type)
3328 (throw 'ignored nil)))
3329 (if (and (setq not-attachment
3330 (and (not (mm-inline-override-p handle))
3331 (or (not (mm-handle-disposition handle))
3332 (equal (car (mm-handle-disposition handle))
3333 "inline")
3334 (mm-attachment-override-p handle))))
3335 (mm-automatic-display-p handle)
3336 (or (mm-inlined-p handle)
3337 (mm-automatic-external-display-p type)))
3338 (setq display t)
3339 (when (equal (mm-handle-media-supertype handle) "text")
3340 (setq text t)))
3341 (let ((id (1+ (length gnus-article-mime-handle-alist))))
3342 (push (cons id handle) gnus-article-mime-handle-alist)
3343 (when (or (not display)
3344 (not (gnus-unbuttonized-mime-type-p type)))
3345 ;(gnus-article-insert-newline)
3346 (gnus-insert-mime-button
3347 handle id (list (or display (and not-attachment text))))
3348 (gnus-article-insert-newline)
3349 ;(gnus-article-insert-newline)
3350 (setq move t)))
3351 (let ((beg (point)))
3352 (cond
3353 (display
3354 (when move
3355 (forward-line -2)
3356 (setq beg (point)))
3357 (let ((mail-parse-charset gnus-newsgroup-charset)
3358 (mail-parse-ignored-charsets
3359 (save-excursion (condition-case ()
3360 (set-buffer gnus-summary-buffer)
3361 (error))
3362 gnus-newsgroup-ignored-charsets)))
3363 (mm-display-part handle t))
3364 (goto-char (point-max)))
3365 ((and text not-attachment)
3366 (when move
3367 (forward-line -2)
3368 (setq beg (point)))
3369 (gnus-article-insert-newline)
3370 (mm-insert-inline handle (mm-get-part handle))
3371 (goto-char (point-max))))
3372 ;; Do highlighting.
3373 (save-excursion
3374 (save-restriction
3375 (narrow-to-region beg (point))
3376 (gnus-treat-article
3377 nil (length gnus-article-mime-handle-alist)
3378 (1- (length gnus-article-mime-handles))
3379 (mm-handle-media-type handle)))))))))
3380
3381(defun gnus-unbuttonized-mime-type-p (type)
3382 "Say whether TYPE is to be unbuttonized."
3383 (unless gnus-inhibit-mime-unbuttonizing
3384 (catch 'found
3385 (let ((types gnus-unbuttonized-mime-types))
3386 (while types
3387 (when (string-match (pop types) type)
3388 (throw 'found t)))))))
3389
3390(defun gnus-article-insert-newline ()
3391 "Insert a newline, but mark it as undeletable."
3392 (gnus-put-text-property
3393 (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
3394
3395(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
3396 (let* ((preferred (or preferred (mm-preferred-alternative handles)))
3397 (ihandles handles)
3398 (point (point))
3399 handle buffer-read-only from props begend not-pref)
3400 (save-window-excursion
3401 (save-restriction
3402 (when ibegend
3403 (narrow-to-region (car ibegend)
3404 (or (cdr ibegend)
3405 (progn
3406 (goto-char (car ibegend))
3407 (forward-line 2)
3408 (point))))
3409 (delete-region (point-min) (point-max))
3410 (mm-remove-parts handles))
3411 (setq begend (list (point-marker)))
3412 ;; Do the toggle.
3413 (unless (setq not-pref (cadr (member preferred ihandles)))
3414 (setq not-pref (car ihandles)))
3415 (when (or ibegend
3416 (not (gnus-unbuttonized-mime-type-p
3417 "multipart/alternative")))
3418 (gnus-add-text-properties
3419 (setq from (point))
3420 (progn
3421 (insert (format "%d. " id))
3422 (point))
3423 `(gnus-callback
3424 (lambda (handles)
3425 (unless ,(not ibegend)
3426 (setq gnus-article-mime-handle-alist
3427 ',gnus-article-mime-handle-alist))
3428 (gnus-mime-display-alternative
3429 ',ihandles ',not-pref ',begend ,id))
3430 local-map ,gnus-mime-button-map
3431 ,gnus-mouse-face-prop ,gnus-article-mouse-face
3432 face ,gnus-article-button-face
3433 keymap ,gnus-mime-button-map
3434 gnus-part ,id
3435 gnus-data ,handle))
3436 (widget-convert-button 'link from (point)
3437 :action 'gnus-widget-press-button
3438 :button-keymap gnus-widget-button-keymap)
3439 ;; Do the handles
3440 (while (setq handle (pop handles))
3441 (gnus-add-text-properties
3442 (setq from (point))
3443 (progn
3444 (insert (format "(%c) %-18s"
3445 (if (equal handle preferred) ?* ? )
3446 (mm-handle-media-type handle)))
3447 (point))
3448 `(gnus-callback
3449 (lambda (handles)
3450 (unless ,(not ibegend)
3451 (setq gnus-article-mime-handle-alist
3452 ',gnus-article-mime-handle-alist))
3453 (gnus-mime-display-alternative
3454 ',ihandles ',handle ',begend ,id))
3455 local-map ,gnus-mime-button-map
3456 ,gnus-mouse-face-prop ,gnus-article-mouse-face
3457 face ,gnus-article-button-face
3458 keymap ,gnus-mime-button-map
3459 gnus-part ,id
3460 gnus-data ,handle))
3461 (widget-convert-button 'link from (point)
3462 :action 'gnus-widget-press-button
3463 :button-keymap gnus-widget-button-keymap)
3464 (insert " "))
3465 (insert "\n\n"))
3466 (when preferred
3467 (if (stringp (car preferred))
3468 (gnus-display-mime preferred)
3469 (let ((mail-parse-charset gnus-newsgroup-charset)
3470 (mail-parse-ignored-charsets
3471 (save-excursion (set-buffer gnus-summary-buffer)
3472 gnus-newsgroup-ignored-charsets)))
3473 (mm-display-part preferred)
3474 ;; Do highlighting.
3475 (save-excursion
3476 (save-restriction
3477 (narrow-to-region (car begend) (point-max))
3478 (gnus-treat-article
3479 nil (length gnus-article-mime-handle-alist)
3480 (1- (length gnus-article-mime-handles))
3481 (mm-handle-media-type handle))))))
3482 (goto-char (point-max))
3483 (setcdr begend (point-marker)))))
3484 (when ibegend
3485 (goto-char point))))
3486
2170(defun gnus-article-wash-status () 3487(defun gnus-article-wash-status ()
2171 "Return a string which display status of article washing." 3488 "Return a string which display status of article washing."
2172 (save-excursion 3489 (save-excursion
2173 (set-buffer gnus-article-buffer) 3490 (set-buffer gnus-article-buffer)
2174 (let ((cite (gnus-article-hidden-text-p 'cite)) 3491 (let ((cite (memq 'cite gnus-article-wash-types))
2175 (headers (gnus-article-hidden-text-p 'headers)) 3492 (headers (memq 'headers gnus-article-wash-types))
2176 (boring (gnus-article-hidden-text-p 'boring-headers)) 3493 (boring (memq 'boring-headers gnus-article-wash-types))
2177 (pgp (gnus-article-hidden-text-p 'pgp)) 3494 (pgp (memq 'pgp gnus-article-wash-types))
2178 (pem (gnus-article-hidden-text-p 'pem)) 3495 (pem (memq 'pem gnus-article-wash-types))
2179 (signature (gnus-article-hidden-text-p 'signature)) 3496 (signature (memq 'signature gnus-article-wash-types))
2180 (overstrike (gnus-article-hidden-text-p 'overstrike)) 3497 (overstrike (memq 'overstrike gnus-article-wash-types))
2181 (emphasis (gnus-article-hidden-text-p 'emphasis)) 3498 (emphasis (memq 'emphasis gnus-article-wash-types)))
2182 (mime gnus-show-mime)) 3499 (format "%c%c%c%c%c%c"
2183 (format "%c%c%c%c%c%c%c"
2184 (if cite ?c ? ) 3500 (if cite ?c ? )
2185 (if (or headers boring) ?h ? ) 3501 (if (or headers boring) ?h ? )
2186 (if (or pgp pem) ?p ? ) 3502 (if (or pgp pem) ?p ? )
2187 (if signature ?s ? ) 3503 (if signature ?s ? )
2188 (if overstrike ?o ? ) 3504 (if overstrike ?o ? )
2189 (if mime ?m ? )
2190 (if emphasis ?e ? ))))) 3505 (if emphasis ?e ? )))))
2191 3506
2192(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) 3507(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
2193 3508
2194(defun gnus-article-maybe-hide-headers () 3509(defun gnus-article-maybe-hide-headers ()
2195 "Hide unwanted headers if `gnus-have-all-headers' is nil. 3510 "Hide unwanted headers if `gnus-have-all-headers' is nil.
2196Provided for backwards compatibility." 3511Provided for backwards compatibility."
2197 (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) 3512 (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
2198 gnus-inhibit-hiding 3513 (not (save-excursion (set-buffer gnus-summary-buffer)
2199 (gnus-article-hide-headers))) 3514 gnus-have-all-headers)))
3515 (not gnus-inhibit-hiding))
3516 (gnus-article-hide-headers)))
2200 3517
2201;;; Article savers. 3518;;; Article savers.
2202 3519
2203(defun gnus-output-to-file (file-name) 3520(defun gnus-output-to-file (file-name)
2204 "Append the current article to a file named FILE-NAME." 3521 "Append the current article to a file named FILE-NAME."
2205 (let ((artbuf (current-buffer))) 3522 (let ((artbuf (current-buffer)))
2206 (nnheader-temp-write nil 3523 (with-temp-buffer
2207 (insert-buffer-substring artbuf) 3524 (insert-buffer-substring artbuf)
2208 ;; Append newline at end of the buffer as separator, and then 3525 ;; Append newline at end of the buffer as separator, and then
2209 ;; save it to file. 3526 ;; save it to file.
2210 (goto-char (point-max)) 3527 (goto-char (point-max))
2211 (insert "\n") 3528 (insert "\n")
2212 (append-to-file (point-min) (point-max) file-name) 3529 (mm-append-to-file (point-min) (point-max) file-name)
2213 t))) 3530 t)))
2214 3531
2215(defun gnus-narrow-to-page (&optional arg) 3532(defun gnus-narrow-to-page (&optional arg)
@@ -2337,8 +3654,7 @@ Argument LINES specifies lines to be scrolled down."
2337(defun gnus-article-describe-briefly () 3654(defun gnus-article-describe-briefly ()
2338 "Describe article mode commands briefly." 3655 "Describe article mode commands briefly."
2339 (interactive) 3656 (interactive)
2340 (gnus-message 6 3657 (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
2341 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
2342 3658
2343(defun gnus-article-summary-command () 3659(defun gnus-article-summary-command ()
2344 "Execute the last keystroke in the summary buffer." 3660 "Execute the last keystroke in the summary buffer."
@@ -2361,9 +3677,15 @@ Argument LINES specifies lines to be scrolled down."
2361 (setq func (lookup-key (current-local-map) (this-command-keys))) 3677 (setq func (lookup-key (current-local-map) (this-command-keys)))
2362 (call-interactively func))) 3678 (call-interactively func)))
2363 3679
3680(defun gnus-article-check-buffer ()
3681 "Beep if not in an article buffer."
3682 (unless (equal major-mode 'gnus-article-mode)
3683 (error "Command invoked outside of a Gnus article buffer")))
3684
2364(defun gnus-article-read-summary-keys (&optional arg key not-restore-window) 3685(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
2365 "Read a summary buffer key sequence and execute it from the article buffer." 3686 "Read a summary buffer key sequence and execute it from the article buffer."
2366 (interactive "P") 3687 (interactive "P")
3688 (gnus-article-check-buffer)
2367 (let ((nosaves 3689 (let ((nosaves
2368 '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" 3690 '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
2369 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" 3691 "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
@@ -2379,7 +3701,10 @@ Argument LINES specifies lines to be scrolled down."
2379 (set-buffer gnus-article-current-summary) 3701 (set-buffer gnus-article-current-summary)
2380 (let (gnus-pick-mode) 3702 (let (gnus-pick-mode)
2381 (push (or key last-command-event) unread-command-events) 3703 (push (or key last-command-event) unread-command-events)
2382 (setq keys (read-key-sequence nil)))) 3704 (setq keys (if gnus-xemacs
3705 (events-to-keys (read-key-sequence nil))
3706 (read-key-sequence nil)))))
3707
2383 (message "") 3708 (message "")
2384 3709
2385 (if (or (member keys nosaves) 3710 (if (or (member keys nosaves)
@@ -2391,7 +3716,8 @@ Argument LINES specifies lines to be scrolled down."
2391 ;; We disable the pick minor mode commands. 3716 ;; We disable the pick minor mode commands.
2392 (let (gnus-pick-mode) 3717 (let (gnus-pick-mode)
2393 (setq func (lookup-key (current-local-map) keys)))) 3718 (setq func (lookup-key (current-local-map) keys))))
2394 (if (not func) 3719 (if (or (not func)
3720 (numberp func))
2395 (ding) 3721 (ding)
2396 (unless (member keys nosave-in-article) 3722 (unless (member keys nosave-in-article)
2397 (set-buffer gnus-article-current-summary)) 3723 (set-buffer gnus-article-current-summary))
@@ -2421,9 +3747,12 @@ Argument LINES specifies lines to be scrolled down."
2421 (set-buffer obuf) 3747 (set-buffer obuf)
2422 (unless not-restore-window 3748 (unless not-restore-window
2423 (set-window-configuration owin)) 3749 (set-window-configuration owin))
2424 (unless (or (not (eq selected 'old)) (member keys up-to-top)) 3750 (when (eq selected 'old)
3751 (article-goto-body)
3752 (set-window-start (get-buffer-window (current-buffer))
3753 1)
2425 (set-window-point (get-buffer-window (current-buffer)) 3754 (set-window-point (get-buffer-window (current-buffer))
2426 opoint)) 3755 (point)))
2427 (let ((win (get-buffer-window gnus-article-current-summary))) 3756 (let ((win (get-buffer-window gnus-article-current-summary)))
2428 (when win 3757 (when win
2429 (set-window-point win new-sum-point)))))))) 3758 (set-window-point win new-sum-point))))))))
@@ -2435,6 +3764,7 @@ headers will be hidden.
2435If given a prefix, show the hidden text instead." 3764If given a prefix, show the hidden text instead."
2436 (interactive (append (gnus-article-hidden-arg) (list 'force))) 3765 (interactive (append (gnus-article-hidden-arg) (list 'force)))
2437 (gnus-article-hide-headers arg) 3766 (gnus-article-hide-headers arg)
3767 (gnus-article-hide-list-identifiers arg)
2438 (gnus-article-hide-pgp arg) 3768 (gnus-article-hide-pgp arg)
2439 (gnus-article-hide-citation-maybe arg force) 3769 (gnus-article-hide-citation-maybe arg force)
2440 (gnus-article-hide-signature arg)) 3770 (gnus-article-hide-signature arg))
@@ -2467,8 +3797,7 @@ If given a prefix, show the hidden text instead."
2467 ;; We only request an article by message-id when we do not have the 3797 ;; We only request an article by message-id when we do not have the
2468 ;; headers for it, so we'll have to get those. 3798 ;; headers for it, so we'll have to get those.
2469 (when (stringp article) 3799 (when (stringp article)
2470 (let ((gnus-override-method gnus-refer-article-method)) 3800 (gnus-read-header article))
2471 (gnus-read-header article)))
2472 3801
2473 ;; If the article number is negative, that means that this article 3802 ;; If the article number is negative, that means that this article
2474 ;; doesn't belong in this newsgroup (possibly), so we find its 3803 ;; doesn't belong in this newsgroup (possibly), so we find its
@@ -2486,8 +3815,7 @@ If given a prefix, show the hidden text instead."
2486 ;; This is a sparse gap article. 3815 ;; This is a sparse gap article.
2487 (setq do-update-line article) 3816 (setq do-update-line article)
2488 (setq article (mail-header-id header)) 3817 (setq article (mail-header-id header))
2489 (let ((gnus-override-method gnus-refer-article-method)) 3818 (setq sparse-header (gnus-read-header article))
2490 (setq sparse-header (gnus-read-header article)))
2491 (setq gnus-newsgroup-sparse 3819 (setq gnus-newsgroup-sparse
2492 (delq article gnus-newsgroup-sparse))) 3820 (delq article gnus-newsgroup-sparse)))
2493 ((vectorp header) 3821 ((vectorp header)
@@ -2502,11 +3830,11 @@ If given a prefix, show the hidden text instead."
2502 gnus-newsgroup-name))) 3830 gnus-newsgroup-name)))
2503 (when (and (eq (car method) 'nneething) 3831 (when (and (eq (car method) 'nneething)
2504 (vectorp header)) 3832 (vectorp header))
2505 (let ((dir (concat 3833 (let ((dir (expand-file-name
3834 (mail-header-subject header)
2506 (file-name-as-directory 3835 (file-name-as-directory
2507 (or (cadr (assq 'nneething-address method)) 3836 (or (cadr (assq 'nneething-address method))
2508 (nth 1 method))) 3837 (nth 1 method))))))
2509 (mail-header-subject header))))
2510 (when (file-directory-p dir) 3838 (when (file-directory-p dir)
2511 (setq article 'nneething) 3839 (setq article 'nneething)
2512 (gnus-group-enter-directory dir)))))))) 3840 (gnus-group-enter-directory dir))))))))
@@ -2547,20 +3875,40 @@ If given a prefix, show the hidden text instead."
2547 (gnus-cache-request-article article group)) 3875 (gnus-cache-request-article article group))
2548 'article) 3876 'article)
2549 ;; Get the article and put into the article buffer. 3877 ;; Get the article and put into the article buffer.
2550 ((or (stringp article) (numberp article)) 3878 ((or (stringp article)
2551 (let ((gnus-override-method 3879 (numberp article))
2552 (and (stringp article) gnus-refer-article-method)) 3880 (let ((gnus-override-method gnus-override-method)
3881 (methods (and (stringp article)
3882 gnus-refer-article-method))
3883 result
2553 (buffer-read-only nil)) 3884 (buffer-read-only nil))
2554 (erase-buffer) 3885 (setq methods
2555 (gnus-kill-all-overlays) 3886 (if (listp methods)
2556 (gnus-check-group-server) 3887 methods
2557 (when (gnus-request-article article group (current-buffer)) 3888 (list methods)))
2558 (when (numberp article) 3889 (when (and (null gnus-override-method)
2559 (gnus-async-prefetch-next group article gnus-summary-buffer) 3890 methods)
2560 (when gnus-keep-backlog 3891 (setq gnus-override-method (pop methods)))
2561 (gnus-backlog-enter-article 3892 (while (not result)
2562 group article (current-buffer)))) 3893 (when (eq gnus-override-method 'current)
2563 'article))) 3894 (setq gnus-override-method gnus-current-select-method))
3895 (erase-buffer)
3896 (gnus-kill-all-overlays)
3897 (let ((gnus-newsgroup-name group))
3898 (gnus-check-group-server))
3899 (when (gnus-request-article article group (current-buffer))
3900 (when (numberp article)
3901 (gnus-async-prefetch-next group article
3902 gnus-summary-buffer)
3903 (when gnus-keep-backlog
3904 (gnus-backlog-enter-article
3905 group article (current-buffer))))
3906 (setq result 'article))
3907 (if (not result)
3908 (if methods
3909 (setq gnus-override-method (pop methods))
3910 (setq result 'done))))
3911 (and (eq result 'article) 'article)))
2564 ;; It was a pseudo. 3912 ;; It was a pseudo.
2565 (t article))) 3913 (t article)))
2566 3914
@@ -2576,13 +3924,18 @@ If given a prefix, show the hidden text instead."
2576 (if (get-buffer gnus-original-article-buffer) 3924 (if (get-buffer gnus-original-article-buffer)
2577 (set-buffer gnus-original-article-buffer) 3925 (set-buffer gnus-original-article-buffer)
2578 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) 3926 (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
2579 (buffer-disable-undo (current-buffer)) 3927 (buffer-disable-undo)
2580 (setq major-mode 'gnus-original-article-mode) 3928 (setq major-mode 'gnus-original-article-mode)
2581 (setq buffer-read-only t)) 3929 (setq buffer-read-only t))
2582 (let (buffer-read-only) 3930 (let (buffer-read-only)
2583 (erase-buffer) 3931 (erase-buffer)
2584 (insert-buffer-substring gnus-article-buffer)) 3932 (insert-buffer-substring gnus-article-buffer))
2585 (setq gnus-original-article (cons group article)))) 3933 (setq gnus-original-article (cons group article)))
3934
3935 ;; Decode charsets.
3936 (run-hooks 'gnus-article-decode-hook)
3937 ;; Mark article as decoded or not.
3938 (setq gnus-article-decoded-p gnus-article-decode-hook))
2586 3939
2587 ;; Update sparse articles. 3940 ;; Update sparse articles.
2588 (when (and do-update-line 3941 (when (and do-update-line
@@ -2609,8 +3962,10 @@ If given a prefix, show the hidden text instead."
2609 3962
2610(defvar gnus-article-edit-mode-map nil) 3963(defvar gnus-article-edit-mode-map nil)
2611 3964
3965;; Should we be using derived.el for this?
2612(unless gnus-article-edit-mode-map 3966(unless gnus-article-edit-mode-map
2613 (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) 3967 (setq gnus-article-edit-mode-map (make-sparse-keymap))
3968 (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
2614 3969
2615 (gnus-define-keys gnus-article-edit-mode-map 3970 (gnus-define-keys gnus-article-edit-mode-map
2616 "\C-c\C-c" gnus-article-edit-done 3971 "\C-c\C-c" gnus-article-edit-done
@@ -2647,18 +4002,19 @@ groups."
2647 (error "The current newsgroup does not support article editing")) 4002 (error "The current newsgroup does not support article editing"))
2648 (gnus-article-date-original) 4003 (gnus-article-date-original)
2649 (gnus-article-edit-article 4004 (gnus-article-edit-article
4005 'ignore
2650 `(lambda (no-highlight) 4006 `(lambda (no-highlight)
4007 'ignore
2651 (gnus-summary-edit-article-done 4008 (gnus-summary-edit-article-done
2652 ,(or (mail-header-references gnus-current-headers) "") 4009 ,(or (mail-header-references gnus-current-headers) "")
2653 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) 4010 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
2654 4011
2655(defun gnus-article-edit-article (exit-func) 4012(defun gnus-article-edit-article (start-func exit-func)
2656 "Start editing the contents of the current article buffer." 4013 "Start editing the contents of the current article buffer."
2657 (let ((winconf (current-window-configuration))) 4014 (let ((winconf (current-window-configuration)))
2658 (set-buffer gnus-article-buffer) 4015 (set-buffer gnus-article-buffer)
2659 (gnus-article-edit-mode) 4016 (gnus-article-edit-mode)
2660 (gnus-article-delete-text-of-type 'annotation) 4017 (funcall start-func)
2661 (gnus-set-text-properties (point-min) (point-max) nil)
2662 (gnus-configure-windows 'edit-article) 4018 (gnus-configure-windows 'edit-article)
2663 (setq gnus-article-edit-done-function exit-func) 4019 (setq gnus-article-edit-done-function exit-func)
2664 (setq gnus-prev-winconf winconf) 4020 (setq gnus-prev-winconf winconf)
@@ -2670,8 +4026,7 @@ groups."
2670 (save-excursion 4026 (save-excursion
2671 (save-restriction 4027 (save-restriction
2672 (widen) 4028 (widen)
2673 (goto-char (point-min)) 4029 (when (article-goto-body)
2674 (when (search-forward "\n\n" nil 1)
2675 (let ((lines (count-lines (point) (point-max))) 4030 (let ((lines (count-lines (point) (point-max)))
2676 (length (- (point-max) (point))) 4031 (length (- (point-max) (point)))
2677 (case-fold-search t) 4032 (case-fold-search t)
@@ -2696,7 +4051,19 @@ groups."
2696 (save-excursion 4051 (save-excursion
2697 (set-buffer buf) 4052 (set-buffer buf)
2698 (let ((buffer-read-only nil)) 4053 (let ((buffer-read-only nil))
2699 (funcall func arg))) 4054 (funcall func arg))
4055 ;; The cache and backlog have to be flushed somewhat.
4056 (when gnus-keep-backlog
4057 (gnus-backlog-remove-article
4058 (car gnus-article-current) (cdr gnus-article-current)))
4059 ;; Flush original article as well.
4060 (save-excursion
4061 (when (get-buffer gnus-original-article-buffer)
4062 (set-buffer gnus-original-article-buffer)
4063 (setq gnus-original-article nil)))
4064 (when gnus-use-cache
4065 (gnus-cache-update-article
4066 (car gnus-article-current) (cdr gnus-article-current))))
2700 (set-buffer buf) 4067 (set-buffer buf)
2701 (set-window-start (get-buffer-window buf) start) 4068 (set-window-start (get-buffer-window buf) start)
2702 (set-window-point (get-buffer-window buf) (point)))) 4069 (set-window-point (get-buffer-window buf) (point))))
@@ -2705,7 +4072,7 @@ groups."
2705 "Exit the article editing without updating." 4072 "Exit the article editing without updating."
2706 (interactive) 4073 (interactive)
2707 ;; We remove all text props from the article buffer. 4074 ;; We remove all text props from the article buffer.
2708 (let ((buf (format "%s" (buffer-string))) 4075 (let ((buf (buffer-substring-no-properties (point-min) (point-max)))
2709 (curbuf (current-buffer)) 4076 (curbuf (current-buffer))
2710 (p (point)) 4077 (p (point))
2711 (window-start (window-start))) 4078 (window-start (window-start)))
@@ -2713,25 +4080,12 @@ groups."
2713 (insert buf) 4080 (insert buf)
2714 (let ((winconf gnus-prev-winconf)) 4081 (let ((winconf gnus-prev-winconf))
2715 (gnus-article-mode) 4082 (gnus-article-mode)
2716 ;; The cache and backlog have to be flushed somewhat.
2717 (when gnus-use-cache
2718 (gnus-cache-update-article
2719 (car gnus-article-current) (cdr gnus-article-current)))
2720 (when gnus-keep-backlog
2721 (gnus-backlog-remove-article
2722 (car gnus-article-current) (cdr gnus-article-current)))
2723 ;; Flush original article as well.
2724 (save-excursion
2725 (when (get-buffer gnus-original-article-buffer)
2726 (set-buffer gnus-original-article-buffer)
2727 (setq gnus-original-article nil)))
2728 (set-window-configuration winconf) 4083 (set-window-configuration winconf)
2729 ;; Tippy-toe some to make sure that point remains where it was. 4084 ;; Tippy-toe some to make sure that point remains where it was.
2730 (let ((buf (current-buffer))) 4085 (save-current-buffer
2731 (set-buffer curbuf) 4086 (set-buffer curbuf)
2732 (set-window-start (get-buffer-window (current-buffer)) window-start) 4087 (set-window-start (get-buffer-window (current-buffer)) window-start)
2733 (goto-char p) 4088 (goto-char p)))))
2734 (set-buffer buf)))))
2735 4089
2736(defun gnus-article-edit-full-stops () 4090(defun gnus-article-edit-full-stops ()
2737 "Interactively repair spacing at end of sentences." 4091 "Interactively repair spacing at end of sentences."
@@ -2750,15 +4104,15 @@ groups."
2750 4104
2751;;; Internal Variables: 4105;;; Internal Variables:
2752 4106
2753(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" 4107(defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)"
2754 "Regular expression that matches URLs." 4108 "Regular expression that matches URLs."
2755 :group 'gnus-article-buttons 4109 :group 'gnus-article-buttons
2756 :type 'regexp) 4110 :type 'regexp)
2757 4111
2758(defcustom gnus-button-alist 4112(defcustom gnus-button-alist
2759 `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t 4113 `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
2760 gnus-button-message-id 2) 4114 0 t gnus-button-message-id 2)
2761 ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) 4115 ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
2762 ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" 4116 ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
2763 1 t 4117 1 t
2764 gnus-button-fetch-group 4) 4118 gnus-button-fetch-group 4)
@@ -2766,12 +4120,12 @@ groups."
2766 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 4120 ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
2767 t gnus-button-message-id 3) 4121 t gnus-button-message-id 3)
2768 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) 4122 ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
2769 ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) 4123 ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
2770 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) 4124 ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
2771 ;; This is how URLs _should_ be embedded in text... 4125 ;; This is how URLs _should_ be embedded in text...
2772 ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1) 4126 ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
2773 ;; Raw URLs. 4127 ;; Raw URLs.
2774 (,gnus-button-url-regexp 0 t gnus-button-url 0)) 4128 (,gnus-button-url-regexp 0 t browse-url 0))
2775 "*Alist of regexps matching buttons in article bodies. 4129 "*Alist of regexps matching buttons in article bodies.
2776 4130
2777Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where 4131Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
@@ -2799,9 +4153,9 @@ variable it the real callback function."
2799 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) 4153 ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
2800 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 4154 ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
2801 0 t gnus-button-mailto 0) 4155 0 t gnus-button-mailto 0)
2802 ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) 4156 ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
2803 ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) 4157 ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
2804 ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) 4158 ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
2805 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t 4159 ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
2806 gnus-button-message-id 3)) 4160 gnus-button-message-id 3))
2807 "*Alist of headers and regexps to match buttons in article heads. 4161 "*Alist of headers and regexps to match buttons in article heads.
@@ -2856,40 +4210,6 @@ call it with the value of the `gnus-data' text property."
2856 (when fun 4210 (when fun
2857 (funcall fun data)))) 4211 (funcall fun data))))
2858 4212
2859(defun gnus-article-prev-button (n)
2860 "Move point to N buttons backward.
2861If N is negative, move forward instead."
2862 (interactive "p")
2863 (gnus-article-next-button (- n)))
2864
2865(defun gnus-article-next-button (n)
2866 "Move point to N buttons forward.
2867If N is negative, move backward instead."
2868 (interactive "p")
2869 (let ((function (if (< n 0) 'previous-single-property-change
2870 'next-single-property-change))
2871 (inhibit-point-motion-hooks t)
2872 (backward (< n 0))
2873 (limit (if (< n 0) (point-min) (point-max))))
2874 (setq n (abs n))
2875 (while (and (not (= limit (point)))
2876 (> n 0))
2877 ;; Skip past the current button.
2878 (when (get-text-property (point) 'gnus-callback)
2879 (goto-char (funcall function (point) 'gnus-callback nil limit)))
2880 ;; Go to the next (or previous) button.
2881 (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
2882 ;; Put point at the start of the button.
2883 (when (and backward (not (get-text-property (point) 'gnus-callback)))
2884 (goto-char (funcall function (point) 'gnus-callback nil limit)))
2885 ;; Skip past intangible buttons.
2886 (when (get-text-property (point) 'intangible)
2887 (incf n))
2888 (decf n))
2889 (unless (zerop n)
2890 (gnus-message 5 "No more buttons"))
2891 n))
2892
2893(defun gnus-article-highlight (&optional force) 4213(defun gnus-article-highlight (&optional force)
2894 "Highlight current article. 4214 "Highlight current article.
2895This function calls `gnus-article-highlight-headers', 4215This function calls `gnus-article-highlight-headers',
@@ -2924,7 +4244,7 @@ do the highlighting. See the documentation for those functions."
2924 (case-fold-search t) 4244 (case-fold-search t)
2925 (inhibit-point-motion-hooks t) 4245 (inhibit-point-motion-hooks t)
2926 entry regexp header-face field-face from hpoints fpoints) 4246 entry regexp header-face field-face from hpoints fpoints)
2927 (message-narrow-to-head) 4247 (article-narrow-to-head)
2928 (while (setq entry (pop alist)) 4248 (while (setq entry (pop alist))
2929 (goto-char (point-min)) 4249 (goto-char (point-min))
2930 (setq regexp (concat "^\\(" 4250 (setq regexp (concat "^\\("
@@ -2990,18 +4310,19 @@ specified by `gnus-button-alist'."
2990 (alist gnus-button-alist) 4310 (alist gnus-button-alist)
2991 beg entry regexp) 4311 beg entry regexp)
2992 ;; Remove all old markers. 4312 ;; Remove all old markers.
2993 (let (marker entry) 4313 (let (marker entry new-list)
2994 (while (setq marker (pop gnus-button-marker-list)) 4314 (while (setq marker (pop gnus-button-marker-list))
2995 (goto-char marker) 4315 (if (or (< marker (point-min)) (>= marker (point-max)))
2996 (when (setq entry (gnus-button-entry)) 4316 (push marker new-list)
2997 (put-text-property (match-beginning (nth 1 entry)) 4317 (goto-char marker)
2998 (match-end (nth 1 entry)) 4318 (when (setq entry (gnus-button-entry))
2999 'gnus-callback nil)) 4319 (put-text-property (match-beginning (nth 1 entry))
3000 (set-marker marker nil))) 4320 (match-end (nth 1 entry))
4321 'gnus-callback nil))
4322 (set-marker marker nil)))
4323 (setq gnus-button-marker-list new-list))
3001 ;; We skip the headers. 4324 ;; We skip the headers.
3002 (goto-char (point-min)) 4325 (article-goto-body)
3003 (unless (search-forward "\n\n" nil t)
3004 (goto-char (point-max)))
3005 (setq beg (point)) 4326 (setq beg (point))
3006 (while (setq entry (pop alist)) 4327 (while (setq entry (pop alist))
3007 (setq regexp (car entry)) 4328 (setq regexp (car entry))
@@ -3027,38 +4348,38 @@ specified by `gnus-button-alist'."
3027 (interactive) 4348 (interactive)
3028 (save-excursion 4349 (save-excursion
3029 (set-buffer gnus-article-buffer) 4350 (set-buffer gnus-article-buffer)
3030 (let ((buffer-read-only nil) 4351 (save-restriction
3031 (inhibit-point-motion-hooks t) 4352 (let ((buffer-read-only nil)
3032 (case-fold-search t) 4353 (inhibit-point-motion-hooks t)
3033 (alist gnus-header-button-alist) 4354 (case-fold-search t)
3034 entry beg end) 4355 (alist gnus-header-button-alist)
3035 (nnheader-narrow-to-headers) 4356 entry beg end)
3036 (while alist 4357 (article-narrow-to-head)
3037 ;; Each alist entry. 4358 (while alist
3038 (setq entry (car alist) 4359 ;; Each alist entry.
3039 alist (cdr alist)) 4360 (setq entry (car alist)
3040 (goto-char (point-min)) 4361 alist (cdr alist))
3041 (while (re-search-forward (car entry) nil t) 4362 (goto-char (point-min))
3042 ;; Each header matching the entry. 4363 (while (re-search-forward (car entry) nil t)
3043 (setq beg (match-beginning 0)) 4364 ;; Each header matching the entry.
3044 (setq end (or (and (re-search-forward "^[^ \t]" nil t) 4365 (setq beg (match-beginning 0))
3045 (match-beginning 0)) 4366 (setq end (or (and (re-search-forward "^[^ \t]" nil t)
3046 (point-max))) 4367 (match-beginning 0))
3047 (goto-char beg) 4368 (point-max)))
3048 (while (re-search-forward (nth 1 entry) end t) 4369 (goto-char beg)
3049 ;; Each match within a header. 4370 (while (re-search-forward (nth 1 entry) end t)
3050 (let* ((entry (cdr entry)) 4371 ;; Each match within a header.
3051 (start (match-beginning (nth 1 entry))) 4372 (let* ((entry (cdr entry))
3052 (end (match-end (nth 1 entry))) 4373 (start (match-beginning (nth 1 entry)))
3053 (form (nth 2 entry))) 4374 (end (match-end (nth 1 entry)))
3054 (goto-char (match-end 0)) 4375 (form (nth 2 entry)))
3055 (when (eval form) 4376 (goto-char (match-end 0))
3056 (gnus-article-add-button 4377 (when (eval form)
3057 start end (nth 3 entry) 4378 (gnus-article-add-button
3058 (buffer-substring (match-beginning (nth 4 entry)) 4379 start end (nth 3 entry)
3059 (match-end (nth 4 entry))))))) 4380 (buffer-substring (match-beginning (nth 4 entry))
3060 (goto-char end)))) 4381 (match-end (nth 4 entry)))))))
3061 (widen))) 4382 (goto-char end)))))))
3062 4383
3063;;; External functions: 4384;;; External functions:
3064 4385
@@ -3072,7 +4393,9 @@ specified by `gnus-button-alist'."
3072 (nconc (and gnus-article-mouse-face 4393 (nconc (and gnus-article-mouse-face
3073 (list gnus-mouse-face-prop gnus-article-mouse-face)) 4394 (list gnus-mouse-face-prop gnus-article-mouse-face))
3074 (list 'gnus-callback fun) 4395 (list 'gnus-callback fun)
3075 (and data (list 'gnus-data data))))) 4396 (and data (list 'gnus-data data))))
4397 (widget-convert-button 'link from to :action 'gnus-widget-press-button
4398 :button-keymap gnus-widget-button-keymap))
3076 4399
3077;;; Internal functions: 4400;;; Internal functions:
3078 4401
@@ -3104,7 +4427,6 @@ specified by `gnus-button-alist'."
3104(defun gnus-button-push (marker) 4427(defun gnus-button-push (marker)
3105 ;; Push button starting at MARKER. 4428 ;; Push button starting at MARKER.
3106 (save-excursion 4429 (save-excursion
3107 (set-buffer gnus-article-buffer)
3108 (goto-char marker) 4430 (goto-char marker)
3109 (let* ((entry (gnus-button-entry)) 4431 (let* ((entry (gnus-button-entry))
3110 (inhibit-point-motion-hooks t) 4432 (inhibit-point-motion-hooks t)
@@ -3149,7 +4471,7 @@ specified by `gnus-button-alist'."
3149 4471
3150(defun gnus-url-parse-query-string (query &optional downcase) 4472(defun gnus-url-parse-query-string (query &optional downcase)
3151 (let (retval pairs cur key val) 4473 (let (retval pairs cur key val)
3152 (setq pairs (gnus-split-string query "&")) 4474 (setq pairs (split-string query "&"))
3153 (while pairs 4475 (while pairs
3154 (setq cur (car pairs) 4476 (setq cur (car pairs)
3155 pairs (cdr pairs)) 4477 pairs (cdr pairs))
@@ -3230,13 +4552,8 @@ forbidden in URL encoding."
3230 ;; Reply to ADDRESS. 4552 ;; Reply to ADDRESS.
3231 (message-reply address)) 4553 (message-reply address))
3232 4554
3233(defun gnus-button-url (address)
3234 "Browse ADDRESS."
3235 (browse-url address))
3236
3237(defun gnus-button-embedded-url (address) 4555(defun gnus-button-embedded-url (address)
3238 "Browse ADDRESS." 4556 "Browse ADDRESS."
3239 ;; In Emacs 20, `browse-url-browser-function' may be an alist.
3240 (browse-url (gnus-strip-whitespace address))) 4557 (browse-url (gnus-strip-whitespace address)))
3241 4558
3242;;; Next/prev buttons in the article buffer. 4559;;; Next/prev buttons in the article buffer.
@@ -3256,7 +4573,7 @@ forbidden in URL encoding."
3256 gnus-prev-page-line-format nil 4573 gnus-prev-page-line-format nil
3257 `(gnus-prev t local-map ,gnus-prev-page-map 4574 `(gnus-prev t local-map ,gnus-prev-page-map
3258 gnus-callback gnus-article-button-prev-page 4575 gnus-callback gnus-article-button-prev-page
3259 gnus-type annotation)))) 4576 article-type annotation))))
3260 4577
3261(defvar gnus-next-page-map nil) 4578(defvar gnus-next-page-map nil)
3262(unless gnus-next-page-map 4579(unless gnus-next-page-map
@@ -3287,7 +4604,7 @@ forbidden in URL encoding."
3287 `(gnus-next 4604 `(gnus-next
3288 t local-map ,gnus-next-page-map 4605 t local-map ,gnus-next-page-map
3289 gnus-callback gnus-article-button-next-page 4606 gnus-callback gnus-article-button-next-page
3290 gnus-type annotation)))) 4607 article-type annotation))))
3291 4608
3292(defun gnus-article-button-next-page (arg) 4609(defun gnus-article-button-next-page (arg)
3293 "Go to the next page." 4610 "Go to the next page."
@@ -3305,6 +4622,117 @@ forbidden in URL encoding."
3305 (gnus-article-prev-page) 4622 (gnus-article-prev-page)
3306 (select-window win))) 4623 (select-window win)))
3307 4624
4625(defvar gnus-decode-header-methods
4626 '(mail-decode-encoded-word-region)
4627 "List of methods used to decode headers.
4628
4629This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item
4630is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
4631(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
4632whose names match REGEXP.
4633
4634For example:
4635((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
4636 mail-decode-encoded-word-region
4637 (\"chinese\" . rfc1843-decode-region))
4638")
4639
4640(defvar gnus-decode-header-methods-cache nil)
4641
4642(defun gnus-multi-decode-header (start end)
4643 "Apply the functions from `gnus-encoded-word-methods' that match."
4644 (unless (and gnus-decode-header-methods-cache
4645 (eq gnus-newsgroup-name
4646 (car gnus-decode-header-methods-cache)))
4647 (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
4648 (mapcar (lambda (x)
4649 (if (symbolp x)
4650 (nconc gnus-decode-header-methods-cache (list x))
4651 (if (and gnus-newsgroup-name
4652 (string-match (car x) gnus-newsgroup-name))
4653 (nconc gnus-decode-header-methods-cache
4654 (list (cdr x))))))
4655 gnus-decode-header-methods))
4656 (let ((xlist gnus-decode-header-methods-cache))
4657 (pop xlist)
4658 (save-restriction
4659 (narrow-to-region start end)
4660 (while xlist
4661 (funcall (pop xlist) (point-min) (point-max))))))
4662
4663;;;
4664;;; Treatment top-level handling.
4665;;;
4666
4667(defun gnus-treat-article (condition &optional part-number total-parts type)
4668 (let ((length (- (point-max) (point-min)))
4669 (alist gnus-treatment-function-alist)
4670 (article-goto-body-goes-to-point-min-p t)
4671 (treated-type
4672 (or (not type)
4673 (catch 'found
4674 (let ((list gnus-article-treat-types))
4675 (while list
4676 (when (string-match (pop list) type)
4677 (throw 'found t)))))))
4678 (highlightp (gnus-visual-p 'article-highlight 'highlight))
4679 val elem)
4680 (gnus-run-hooks 'gnus-part-display-hook)
4681 (while (setq elem (pop alist))
4682 (setq val
4683 (save-excursion
4684 (if (gnus-buffer-live-p gnus-summary-buffer)
4685 (set-buffer gnus-summary-buffer))
4686 (symbol-value (car elem))))
4687 (when (and (or (consp val)
4688 treated-type)
4689 (gnus-treat-predicate val)
4690 (or (not (get (car elem) 'highlight))
4691 highlightp))
4692 (save-restriction
4693 (funcall (cadr elem)))))))
4694
4695;; Dynamic variables.
4696(defvar part-number)
4697(defvar total-parts)
4698(defvar type)
4699(defvar condition)
4700(defvar length)
4701(defun gnus-treat-predicate (val)
4702 (cond
4703 ((null val)
4704 nil)
4705 ((and (listp val)
4706 (stringp (car val)))
4707 (apply 'gnus-or (mapcar `(lambda (s)
4708 (string-match s ,(or gnus-newsgroup-name "")))
4709 val)))
4710 ((listp val)
4711 (let ((pred (pop val)))
4712 (cond
4713 ((eq pred 'or)
4714 (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
4715 ((eq pred 'and)
4716 (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
4717 ((eq pred 'not)
4718 (not (gnus-treat-predicate (car val))))
4719 ((eq pred 'typep)
4720 (equal (car val) type))
4721 (t
4722 (error "%S is not a valid predicate" pred)))))
4723 (condition
4724 (eq condition val))
4725 ((eq val t)
4726 t)
4727 ((eq val 'head)
4728 nil)
4729 ((eq val 'last)
4730 (eq part-number total-parts))
4731 ((numberp val)
4732 (< length val))
4733 (t
4734 (error "%S is not a valid value" val))))
4735
3308(gnus-ems-redefine) 4736(gnus-ems-redefine)
3309 4737
3310(provide 'gnus-art) 4738(provide 'gnus-art)
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index c881f5976d9..0aead88df25 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -1,5 +1,6 @@
1;;; gnus-group.el --- group mode commands for Gnus 1;;; gnus-group.el --- group mode commands for Gnus
2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. 2;; Copyright (C) 1996, 1997, 1998, 1999, 2000
3;; Free Software Foundation, Inc.
3 4
4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 6;; Keywords: news
@@ -27,8 +28,6 @@
27 28
28(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
29 30
30(eval-when-compile (require 'cl))
31
32(require 'gnus) 31(require 'gnus)
33(require 'gnus-start) 32(require 'gnus-start)
34(require 'nnmail) 33(require 'nnmail)
@@ -37,6 +36,7 @@
37(require 'gnus-range) 36(require 'gnus-range)
38(require 'gnus-win) 37(require 'gnus-win)
39(require 'gnus-undo) 38(require 'gnus-undo)
39(require 'time-date)
40 40
41(defcustom gnus-group-archive-directory 41(defcustom gnus-group-archive-directory
42 "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" 42 "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
@@ -50,7 +50,7 @@
50 :group 'gnus-group-foreign 50 :group 'gnus-group-foreign
51 :type 'directory) 51 :type 'directory)
52 52
53(defcustom gnus-no-groups-message "No news is no news" 53(defcustom gnus-no-groups-message "No gnus is bad news"
54 "*Message displayed by Gnus when no groups are available." 54 "*Message displayed by Gnus when no groups are available."
55 :group 'gnus-start 55 :group 'gnus-start
56 :type 'string) 56 :type 'string)
@@ -162,6 +162,7 @@ with some simple extensions.
162%n Select from where (string) 162%n Select from where (string)
163%z A string that look like `<%s:%n>' if a foreign select method is used 163%z A string that look like `<%s:%n>' if a foreign select method is used
164%d The date the group was last entered. 164%d The date the group was last entered.
165%E Icon as defined by `gnus-group-icon-list'.
165%u User defined specifier. The next character in the format string should 166%u User defined specifier. The next character in the format string should
166 be a letter. Gnus will call the function gnus-user-format-function-X, 167 be a letter. Gnus will call the function gnus-user-format-function-X,
167 where X is the letter following %u. The function will be passed the 168 where X is the letter following %u. The function will be passed the
@@ -300,6 +301,18 @@ variable."
300 gnus-group-news-3-empty-face) 301 gnus-group-news-3-empty-face)
301 ((and (not mailp) (eq level 3)) . 302 ((and (not mailp) (eq level 3)) .
302 gnus-group-news-3-face) 303 gnus-group-news-3-face)
304 ((and (= unread 0) (not mailp) (eq level 4)) .
305 gnus-group-news-4-empty-face)
306 ((and (not mailp) (eq level 4)) .
307 gnus-group-news-4-face)
308 ((and (= unread 0) (not mailp) (eq level 5)) .
309 gnus-group-news-5-empty-face)
310 ((and (not mailp) (eq level 5)) .
311 gnus-group-news-5-face)
312 ((and (= unread 0) (not mailp) (eq level 6)) .
313 gnus-group-news-6-empty-face)
314 ((and (not mailp) (eq level 6)) .
315 gnus-group-news-6-face)
303 ((and (= unread 0) (not mailp)) . 316 ((and (= unread 0) (not mailp)) .
304 gnus-group-news-low-empty-face) 317 gnus-group-news-low-empty-face)
305 ((and (not mailp)) . 318 ((and (not mailp)) .
@@ -320,7 +333,7 @@ variable."
320 ((= unread 0) . 333 ((= unread 0) .
321 gnus-group-mail-low-empty-face) 334 gnus-group-mail-low-empty-face)
322 (t . 335 (t .
323 gnus-group-mail-low-face)) 336 gnus-group-mail-low-face))
324 "*Controls the highlighting of group buffer lines. 337 "*Controls the highlighting of group buffer lines.
325 338
326Below is a list of `Form'/`Face' pairs. When deciding how a a 339Below is a list of `Form'/`Face' pairs. When deciding how a a
@@ -349,6 +362,56 @@ ticked: The number of ticked articles."
349 :group 'gnus-group-visual 362 :group 'gnus-group-visual
350 :type 'character) 363 :type 'character)
351 364
365(defgroup gnus-group-icons nil
366 "Add Icons to your group buffer. "
367 :group 'gnus-group-visual)
368
369(defcustom gnus-group-icon-list
370 nil
371 "*Controls the insertion of icons into group buffer lines.
372
373Below is a list of `Form'/`File' pairs. When deciding how a
374particular group line should be displayed, each form is evaluated.
375The icon from the file field after the first true form is used. You
376can change how those group lines are displayed by editing the file
377field. The File will either be found in the
378`gnus-group-glyph-directory' or by designating absolute path to the
379file.
380
381It is also possible to change and add form fields, but currently that
382requires an understanding of Lisp expressions. Hopefully this will
383change in a future release. For now, you can use the following
384variables in the Lisp expression:
385
386group: The name of the group.
387unread: The number of unread articles in the group.
388method: The select method used.
389mailp: Whether it's a mail group or not.
390newsp: Whether it's a news group or not
391level: The level of the group.
392score: The score of the group.
393ticked: The number of ticked articles."
394 :group 'gnus-group-icons
395 :type '(repeat (cons (sexp :tag "Form") file)))
396
397(defcustom gnus-group-name-charset-method-alist nil
398 "*Alist of method and the charset for group names.
399
400For example:
401 (((nntp \"news.com.cn\") . cn-gb-2312))
402"
403 :group 'gnus-charset
404 :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset"))))
405
406(defcustom gnus-group-name-charset-group-alist nil
407 "*Alist of group regexp and the charset for group names.
408
409For example:
410 ((\"\\.com\\.cn:\" . cn-gb-2312))
411"
412 :group 'gnus-charset
413 :type '(repeat (cons (regexp :tag "Group") (symbol :tag "Charset"))))
414
352;;; Internal variables 415;;; Internal variables
353 416
354(defvar gnus-group-sort-alist-function 'gnus-group-sort-flat 417(defvar gnus-group-sort-alist-function 'gnus-group-sort-flat
@@ -393,6 +456,7 @@ ticked: The number of ticked articles."
393 (?s gnus-tmp-news-server ?s) 456 (?s gnus-tmp-news-server ?s)
394 (?n gnus-tmp-news-method ?s) 457 (?n gnus-tmp-news-method ?s)
395 (?P gnus-group-indentation ?s) 458 (?P gnus-group-indentation ?s)
459 (?E gnus-tmp-group-icon ?s)
396 (?l gnus-tmp-grouplens ?s) 460 (?l gnus-tmp-grouplens ?s)
397 (?z gnus-tmp-news-method-string ?s) 461 (?z gnus-tmp-news-method-string ?s)
398 (?m (gnus-group-new-mail gnus-tmp-group) ?c) 462 (?m (gnus-group-new-mail gnus-tmp-group) ?c)
@@ -415,6 +479,9 @@ ticked: The number of ticked articles."
415 479
416(defvar gnus-group-list-mode nil) 480(defvar gnus-group-list-mode nil)
417 481
482
483(defvar gnus-group-icon-cache nil)
484
418;;; 485;;;
419;;; Gnus group mode 486;;; Gnus group mode
420;;; 487;;;
@@ -427,6 +494,7 @@ ticked: The number of ticked articles."
427 "=" gnus-group-select-group 494 "=" gnus-group-select-group
428 "\r" gnus-group-select-group 495 "\r" gnus-group-select-group
429 "\M-\r" gnus-group-quick-select-group 496 "\M-\r" gnus-group-quick-select-group
497 "\M- " gnus-group-visible-select-group
430 [(meta control return)] gnus-group-select-group-ephemerally 498 [(meta control return)] gnus-group-select-group-ephemerally
431 "j" gnus-group-jump-to-group 499 "j" gnus-group-jump-to-group
432 "n" gnus-group-next-unread-group 500 "n" gnus-group-next-unread-group
@@ -503,6 +571,7 @@ ticked: The number of ticked articles."
503 "u" gnus-group-make-useful-group 571 "u" gnus-group-make-useful-group
504 "a" gnus-group-make-archive-group 572 "a" gnus-group-make-archive-group
505 "k" gnus-group-make-kiboze-group 573 "k" gnus-group-make-kiboze-group
574 "l" gnus-group-nnimap-edit-acl
506 "m" gnus-group-make-group 575 "m" gnus-group-make-group
507 "E" gnus-group-edit-group 576 "E" gnus-group-edit-group
508 "e" gnus-group-edit-group-method 577 "e" gnus-group-edit-group-method
@@ -514,6 +583,7 @@ ticked: The number of ticked articles."
514 "w" gnus-group-make-web-group 583 "w" gnus-group-make-web-group
515 "r" gnus-group-rename-group 584 "r" gnus-group-rename-group
516 "c" gnus-group-customize 585 "c" gnus-group-customize
586 "x" gnus-group-nnimap-expunge
517 "\177" gnus-group-delete-group 587 "\177" gnus-group-delete-group
518 [delete] gnus-group-delete-group) 588 [delete] gnus-group-delete-group)
519 589
@@ -552,7 +622,9 @@ ticked: The number of ticked articles."
552 "d" gnus-group-description-apropos 622 "d" gnus-group-description-apropos
553 "m" gnus-group-list-matching 623 "m" gnus-group-list-matching
554 "M" gnus-group-list-all-matching 624 "M" gnus-group-list-all-matching
555 "l" gnus-group-list-level) 625 "l" gnus-group-list-level
626 "c" gnus-group-list-cached
627 "?" gnus-group-list-dormant)
556 628
557 (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) 629 (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
558 "f" gnus-score-flush-cache) 630 "f" gnus-score-flush-cache)
@@ -628,7 +700,9 @@ ticked: The number of ticked articles."
628 ["Group and description apropos..." gnus-group-description-apropos t] 700 ["Group and description apropos..." gnus-group-description-apropos t]
629 ["List groups matching..." gnus-group-list-matching t] 701 ["List groups matching..." gnus-group-list-matching t]
630 ["List all groups matching..." gnus-group-list-all-matching t] 702 ["List all groups matching..." gnus-group-list-all-matching t]
631 ["List active file" gnus-group-list-active t]) 703 ["List active file" gnus-group-list-active t]
704 ["List groups with cached" gnus-group-list-cached t]
705 ["List groups with dormant" gnus-group-list-dormant t])
632 ("Sort" 706 ("Sort"
633 ["Default sort" gnus-group-sort-groups t] 707 ["Default sort" gnus-group-sort-groups t]
634 ["Sort by method" gnus-group-sort-groups-by-method t] 708 ["Sort by method" gnus-group-sort-groups-by-method t]
@@ -714,7 +788,6 @@ ticked: The number of ticked articles."
714 ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] 788 ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)]
715 ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] 789 ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
716 ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) 790 ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)])
717 ["Send a bug report" gnus-bug t]
718 ["Send a mail" gnus-group-mail t] 791 ["Send a mail" gnus-group-mail t]
719 ["Post an article..." gnus-group-post-news t] 792 ["Post an article..." gnus-group-post-news t]
720 ["Check for new news" gnus-group-get-new-news t] 793 ["Check for new news" gnus-group-get-new-news t]
@@ -765,14 +838,12 @@ The following commands are available:
765 (gnus-group-set-mode-line) 838 (gnus-group-set-mode-line)
766 (setq mode-line-process nil) 839 (setq mode-line-process nil)
767 (use-local-map gnus-group-mode-map) 840 (use-local-map gnus-group-mode-map)
768 (buffer-disable-undo (current-buffer)) 841 (buffer-disable-undo)
769 (setq truncate-lines t) 842 (setq truncate-lines t)
770 (setq buffer-read-only t) 843 (setq buffer-read-only t)
771 (gnus-set-default-directory) 844 (gnus-set-default-directory)
772 (gnus-update-format-specifications nil 'group 'group-mode) 845 (gnus-update-format-specifications nil 'group 'group-mode)
773 (gnus-update-group-mark-positions) 846 (gnus-update-group-mark-positions)
774 (make-local-hook 'post-command-hook)
775 (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
776 (when gnus-use-undo 847 (when gnus-use-undo
777 (gnus-undo-mode 1)) 848 (gnus-undo-mode 1))
778 (when gnus-slave 849 (when gnus-slave
@@ -793,9 +864,6 @@ The following commands are available:
793 (list (cons 'process (and (search-forward "\200" nil t) 864 (list (cons 'process (and (search-forward "\200" nil t)
794 (- (point) 2)))))))) 865 (- (point) 2))))))))
795 866
796(defun gnus-clear-inboxes-moved ()
797 (setq nnmail-moved-inboxes nil))
798
799(defun gnus-mouse-pick-group (e) 867(defun gnus-mouse-pick-group (e)
800 "Enter the group under the mouse pointer." 868 "Enter the group under the mouse pointer."
801 (interactive "e") 869 (interactive "e")
@@ -826,6 +894,29 @@ The following commands are available:
826 (when gnus-carpal 894 (when gnus-carpal
827 (gnus-carpal-setup-buffer 'group)))) 895 (gnus-carpal-setup-buffer 'group))))
828 896
897(defsubst gnus-group-name-charset (method group)
898 (if (null method)
899 (setq method (gnus-find-method-for-group group)))
900 (let ((item (assoc method gnus-group-name-charset-method-alist))
901 (alist gnus-group-name-charset-group-alist)
902 result)
903 (if item
904 (cdr item)
905 (while (setq item (pop alist))
906 (if (string-match (car item) group)
907 (setq alist nil
908 result (cdr item))))
909 result)))
910
911(defsubst gnus-group-name-decode (string charset)
912 (if (and string charset (featurep 'mule))
913 (mm-decode-coding-string string charset)
914 string))
915
916(defun gnus-group-decoded-name (string)
917 (let ((charset (gnus-group-name-charset nil string)))
918 (gnus-group-name-decode string charset)))
919
829(defun gnus-group-list-groups (&optional level unread lowest) 920(defun gnus-group-list-groups (&optional level unread lowest)
830 "List newsgroups with level LEVEL or lower that have unread articles. 921 "List newsgroups with level LEVEL or lower that have unread articles.
831Default is all subscribed groups. 922Default is all subscribed groups.
@@ -840,8 +931,6 @@ Also see the `gnus-group-use-permanent-levels' variable."
840 (gnus-group-default-level nil t) 931 (gnus-group-default-level nil t)
841 gnus-group-default-list-level 932 gnus-group-default-list-level
842 gnus-level-subscribed)))) 933 gnus-level-subscribed))))
843 ;; Just do this here, for no particular good reason.
844 (gnus-clear-inboxes-moved)
845 (unless level 934 (unless level
846 (setq level (car gnus-group-list-mode) 935 (setq level (car gnus-group-list-mode)
847 unread (cdr gnus-group-list-mode))) 936 unread (cdr gnus-group-list-mode)))
@@ -920,7 +1009,7 @@ If REGEXP, only list groups matching REGEXP."
920 params (gnus-info-params info) 1009 params (gnus-info-params info)
921 newsrc (cdr newsrc) 1010 newsrc (cdr newsrc)
922 unread (car (gnus-gethash group gnus-newsrc-hashtb))) 1011 unread (car (gnus-gethash group gnus-newsrc-hashtb)))
923 (and unread ; This group might be bogus 1012 (and unread ; This group might be unchecked
924 (or (not regexp) 1013 (or (not regexp)
925 (string-match regexp group)) 1014 (string-match regexp group))
926 (<= (setq clevel (gnus-info-level info)) level) 1015 (<= (setq clevel (gnus-info-level info)) level)
@@ -971,16 +1060,24 @@ If REGEXP, only list groups matching REGEXP."
971 (when (string-match regexp group) 1060 (when (string-match regexp group)
972 (gnus-add-text-properties 1061 (gnus-add-text-properties
973 (point) (prog1 (1+ (point)) 1062 (point) (prog1 (1+ (point))
974 (insert " " mark " *: " group "\n")) 1063 (insert " " mark " *: "
1064 (gnus-group-name-decode group
1065 (gnus-group-name-charset
1066 nil group))
1067 "\n"))
975 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 1068 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
976 'gnus-unread t 1069 'gnus-unread t
977 'gnus-level level)))) 1070 'gnus-level level))))
978 ;; This loop is used when listing all groups. 1071 ;; This loop is used when listing all groups.
979 (while groups 1072 (while groups
1073 (setq group (pop groups))
980 (gnus-add-text-properties 1074 (gnus-add-text-properties
981 (point) (prog1 (1+ (point)) 1075 (point) (prog1 (1+ (point))
982 (insert " " mark " *: " 1076 (insert " " mark " *: "
983 (setq group (pop groups)) "\n")) 1077 (gnus-group-name-decode group
1078 (gnus-group-name-charset
1079 nil group))
1080 "\n"))
984 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 1081 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
985 'gnus-unread t 1082 'gnus-unread t
986 'gnus-level level)))))) 1083 'gnus-level level))))))
@@ -1032,7 +1129,11 @@ If REGEXP, only list groups matching REGEXP."
1032 gnus-tmp-marked number 1129 gnus-tmp-marked number
1033 gnus-tmp-method) 1130 gnus-tmp-method)
1034 "Insert a group line in the group buffer." 1131 "Insert a group line in the group buffer."
1035 (let* ((gnus-tmp-active (gnus-active gnus-tmp-group)) 1132 (let* ((gnus-tmp-method
1133 (gnus-server-get-method gnus-tmp-group gnus-tmp-method))
1134 (group-name-charset (gnus-group-name-charset gnus-tmp-method
1135 gnus-tmp-group))
1136 (gnus-tmp-active (gnus-active gnus-tmp-group))
1036 (gnus-tmp-number-total 1137 (gnus-tmp-number-total
1037 (if gnus-tmp-active 1138 (if gnus-tmp-active
1038 (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active))) 1139 (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active)))
@@ -1049,10 +1150,14 @@ If REGEXP, only list groups matching REGEXP."
1049 ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) 1150 ((<= gnus-tmp-level gnus-level-unsubscribed) ?U)
1050 ((= gnus-tmp-level gnus-level-zombie) ?Z) 1151 ((= gnus-tmp-level gnus-level-zombie) ?Z)
1051 (t ?K))) 1152 (t ?K)))
1052 (gnus-tmp-qualified-group (gnus-group-real-name gnus-tmp-group)) 1153 (gnus-tmp-qualified-group
1154 (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group)
1155 group-name-charset))
1053 (gnus-tmp-newsgroup-description 1156 (gnus-tmp-newsgroup-description
1054 (if gnus-description-hashtb 1157 (if gnus-description-hashtb
1055 (or (gnus-gethash gnus-tmp-group gnus-description-hashtb) "") 1158 (or (gnus-group-name-decode
1159 (gnus-gethash gnus-tmp-group gnus-description-hashtb)
1160 group-name-charset) "")
1056 "")) 1161 ""))
1057 (gnus-tmp-moderated 1162 (gnus-tmp-moderated
1058 (if (and gnus-moderated-hashtb 1163 (if (and gnus-moderated-hashtb
@@ -1060,8 +1165,7 @@ If REGEXP, only list groups matching REGEXP."
1060 ?m ? )) 1165 ?m ? ))
1061 (gnus-tmp-moderated-string 1166 (gnus-tmp-moderated-string
1062 (if (eq gnus-tmp-moderated ?m) "(m)" "")) 1167 (if (eq gnus-tmp-moderated ?m) "(m)" ""))
1063 (gnus-tmp-method 1168 (gnus-tmp-group-icon "==&&==")
1064 (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ;
1065 (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) 1169 (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
1066 (gnus-tmp-news-method (or (car gnus-tmp-method) "")) 1170 (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
1067 (gnus-tmp-news-method-string 1171 (gnus-tmp-news-method-string
@@ -1095,10 +1199,10 @@ If REGEXP, only list groups matching REGEXP."
1095 gnus-marked ,gnus-tmp-marked-mark 1199 gnus-marked ,gnus-tmp-marked-mark
1096 gnus-indentation ,gnus-group-indentation 1200 gnus-indentation ,gnus-group-indentation
1097 gnus-level ,gnus-tmp-level)) 1201 gnus-level ,gnus-tmp-level))
1202 (forward-line -1)
1098 (when (inline (gnus-visual-p 'group-highlight 'highlight)) 1203 (when (inline (gnus-visual-p 'group-highlight 'highlight))
1099 (forward-line -1) 1204 (gnus-run-hooks 'gnus-group-update-hook))
1100 (gnus-run-hooks 'gnus-group-update-hook) 1205 (forward-line)
1101 (forward-line))
1102 ;; Allow XEmacs to remove front-sticky text properties. 1206 ;; Allow XEmacs to remove front-sticky text properties.
1103 (gnus-group-remove-excess-properties))) 1207 (gnus-group-remove-excess-properties)))
1104 1208
@@ -1317,6 +1421,12 @@ If FIRST-TOO, the current line is also eligible as a target."
1317 1421
1318;; Group marking. 1422;; Group marking.
1319 1423
1424(defun gnus-group-mark-line-p ()
1425 (save-excursion
1426 (beginning-of-line)
1427 (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
1428 (eq (char-after) gnus-process-mark)))
1429
1320(defun gnus-group-mark-group (n &optional unmark no-advance) 1430(defun gnus-group-mark-group (n &optional unmark no-advance)
1321 "Mark the current group." 1431 "Mark the current group."
1322 (interactive "p") 1432 (interactive "p")
@@ -1329,7 +1439,7 @@ If FIRST-TOO, the current line is also eligible as a target."
1329 (beginning-of-line) 1439 (beginning-of-line)
1330 (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) 1440 (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
1331 (subst-char-in-region 1441 (subst-char-in-region
1332 (point) (1+ (point)) (following-char) 1442 (point) (1+ (point)) (char-after)
1333 (if unmark 1443 (if unmark
1334 (progn 1444 (progn
1335 (setq gnus-group-marked (delete group gnus-group-marked)) 1445 (setq gnus-group-marked (delete group gnus-group-marked))
@@ -1383,10 +1493,10 @@ If UNMARK, remove the mark instead."
1383 (gnus-group-set-mark group)))) 1493 (gnus-group-set-mark group))))
1384 (gnus-group-position-point)) 1494 (gnus-group-position-point))
1385 1495
1386(defun gnus-group-remove-mark (group) 1496(defun gnus-group-remove-mark (group &optional test-marked)
1387 "Remove the process mark from GROUP and move point there. 1497 "Remove the process mark from GROUP and move point there.
1388Return nil if the group isn't displayed." 1498Return nil if the group isn't displayed."
1389 (if (gnus-group-goto-group group) 1499 (if (gnus-group-goto-group group nil test-marked)
1390 (save-excursion 1500 (save-excursion
1391 (gnus-group-mark-group 1 'unmark t) 1501 (gnus-group-mark-group 1 'unmark t)
1392 t) 1502 t)
@@ -1465,12 +1575,14 @@ Take into consideration N (the prefix) and the list of marked groups."
1465 (eval 1575 (eval
1466 `(defun gnus-group-iterate (arg ,function) 1576 `(defun gnus-group-iterate (arg ,function)
1467 "Iterate FUNCTION over all process/prefixed groups. 1577 "Iterate FUNCTION over all process/prefixed groups.
1468FUNCTION will be called with the group name as the paremeter 1578FUNCTION will be called with the group name as the parameter
1469and with point over the group in question." 1579and with point over the group in question."
1470 (let ((,groups (gnus-group-process-prefix arg)) 1580 (let ((,groups (gnus-group-process-prefix arg))
1471 (,window (selected-window)) 1581 (,window (selected-window))
1472 ,group) 1582 ,group)
1473 (while (setq ,group (pop ,groups)) 1583 (while ,groups
1584 (setq ,group (car ,groups)
1585 ,groups (cdr ,groups))
1474 (select-window ,window) 1586 (select-window ,window)
1475 (gnus-group-remove-mark ,group) 1587 (gnus-group-remove-mark ,group)
1476 (save-selected-window 1588 (save-selected-window
@@ -1565,7 +1677,7 @@ be permanent."
1565(defun gnus-fetch-group (group) 1677(defun gnus-fetch-group (group)
1566 "Start Gnus if necessary and enter GROUP. 1678 "Start Gnus if necessary and enter GROUP.
1567Returns whether the fetching was successful or not." 1679Returns whether the fetching was successful or not."
1568 (interactive "sGroup name: ") 1680 (interactive (list (completing-read "Group name: " gnus-active-hashtb)))
1569 (unless (get-buffer gnus-group-buffer) 1681 (unless (get-buffer gnus-group-buffer)
1570 (gnus-no-server)) 1682 (gnus-no-server))
1571 (gnus-group-read-group nil nil group)) 1683 (gnus-group-read-group nil nil group))
@@ -1597,7 +1709,7 @@ ephemeral group.
1597If REQUEST-ONLY, don't actually read the group; just request it. 1709If REQUEST-ONLY, don't actually read the group; just request it.
1598If SELECT-ARTICLES, only select those articles. 1710If SELECT-ARTICLES, only select those articles.
1599 1711
1600Return the name of the group is selection was successful." 1712Return the name of the group if selection was successful."
1601 ;; Transform the select method into a unique server. 1713 ;; Transform the select method into a unique server.
1602 (when (stringp method) 1714 (when (stringp method)
1603 (setq method (gnus-server-to-method method))) 1715 (setq method (gnus-server-to-method method)))
@@ -1654,41 +1766,56 @@ Return the name of the group is selection was successful."
1654 ;; Adjust cursor point. 1766 ;; Adjust cursor point.
1655 (gnus-group-position-point)) 1767 (gnus-group-position-point))
1656 1768
1657(defun gnus-group-goto-group (group &optional far) 1769(defun gnus-group-goto-group (group &optional far test-marked)
1658 "Goto to newsgroup GROUP. 1770 "Goto to newsgroup GROUP.
1659If FAR, it is likely that the group is not on the current line." 1771If FAR, it is likely that the group is not on the current line.
1772If TEST-MARKED, the line must be marked."
1660 (when group 1773 (when group
1661 (if far 1774 (beginning-of-line)
1662 (gnus-goto-char 1775 (cond
1663 (text-property-any 1776 ;; It's quite likely that we are on the right line, so
1664 (point-min) (point-max) 1777 ;; we check the current line first.
1665 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) 1778 ((and (not far)
1666 (beginning-of-line) 1779 (eq (get-text-property (point) 'gnus-group)
1667 (cond 1780 (gnus-intern-safe group gnus-active-hashtb))
1668 ;; It's quite likely that we are on the right line, so 1781 (or (not test-marked) (gnus-group-mark-line-p)))
1669 ;; we check the current line first. 1782 (point))
1670 ((eq (get-text-property (point) 'gnus-group) 1783 ;; Previous and next line are also likely, so we check them as well.
1671 (gnus-intern-safe group gnus-active-hashtb)) 1784 ((and (not far)
1672 (point)) 1785 (save-excursion
1673 ;; Previous and next line are also likely, so we check them as well. 1786 (forward-line -1)
1674 ((save-excursion 1787 (and (eq (get-text-property (point) 'gnus-group)
1675 (forward-line -1) 1788 (gnus-intern-safe group gnus-active-hashtb))
1676 (eq (get-text-property (point) 'gnus-group) 1789 (or (not test-marked) (gnus-group-mark-line-p)))))
1677 (gnus-intern-safe group gnus-active-hashtb))) 1790 (forward-line -1)
1678 (forward-line -1) 1791 (point))
1679 (point)) 1792 ((and (not far)
1680 ((save-excursion 1793 (save-excursion
1681 (forward-line 1) 1794 (forward-line 1)
1682 (eq (get-text-property (point) 'gnus-group) 1795 (and (eq (get-text-property (point) 'gnus-group)
1683 (gnus-intern-safe group gnus-active-hashtb))) 1796 (gnus-intern-safe group gnus-active-hashtb))
1684 (forward-line 1) 1797 (or (not test-marked) (gnus-group-mark-line-p)))))
1685 (point)) 1798 (forward-line 1)
1686 (t 1799 (point))
1687 ;; Search through the entire buffer. 1800 (test-marked
1688 (gnus-goto-char 1801 (goto-char (point-min))
1689 (text-property-any 1802 (let (found)
1690 (point-min) (point-max) 1803 (while (and (not found)
1691 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))) 1804 (gnus-goto-char
1805 (text-property-any
1806 (point) (point-max)
1807 'gnus-group
1808 (gnus-intern-safe group gnus-active-hashtb))))
1809 (if (gnus-group-mark-line-p)
1810 (setq found t)
1811 (forward-line 1)))
1812 found))
1813 (t
1814 ;; Search through the entire buffer.
1815 (gnus-goto-char
1816 (text-property-any
1817 (point-min) (point-max)
1818 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))
1692 1819
1693(defun gnus-group-next-group (n &optional silent) 1820(defun gnus-group-next-group (n &optional silent)
1694 "Go to next N'th newsgroup. 1821 "Go to next N'th newsgroup.
@@ -1804,11 +1931,12 @@ ADDRESS."
1804 (gnus-read-method "From method: "))) 1931 (gnus-read-method "From method: ")))
1805 1932
1806 (when (stringp method) 1933 (when (stringp method)
1807 (setq method (gnus-server-to-method method))) 1934 (setq method (or (gnus-server-to-method method) method)))
1808 (let* ((meth (when (and method 1935 (let* ((meth (gnus-method-simplify
1809 (not (gnus-server-equal method gnus-select-method))) 1936 (when (and method
1810 (if address (list (intern method) address) 1937 (not (gnus-server-equal method gnus-select-method)))
1811 method))) 1938 (if address (list (intern method) address)
1939 method))))
1812 (nname (if method (gnus-group-prefixed-name name meth) name)) 1940 (nname (if method (gnus-group-prefixed-name name meth) name))
1813 backend info) 1941 backend info)
1814 (when (gnus-gethash nname gnus-newsrc-hashtb) 1942 (when (gnus-gethash nname gnus-newsrc-hashtb)
@@ -1843,8 +1971,20 @@ ADDRESS."
1843 (gnus-request-create-group nname nil args)) 1971 (gnus-request-create-group nname nil args))
1844 t)) 1972 t))
1845 1973
1846(defun gnus-group-delete-group (group &optional force) 1974(defun gnus-group-delete-groups (&optional arg)
1847 "Delete the current group. Only meaningful with mail groups. 1975 "Delete the current group. Only meaningful with editable groups."
1976 (interactive "P")
1977 (let ((n (length (gnus-group-process-prefix arg))))
1978 (when (gnus-yes-or-no-p
1979 (if (= n 1)
1980 "Delete this 1 group? "
1981 (format "Delete these %d groups? " n)))
1982 (gnus-group-iterate arg
1983 (lambda (group)
1984 (gnus-group-delete-group group nil t))))))
1985
1986(defun gnus-group-delete-group (group &optional force no-prompt)
1987 "Delete the current group. Only meaningful with editable groups.
1848If FORCE (the prefix) is non-nil, all the articles in the group will 1988If FORCE (the prefix) is non-nil, all the articles in the group will
1849be deleted. This is \"deleted\" as in \"removed forever from the face 1989be deleted. This is \"deleted\" as in \"removed forever from the face
1850of the Earth\". There is no undo. The user will be prompted before 1990of the Earth\". There is no undo. The user will be prompted before
@@ -1857,10 +1997,11 @@ doing the deletion."
1857 (unless (gnus-check-backend-function 'request-delete-group group) 1997 (unless (gnus-check-backend-function 'request-delete-group group)
1858 (error "This backend does not support group deletion")) 1998 (error "This backend does not support group deletion"))
1859 (prog1 1999 (prog1
1860 (if (not (gnus-yes-or-no-p 2000 (if (and (not no-prompt)
1861 (format 2001 (not (gnus-yes-or-no-p
1862 "Do you really want to delete %s%s? " 2002 (format
1863 group (if force " and all its contents" "")))) 2003 "Do you really want to delete %s%s? "
2004 group (if force " and all its contents" "")))))
1864 () ; Whew! 2005 () ; Whew!
1865 (gnus-message 6 "Deleting group %s..." group) 2006 (gnus-message 6 "Deleting group %s..." group)
1866 (if (not (gnus-request-delete-group group force)) 2007 (if (not (gnus-request-delete-group group force))
@@ -1905,10 +2046,12 @@ and NEW-NAME will be prompted for."
1905 2046
1906 (gnus-message 6 "Renaming group %s to %s..." group new-name) 2047 (gnus-message 6 "Renaming group %s to %s..." group new-name)
1907 (prog1 2048 (prog1
1908 (if (not (gnus-request-rename-group group new-name)) 2049 (if (progn
2050 (gnus-group-goto-group group)
2051 (not (when (< (gnus-group-group-level) gnus-level-zombie)
2052 (gnus-request-rename-group group new-name))))
1909 (gnus-error 3 "Couldn't rename group %s to %s" group new-name) 2053 (gnus-error 3 "Couldn't rename group %s to %s" group new-name)
1910 ;; We rename the group internally by killing it... 2054 ;; We rename the group internally by killing it...
1911 (gnus-group-goto-group group)
1912 (gnus-group-kill-group) 2055 (gnus-group-kill-group)
1913 ;; ... changing its name ... 2056 ;; ... changing its name ...
1914 (setcar (cdar gnus-list-of-killed-groups) new-name) 2057 (setcar (cdar gnus-list-of-killed-groups) new-name)
@@ -1947,7 +2090,7 @@ and NEW-NAME will be prompted for."
1947 ((eq part 'method) "select method") 2090 ((eq part 'method) "select method")
1948 ((eq part 'params) "group parameters") 2091 ((eq part 'params) "group parameters")
1949 (t "group info")) 2092 (t "group info"))
1950 group) 2093 (gnus-group-decoded-name group))
1951 `(lambda (form) 2094 `(lambda (form)
1952 (gnus-group-edit-group-done ',part ,group form))))) 2095 (gnus-group-edit-group-done ',part ,group form)))))
1953 2096
@@ -2043,6 +2186,7 @@ and NEW-NAME will be prompted for."
2043 ((= char ?d) 'digest) 2186 ((= char ?d) 'digest)
2044 ((= char ?f) 'forward) 2187 ((= char ?f) 'forward)
2045 ((= char ?a) 'mmfd) 2188 ((= char ?a) 'mmfd)
2189 ((= char ?g) 'guess)
2046 (t (setq err (format "%c unknown. " char)) 2190 (t (setq err (format "%c unknown. " char))
2047 nil)))) 2191 nil))))
2048 (setq type found))) 2192 (setq type found)))
@@ -2093,6 +2237,42 @@ If SOLID (the prefix), create a solid group."
2093 (cons (current-buffer) 2237 (cons (current-buffer)
2094 (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) 2238 (if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
2095 2239
2240(defvar nnwarchive-type-definition)
2241(defvar gnus-group-warchive-type-history nil)
2242(defvar gnus-group-warchive-login-history nil)
2243(defvar gnus-group-warchive-address-history nil)
2244
2245(defun gnus-group-make-warchive-group ()
2246 "Create a nnwarchive group."
2247 (interactive)
2248 (require 'nnwarchive)
2249 (let* ((group (gnus-read-group "Group name: "))
2250 (default-type (or (car gnus-group-warchive-type-history)
2251 (symbol-name (caar nnwarchive-type-definition))))
2252 (type
2253 (gnus-string-or
2254 (completing-read
2255 (format "Warchive type (default %s): " default-type)
2256 (mapcar (lambda (elem) (list (symbol-name (car elem))))
2257 nnwarchive-type-definition)
2258 nil t nil 'gnus-group-warchive-type-history)
2259 default-type))
2260 (address (read-string "Warchive address: "
2261 nil 'gnus-group-warchive-address-history))
2262 (default-login (or (car gnus-group-warchive-login-history)
2263 user-mail-address))
2264 (login
2265 (gnus-string-or
2266 (read-string
2267 (format "Warchive login (default %s): " user-mail-address)
2268 default-login 'gnus-group-warchive-login-history)
2269 user-mail-address))
2270 (method
2271 `(nnwarchive ,address
2272 (nnwarchive-type ,(intern type))
2273 (nnwarchive-login ,login))))
2274 (gnus-group-make-group group method)))
2275
2096(defun gnus-group-make-archive-group (&optional all) 2276(defun gnus-group-make-archive-group (&optional all)
2097 "Create the (ding) Gnus archive group of the most recent articles. 2277 "Create the (ding) Gnus archive group of the most recent articles.
2098Given a prefix, create a full group." 2278Given a prefix, create a full group."
@@ -2157,9 +2337,13 @@ score file entries for articles to include in the group."
2157 (push (cons header regexps) scores)) 2337 (push (cons header regexps) scores))
2158 scores))) 2338 scores)))
2159 (gnus-group-make-group group "nnkiboze" address) 2339 (gnus-group-make-group group "nnkiboze" address)
2160 (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group)) 2340 (let* ((score-file (gnus-score-file-name (concat "nnkiboze:" group)))
2161 (let (emacs-lisp-mode-hook) 2341 (score-dir (file-name-directory score-file)))
2162 (pp scores (current-buffer))))) 2342 (unless (file-exists-p score-dir)
2343 (make-directory score-dir))
2344 (with-temp-file score-file
2345 (let (emacs-lisp-mode-hook)
2346 (pp scores (current-buffer))))))
2163 2347
2164(defun gnus-group-add-to-virtual (n vgroup) 2348(defun gnus-group-add-to-virtual (n vgroup)
2165 "Add the current group to a virtual group." 2349 "Add the current group to a virtual group."
@@ -2211,6 +2395,62 @@ score file entries for articles to include in the group."
2211 'summary 'group))) 2395 'summary 'group)))
2212 (error "Couldn't enter %s" dir)))) 2396 (error "Couldn't enter %s" dir))))
2213 2397
2398(eval-and-compile
2399 (autoload 'nnimap-expunge "nnimap")
2400 (autoload 'nnimap-acl-get "nnimap")
2401 (autoload 'nnimap-acl-edit "nnimap"))
2402
2403(defun gnus-group-nnimap-expunge (group)
2404 "Expunge deleted articles in current nnimap GROUP."
2405 (interactive (list (gnus-group-group-name)))
2406 (let ((mailbox (gnus-group-real-name group)) method)
2407 (unless group
2408 (error "No group on current line"))
2409 (unless (gnus-get-info group)
2410 (error "Killed group; can't be edited"))
2411 (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
2412 (error "%s is not an nnimap group" group))
2413 (nnimap-expunge mailbox (cadr method))))
2414
2415(defun gnus-group-nnimap-edit-acl (group)
2416 "Edit the Access Control List of current nnimap GROUP."
2417 (interactive (list (gnus-group-group-name)))
2418 (let ((mailbox (gnus-group-real-name group)) method acl)
2419 (unless group
2420 (error "No group on current line"))
2421 (unless (gnus-get-info group)
2422 (error "Killed group; can't be edited"))
2423 (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
2424 (error "%s is not an nnimap group" group))
2425 (gnus-edit-form (setq acl (nnimap-acl-get mailbox (cadr method)))
2426 (format "Editing the access control list for `%s'.
2427
2428 An access control list is a list of (identifier . rights) elements.
2429
2430 The identifier string specifies the corresponding user. The
2431 identifier \"anyone\" is reserved to refer to the universal identity.
2432
2433 Rights is a string listing a (possibly empty) set of alphanumeric
2434 characters, each character listing a set of operations which is being
2435 controlled. Letters are reserved for ``standard'' rights, listed
2436 below. Digits are reserved for implementation or site defined rights.
2437
2438 l - lookup (mailbox is visible to LIST/LSUB commands)
2439 r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
2440 SEARCH, COPY from mailbox)
2441 s - keep seen/unseen information across sessions (STORE \\SEEN flag)
2442 w - write (STORE flags other than \\SEEN and \\DELETED)
2443 i - insert (perform APPEND, COPY into mailbox)
2444 p - post (send mail to submission address for mailbox,
2445 not enforced by IMAP4 itself)
2446 c - create and delete mailbox (CREATE new sub-mailboxes in any
2447 implementation-defined hierarchy, RENAME or DELETE mailbox)
2448 d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
2449 a - administer (perform SETACL)" group)
2450 `(lambda (form)
2451 (nnimap-acl-edit
2452 ,mailbox ',method ',acl form)))))
2453
2214;; Group sorting commands 2454;; Group sorting commands
2215;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>. 2455;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
2216 2456
@@ -2302,46 +2542,52 @@ If REVERSE, sort in reverse order."
2302 ;; Go through all the infos and replace the old entries 2542 ;; Go through all the infos and replace the old entries
2303 ;; with the new infos. 2543 ;; with the new infos.
2304 (while infos 2544 (while infos
2305 (setcar entries (pop infos)) 2545 (setcar (car entries) (pop infos))
2306 (pop entries)) 2546 (pop entries))
2307 ;; Update the hashtable. 2547 ;; Update the hashtable.
2308 (gnus-make-hashtable-from-newsrc-alist))) 2548 (gnus-make-hashtable-from-newsrc-alist)))
2309 2549
2310(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse) 2550(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
2311 "Sort the group buffer alphabetically by group name. 2551 "Sort the group buffer alphabetically by group name.
2312If REVERSE, sort in reverse order." 2552Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
2313 (interactive "P") 2553sort in reverse order."
2314 (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse)) 2554 (interactive (gnus-interactive "P\ny"))
2555 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
2315 2556
2316(defun gnus-group-sort-selected-groups-by-unread (&optional reverse) 2557(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
2317 "Sort the group buffer by number of unread articles. 2558 "Sort the group buffer by number of unread articles.
2318If REVERSE, sort in reverse order." 2559Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
2319 (interactive "P") 2560sort in reverse order."
2320 (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse)) 2561 (interactive (gnus-interactive "P\ny"))
2562 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
2321 2563
2322(defun gnus-group-sort-selected-groups-by-level (&optional reverse) 2564(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
2323 "Sort the group buffer by group level. 2565 "Sort the group buffer by group level.
2324If REVERSE, sort in reverse order." 2566Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
2325 (interactive "P") 2567sort in reverse order."
2326 (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse)) 2568 (interactive (gnus-interactive "P\ny"))
2569 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
2327 2570
2328(defun gnus-group-sort-selected-groups-by-score (&optional reverse) 2571(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
2329 "Sort the group buffer by group score. 2572 "Sort the group buffer by group score.
2330If REVERSE, sort in reverse order." 2573Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
2331 (interactive "P") 2574sort in reverse order."
2332 (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse)) 2575 (interactive (gnus-interactive "P\ny"))
2576 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
2333 2577
2334(defun gnus-group-sort-selected-groups-by-rank (&optional reverse) 2578(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
2335 "Sort the group buffer by group rank. 2579 "Sort the group buffer by group rank.
2336If REVERSE, sort in reverse order." 2580Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
2337 (interactive "P") 2581sort in reverse order."
2338 (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse)) 2582 (interactive (gnus-interactive "P\ny"))
2583 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
2339 2584
2340(defun gnus-group-sort-selected-groups-by-method (&optional reverse) 2585(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
2341 "Sort the group buffer alphabetically by backend name. 2586 "Sort the group buffer alphabetically by backend name.
2342If REVERSE, sort in reverse order." 2587Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
2343 (interactive "P") 2588sort in reverse order."
2344 (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse)) 2589 (interactive (gnus-interactive "P\ny"))
2590 (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
2345 2591
2346;;; Sorting predicates. 2592;;; Sorting predicates.
2347 2593
@@ -2428,7 +2674,7 @@ If REVERSE, sort in reverse order."
2428;; Group catching up. 2674;; Group catching up.
2429 2675
2430(defun gnus-group-catchup-current (&optional n all) 2676(defun gnus-group-catchup-current (&optional n all)
2431 "Mark all articles not marked as unread in current newsgroup as read. 2677 "Mark all unread articles in the current newsgroup as read.
2432If prefix argument N is numeric, the next N newsgroups will be 2678If prefix argument N is numeric, the next N newsgroups will be
2433caught up. If ALL is non-nil, marked articles will also be marked as 2679caught up. If ALL is non-nil, marked articles will also be marked as
2434read. Cross references (Xref: header) of articles are ignored. 2680read. Cross references (Xref: header) of articles are ignored.
@@ -2436,7 +2682,8 @@ The number of newsgroups that this function was unable to catch
2436up is returned." 2682up is returned."
2437 (interactive "P") 2683 (interactive "P")
2438 (let ((groups (gnus-group-process-prefix n)) 2684 (let ((groups (gnus-group-process-prefix n))
2439 (ret 0)) 2685 (ret 0)
2686 group)
2440 (unless groups (error "No groups selected")) 2687 (unless groups (error "No groups selected"))
2441 (if (not 2688 (if (not
2442 (or (not gnus-interactive-catchup) ;Without confirmation? 2689 (or (not gnus-interactive-catchup) ;Without confirmation?
@@ -2450,21 +2697,20 @@ up is returned."
2450 (car groups) 2697 (car groups)
2451 (format "these %d groups" (length groups))))))) 2698 (format "these %d groups" (length groups)))))))
2452 n 2699 n
2453 (while groups 2700 (while (setq group (pop groups))
2701 (gnus-group-remove-mark group)
2454 ;; Virtual groups have to be given special treatment. 2702 ;; Virtual groups have to be given special treatment.
2455 (let ((method (gnus-find-method-for-group (car groups)))) 2703 (let ((method (gnus-find-method-for-group group)))
2456 (when (eq 'nnvirtual (car method)) 2704 (when (eq 'nnvirtual (car method))
2457 (nnvirtual-catchup-group 2705 (nnvirtual-catchup-group
2458 (gnus-group-real-name (car groups)) (nth 1 method) all))) 2706 (gnus-group-real-name group) (nth 1 method) all)))
2459 (gnus-group-remove-mark (car groups)) 2707 (if (>= (gnus-group-level group) gnus-level-zombie)
2460 (if (>= (gnus-group-group-level) gnus-level-zombie)
2461 (gnus-message 2 "Dead groups can't be caught up") 2708 (gnus-message 2 "Dead groups can't be caught up")
2462 (if (prog1 2709 (if (prog1
2463 (gnus-group-goto-group (car groups)) 2710 (gnus-group-goto-group group)
2464 (gnus-group-catchup (car groups) all)) 2711 (gnus-group-catchup group all))
2465 (gnus-group-update-group-line) 2712 (gnus-group-update-group-line)
2466 (setq ret (1+ ret)))) 2713 (setq ret (1+ ret)))))
2467 (setq groups (cdr groups)))
2468 (gnus-group-next-unread-group 1) 2714 (gnus-group-next-unread-group 1)
2469 ret))) 2715 ret)))
2470 2716
@@ -2481,6 +2727,8 @@ The return value is the number of articles that were marked as read,
2481or nil if no action could be taken." 2727or nil if no action could be taken."
2482 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) 2728 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
2483 (num (car entry))) 2729 (num (car entry)))
2730 ;; Remove entries for this group.
2731 (nnmail-purge-split-history (gnus-group-real-name group))
2484 ;; Do the updating only if the newsgroup isn't killed. 2732 ;; Do the updating only if the newsgroup isn't killed.
2485 (if (not (numberp (car entry))) 2733 (if (not (numberp (car entry)))
2486 (gnus-message 1 "Can't catch up %s; non-active group" group) 2734 (gnus-message 1 "Can't catch up %s; non-active group" group)
@@ -2513,32 +2761,41 @@ or nil if no action could be taken."
2513 (error "No groups to expire")) 2761 (error "No groups to expire"))
2514 (while (setq group (pop groups)) 2762 (while (setq group (pop groups))
2515 (gnus-group-remove-mark group) 2763 (gnus-group-remove-mark group)
2516 (when (gnus-check-backend-function 'request-expire-articles group) 2764 (gnus-group-expire-articles-1 group)
2517 (gnus-message 6 "Expiring articles in %s..." group)
2518 (let* ((info (gnus-get-info group))
2519 (expirable (if (gnus-group-total-expirable-p group)
2520 (cons nil (gnus-list-of-read-articles group))
2521 (assq 'expire (gnus-info-marks info))))
2522 (expiry-wait (gnus-group-find-parameter group 'expiry-wait)))
2523 (when expirable
2524 (setcdr
2525 expirable
2526 (gnus-compress-sequence
2527 (if expiry-wait
2528 ;; We set the expiry variables to the group
2529 ;; parameter.
2530 (let ((nnmail-expiry-wait-function nil)
2531 (nnmail-expiry-wait expiry-wait))
2532 (gnus-request-expire-articles
2533 (gnus-uncompress-sequence (cdr expirable)) group))
2534 ;; Just expire using the normal expiry values.
2535 (gnus-request-expire-articles
2536 (gnus-uncompress-sequence (cdr expirable)) group))))
2537 (gnus-close-group group))
2538 (gnus-message 6 "Expiring articles in %s...done" group)))
2539 (gnus-dribble-touch) 2765 (gnus-dribble-touch)
2540 (gnus-group-position-point)))) 2766 (gnus-group-position-point))))
2541 2767
2768(defun gnus-group-expire-articles-1 (group)
2769 (when (gnus-check-backend-function 'request-expire-articles group)
2770 (gnus-message 6 "Expiring articles in %s..." group)
2771 (let* ((info (gnus-get-info group))
2772 (expirable (if (gnus-group-total-expirable-p group)
2773 (cons nil (gnus-list-of-read-articles group))
2774 (assq 'expire (gnus-info-marks info))))
2775 (expiry-wait (gnus-group-find-parameter group 'expiry-wait))
2776 (nnmail-expiry-target
2777 (or (gnus-group-find-parameter group 'expiry-target)
2778 nnmail-expiry-target)))
2779 (when expirable
2780 (gnus-check-group group)
2781 (setcdr
2782 expirable
2783 (gnus-compress-sequence
2784 (if expiry-wait
2785 ;; We set the expiry variables to the group
2786 ;; parameter.
2787 (let ((nnmail-expiry-wait-function nil)
2788 (nnmail-expiry-wait expiry-wait))
2789 (gnus-request-expire-articles
2790 (gnus-uncompress-sequence (cdr expirable)) group))
2791 ;; Just expire using the normal expiry values.
2792 (gnus-request-expire-articles
2793 (gnus-uncompress-sequence (cdr expirable)) group))))
2794 (gnus-close-group group))
2795 (gnus-message 6 "Expiring articles in %s...done" group)
2796 ;; Return the list of un-expired articles.
2797 (cdr expirable))))
2798
2542(defun gnus-group-expire-all-groups () 2799(defun gnus-group-expire-all-groups ()
2543 "Expire all expirable articles in all newsgroups." 2800 "Expire all expirable articles in all newsgroups."
2544 (interactive) 2801 (interactive)
@@ -2565,7 +2822,7 @@ or nil if no action could be taken."
2565 gnus-level-default-subscribed)) 2822 gnus-level-default-subscribed))
2566 s))))) 2823 s)))))
2567 (unless (and (>= level 1) (<= level gnus-level-killed)) 2824 (unless (and (>= level 1) (<= level gnus-level-killed))
2568 (error "Illegal level: %d" level)) 2825 (error "Invalid level: %d" level))
2569 (let ((groups (gnus-group-process-prefix n)) 2826 (let ((groups (gnus-group-process-prefix n))
2570 group) 2827 group)
2571 (while (setq group (pop groups)) 2828 (while (setq group (pop groups))
@@ -2666,13 +2923,15 @@ N and the number of steps taken is returned."
2666 (gnus-group-yank-group) 2923 (gnus-group-yank-group)
2667 (gnus-group-position-point))) 2924 (gnus-group-position-point)))
2668 2925
2669(defun gnus-group-kill-all-zombies () 2926(defun gnus-group-kill-all-zombies (&optional dummy)
2670 "Kill all zombie newsgroups." 2927 "Kill all zombie newsgroups.
2671 (interactive) 2928The optional DUMMY should always be nil."
2672 (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) 2929 (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? "))))
2673 (setq gnus-zombie-list nil) 2930 (unless dummy
2674 (gnus-dribble-touch) 2931 (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
2675 (gnus-group-list-groups)) 2932 (setq gnus-zombie-list nil)
2933 (gnus-dribble-touch)
2934 (gnus-group-list-groups)))
2676 2935
2677(defun gnus-group-kill-region (begin end) 2936(defun gnus-group-kill-region (begin end)
2678 "Kill newsgroups in current region (excluding current point). 2937 "Kill newsgroups in current region (excluding current point).
@@ -2721,7 +2980,8 @@ of groups killed."
2721 (push (cons (car entry) (nth 2 entry)) 2980 (push (cons (car entry) (nth 2 entry))
2722 gnus-list-of-killed-groups)) 2981 gnus-list-of-killed-groups))
2723 (gnus-group-change-level 2982 (gnus-group-change-level
2724 (if entry entry group) gnus-level-killed (if entry nil level))) 2983 (if entry entry group) gnus-level-killed (if entry nil level))
2984 (message "Killed group %s" group))
2725 ;; If there are lots and lots of groups to be killed, we use 2985 ;; If there are lots and lots of groups to be killed, we use
2726 ;; this thing instead. 2986 ;; this thing instead.
2727 (let (entry) 2987 (let (entry)
@@ -2807,7 +3067,7 @@ yanked) a list of yanked groups is returned."
2807 (gnus-make-hashtable-from-newsrc-alist) 3067 (gnus-make-hashtable-from-newsrc-alist)
2808 (gnus-group-list-groups))) 3068 (gnus-group-list-groups)))
2809 (t 3069 (t
2810 (error "Can't kill; illegal level: %d" level)))) 3070 (error "Can't kill; invalid level: %d" level))))
2811 3071
2812(defun gnus-group-list-all-groups (&optional arg) 3072(defun gnus-group-list-all-groups (&optional arg)
2813 "List all newsgroups with level ARG or lower. 3073 "List all newsgroups with level ARG or lower.
@@ -2850,7 +3110,8 @@ entail asking the server for the groups."
2850 (interactive) 3110 (interactive)
2851 ;; First we make sure that we have really read the active file. 3111 ;; First we make sure that we have really read the active file.
2852 (unless (gnus-read-active-file-p) 3112 (unless (gnus-read-active-file-p)
2853 (let ((gnus-read-active-file t)) 3113 (let ((gnus-read-active-file t)
3114 (gnus-agent nil)) ; Trick the agent into ignoring the active file.
2854 (gnus-read-active-file))) 3115 (gnus-read-active-file)))
2855 ;; Find all groups and sort them. 3116 ;; Find all groups and sort them.
2856 (let ((groups 3117 (let ((groups
@@ -2868,10 +3129,14 @@ entail asking the server for the groups."
2868 group) 3129 group)
2869 (erase-buffer) 3130 (erase-buffer)
2870 (while groups 3131 (while groups
3132 (setq group (pop groups))
2871 (gnus-add-text-properties 3133 (gnus-add-text-properties
2872 (point) (prog1 (1+ (point)) 3134 (point) (prog1 (1+ (point))
2873 (insert " *: " 3135 (insert " *: "
2874 (setq group (pop groups)) "\n")) 3136 (gnus-group-name-decode group
3137 (gnus-group-name-charset
3138 nil group))
3139 "\n"))
2875 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 3140 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
2876 'gnus-unread t 3141 'gnus-unread t
2877 'gnus-level (inline (gnus-group-level group))))) 3142 'gnus-level (inline (gnus-group-level group)))))
@@ -2890,7 +3155,11 @@ If ARG is a number, it specifies which levels you are interested in
2890re-scanning. If ARG is non-nil and not a number, this will force 3155re-scanning. If ARG is non-nil and not a number, this will force
2891\"hard\" re-reading of the active files from all servers." 3156\"hard\" re-reading of the active files from all servers."
2892 (interactive "P") 3157 (interactive "P")
2893 (let ((gnus-inhibit-demon t)) 3158 (require 'nnmail)
3159 (let ((gnus-inhibit-demon t)
3160 ;; Binding this variable will inhibit multiple fetchings
3161 ;; of the same mail source.
3162 (nnmail-fetched-sources (list t)))
2894 (gnus-run-hooks 'gnus-get-new-news-hook) 3163 (gnus-run-hooks 'gnus-get-new-news-hook)
2895 3164
2896 ;; Read any slave files. 3165 ;; Read any slave files.
@@ -2931,7 +3200,12 @@ If N is negative, this group and the N-1 previous groups will be checked."
2931 (ret (if (numberp n) (- n (length groups)) 0)) 3200 (ret (if (numberp n) (- n (length groups)) 0))
2932 (beg (unless n 3201 (beg (unless n
2933 (point))) 3202 (point)))
2934 group method) 3203 group method
3204 (gnus-inhibit-demon t)
3205 ;; Binding this variable will inhibit multiple fetchings
3206 ;; of the same mail source.
3207 (nnmail-fetched-sources (list t)))
3208 (gnus-run-hooks 'gnus-get-new-news-hook)
2935 (while (setq group (pop groups)) 3209 (while (setq group (pop groups))
2936 (gnus-group-remove-mark group) 3210 (gnus-group-remove-mark group)
2937 ;; Bypass any previous denials from the server. 3211 ;; Bypass any previous denials from the server.
@@ -2942,8 +3216,9 @@ If N is negative, this group and the N-1 previous groups will be checked."
2942 (gnus-get-info group) (gnus-active group) t) 3216 (gnus-get-info group) (gnus-active group) t)
2943 (unless (gnus-virtual-group-p group) 3217 (unless (gnus-virtual-group-p group)
2944 (gnus-close-group group)) 3218 (gnus-close-group group))
2945 (gnus-agent-save-group-info 3219 (when gnus-agent
2946 method (gnus-group-real-name group) (gnus-active group)) 3220 (gnus-agent-save-group-info
3221 method (gnus-group-real-name group) (gnus-active group)))
2947 (gnus-group-update-group group)) 3222 (gnus-group-update-group group))
2948 (if (eq (gnus-server-status (gnus-find-method-for-group group)) 3223 (if (eq (gnus-server-status (gnus-find-method-for-group group))
2949 'denied) 3224 'denied)
@@ -3020,8 +3295,12 @@ to use."
3020 (mapatoms 3295 (mapatoms
3021 (lambda (group) 3296 (lambda (group)
3022 (setq b (point)) 3297 (setq b (point))
3023 (insert (format " *: %-20s %s\n" (symbol-name group) 3298 (let ((charset (gnus-group-name-charset nil (symbol-name group))))
3024 (symbol-value group))) 3299 (insert (format " *: %-20s %s\n"
3300 (gnus-group-name-decode
3301 (symbol-name group) charset)
3302 (gnus-group-name-decode
3303 (symbol-value group) charset))))
3025 (gnus-add-text-properties 3304 (gnus-add-text-properties
3026 b (1+ b) (list 'gnus-group group 3305 b (1+ b) (list 'gnus-group group
3027 'gnus-unread t 'gnus-marked nil 3306 'gnus-unread t 'gnus-marked nil
@@ -3057,17 +3336,19 @@ to use."
3057 ;; Print out all the groups. 3336 ;; Print out all the groups.
3058 (save-excursion 3337 (save-excursion
3059 (pop-to-buffer "*Gnus Help*") 3338 (pop-to-buffer "*Gnus Help*")
3060 (buffer-disable-undo (current-buffer)) 3339 (buffer-disable-undo)
3061 (erase-buffer) 3340 (erase-buffer)
3062 (setq groups (sort groups 'string<)) 3341 (setq groups (sort groups 'string<))
3063 (while groups 3342 (while groups
3064 ;; Groups may be entered twice into the list of groups. 3343 ;; Groups may be entered twice into the list of groups.
3065 (when (not (string= (car groups) prev)) 3344 (when (not (string= (car groups) prev))
3066 (insert (setq prev (car groups)) "\n") 3345 (setq prev (car groups))
3067 (when (and gnus-description-hashtb 3346 (let ((charset (gnus-group-name-charset nil prev)))
3068 (setq des (gnus-gethash (car groups) 3347 (insert (gnus-group-name-decode prev charset) "\n")
3069 gnus-description-hashtb))) 3348 (when (and gnus-description-hashtb
3070 (insert " " des "\n"))) 3349 (setq des (gnus-gethash (car groups)
3350 gnus-description-hashtb)))
3351 (insert " " (gnus-group-name-decode des charset) "\n"))))
3071 (setq groups (cdr groups))) 3352 (setq groups (cdr groups)))
3072 (goto-char (point-min)))) 3353 (goto-char (point-min))))
3073 (pop-to-buffer obuf))) 3354 (pop-to-buffer obuf)))
@@ -3267,59 +3548,60 @@ and the second element is the address."
3267 (gnus-browse-foreign-server method)) 3548 (gnus-browse-foreign-server method))
3268 3549
3269(defun gnus-group-set-info (info &optional method-only-group part) 3550(defun gnus-group-set-info (info &optional method-only-group part)
3270 (let* ((entry (gnus-gethash 3551 (when (or info part)
3271 (or method-only-group (gnus-info-group info)) 3552 (let* ((entry (gnus-gethash
3272 gnus-newsrc-hashtb)) 3553 (or method-only-group (gnus-info-group info))
3273 (part-info info) 3554 gnus-newsrc-hashtb))
3274 (info (if method-only-group (nth 2 entry) info)) 3555 (part-info info)
3275 method) 3556 (info (if method-only-group (nth 2 entry) info))
3276 (when method-only-group 3557 method)
3558 (when method-only-group
3559 (unless entry
3560 (error "Trying to change non-existent group %s" method-only-group))
3561 ;; We have received parts of the actual group info - either the
3562 ;; select method or the group parameters. We first check
3563 ;; whether we have to extend the info, and if so, do that.
3564 (let ((len (length info))
3565 (total (if (eq part 'method) 5 6)))
3566 (when (< len total)
3567 (setcdr (nthcdr (1- len) info)
3568 (make-list (- total len) nil)))
3569 ;; Then we enter the new info.
3570 (setcar (nthcdr (1- total) info) part-info)))
3277 (unless entry 3571 (unless entry
3278 (error "Trying to change non-existent group %s" method-only-group)) 3572 ;; This is a new group, so we just create it.
3279 ;; We have received parts of the actual group info - either the
3280 ;; select method or the group parameters. We first check
3281 ;; whether we have to extend the info, and if so, do that.
3282 (let ((len (length info))
3283 (total (if (eq part 'method) 5 6)))
3284 (when (< len total)
3285 (setcdr (nthcdr (1- len) info)
3286 (make-list (- total len) nil)))
3287 ;; Then we enter the new info.
3288 (setcar (nthcdr (1- total) info) part-info)))
3289 (unless entry
3290 ;; This is a new group, so we just create it.
3291 (save-excursion
3292 (set-buffer gnus-group-buffer)
3293 (setq method (gnus-info-method info))
3294 (when (gnus-server-equal method "native")
3295 (setq method nil))
3296 (save-excursion 3573 (save-excursion
3297 (set-buffer gnus-group-buffer) 3574 (set-buffer gnus-group-buffer)
3298 (if method 3575 (setq method (gnus-info-method info))
3299 ;; It's a foreign group... 3576 (when (gnus-server-equal method "native")
3300 (gnus-group-make-group 3577 (setq method nil))
3301 (gnus-group-real-name (gnus-info-group info)) 3578 (save-excursion
3302 (if (stringp method) method 3579 (set-buffer gnus-group-buffer)
3303 (prin1-to-string (car method))) 3580 (if method
3304 (and (consp method) 3581 ;; It's a foreign group...
3305 (nth 1 (gnus-info-method info)))) 3582 (gnus-group-make-group
3306 ;; It's a native group. 3583 (gnus-group-real-name (gnus-info-group info))
3307 (gnus-group-make-group (gnus-info-group info)))) 3584 (if (stringp method) method
3308 (gnus-message 6 "Note: New group created") 3585 (prin1-to-string (car method)))
3309 (setq entry 3586 (and (consp method)
3310 (gnus-gethash (gnus-group-prefixed-name 3587 (nth 1 (gnus-info-method info))))
3311 (gnus-group-real-name (gnus-info-group info)) 3588 ;; It's a native group.
3312 (or (gnus-info-method info) gnus-select-method)) 3589 (gnus-group-make-group (gnus-info-group info))))
3313 gnus-newsrc-hashtb)))) 3590 (gnus-message 6 "Note: New group created")
3314 ;; Whether it was a new group or not, we now have the entry, so we 3591 (setq entry
3315 ;; can do the update. 3592 (gnus-gethash (gnus-group-prefixed-name
3316 (if entry 3593 (gnus-group-real-name (gnus-info-group info))
3317 (progn 3594 (or (gnus-info-method info) gnus-select-method))
3318 (setcar (nthcdr 2 entry) info) 3595 gnus-newsrc-hashtb))))
3319 (when (and (not (eq (car entry) t)) 3596 ;; Whether it was a new group or not, we now have the entry, so we
3320 (gnus-active (gnus-info-group info))) 3597 ;; can do the update.
3321 (setcar entry (length (gnus-list-of-unread-articles (car info)))))) 3598 (if entry
3322 (error "No such group: %s" (gnus-info-group info))))) 3599 (progn
3600 (setcar (nthcdr 2 entry) info)
3601 (when (and (not (eq (car entry) t))
3602 (gnus-active (gnus-info-group info)))
3603 (setcar entry (length (gnus-list-of-unread-articles (car info))))))
3604 (error "No such group: %s" (gnus-info-group info))))))
3323 3605
3324(defun gnus-group-set-method-info (group select-method) 3606(defun gnus-group-set-method-info (group select-method)
3325 (gnus-group-set-info select-method group 'method)) 3607 (gnus-group-set-info select-method group 'method))
@@ -3329,7 +3611,7 @@ and the second element is the address."
3329 3611
3330(defun gnus-add-marked-articles (group type articles &optional info force) 3612(defun gnus-add-marked-articles (group type articles &optional info force)
3331 ;; Add ARTICLES of TYPE to the info of GROUP. 3613 ;; Add ARTICLES of TYPE to the info of GROUP.
3332 ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't 3614 ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
3333 ;; add, but replace marked articles of TYPE with ARTICLES. 3615 ;; add, but replace marked articles of TYPE with ARTICLES.
3334 (let ((info (or info (gnus-get-info group))) 3616 (let ((info (or info (gnus-get-info group)))
3335 marked m) 3617 marked m)
@@ -3373,8 +3655,8 @@ or `gnus-group-catchup-group-hook'."
3373(defun gnus-group-timestamp-delta (group) 3655(defun gnus-group-timestamp-delta (group)
3374 "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." 3656 "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
3375 (let* ((time (or (gnus-group-timestamp group) 3657 (let* ((time (or (gnus-group-timestamp group)
3376 (list 0 0))) 3658 (list 0 0)))
3377 (delta (gnus-time-minus (current-time) time))) 3659 (delta (subtract-time (current-time) time)))
3378 (+ (* (nth 0 delta) 65536.0) 3660 (+ (* (nth 0 delta) 65536.0)
3379 (nth 1 delta)))) 3661 (nth 1 delta))))
3380 3662
@@ -3385,6 +3667,118 @@ or `gnus-group-catchup-group-hook'."
3385 "" 3667 ""
3386 (gnus-time-iso8601 time)))) 3668 (gnus-time-iso8601 time))))
3387 3669
3670(defun gnus-group-prepare-flat-list-dead-predicate
3671 (groups level mark predicate)
3672 (let (group)
3673 (if predicate
3674 ;; This loop is used when listing groups that match some
3675 ;; regexp.
3676 (while (setq group (pop groups))
3677 (when (funcall predicate group)
3678 (gnus-add-text-properties
3679 (point) (prog1 (1+ (point))
3680 (insert " " mark " *: "
3681 (gnus-group-name-decode group
3682 (gnus-group-name-charset
3683 nil group))
3684 "\n"))
3685 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
3686 'gnus-unread t
3687 'gnus-level level)))))))
3688
3689(defun gnus-group-prepare-flat-predicate (level predicate &optional lowest
3690 dead-predicate)
3691 "List all newsgroups with unread articles of level LEVEL or lower.
3692If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
3693If PREDICATE, only list groups which PREDICATE returns non-nil.
3694If DEAD-PREDICATE, list dead groups which DEAD-PREDICATE returns non-nil."
3695 (set-buffer gnus-group-buffer)
3696 (let ((buffer-read-only nil)
3697 (newsrc (cdr gnus-newsrc-alist))
3698 (lowest (or lowest 1))
3699 info clevel unread group params)
3700 (erase-buffer)
3701 ;; List living groups.
3702 (while newsrc
3703 (setq info (car newsrc)
3704 group (gnus-info-group info)
3705 params (gnus-info-params info)
3706 newsrc (cdr newsrc)
3707 unread (car (gnus-gethash group gnus-newsrc-hashtb)))
3708 (and unread ; This group might be unchecked
3709 (funcall predicate info)
3710 (<= (setq clevel (gnus-info-level info)) level)
3711 (>= clevel lowest)
3712 (gnus-group-insert-group-line
3713 group (gnus-info-level info)
3714 (gnus-info-marks info) unread (gnus-info-method info))))
3715
3716 ;; List dead groups.
3717 (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
3718 (gnus-group-prepare-flat-list-dead-predicate
3719 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
3720 gnus-level-zombie ?Z
3721 dead-predicate))
3722 (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
3723 (gnus-group-prepare-flat-list-dead-predicate
3724 (setq gnus-killed-list (sort gnus-killed-list 'string<))
3725 gnus-level-killed ?K dead-predicate))
3726
3727 (gnus-group-set-mode-line)
3728 (setq gnus-group-list-mode (cons level t))
3729 (gnus-run-hooks 'gnus-group-prepare-hook)
3730 t))
3731
3732(defun gnus-group-list-cached (level &optional lowest)
3733 "List all groups with cached articles.
3734If the prefix LEVEL is non-nil, it should be a number that says which
3735level to cut off listing groups.
3736If LOWEST, don't list groups with level lower than LOWEST.
3737
3738This command may read the active file."
3739 (interactive "P")
3740 (when level
3741 (setq level (prefix-numeric-value level)))
3742 (when (or (not level) (>= level gnus-level-zombie))
3743 (gnus-cache-open))
3744 (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed)
3745 #'(lambda (info)
3746 (let ((marks (gnus-info-marks info)))
3747 (assq 'cache marks)))
3748 lowest
3749 #'(lambda (group)
3750 (or (gnus-gethash group
3751 gnus-cache-active-hashtb)
3752 ;; Cache active file might use "."
3753 ;; instead of ":".
3754 (gnus-gethash
3755 (mapconcat 'identity
3756 (split-string group ":")
3757 ".")
3758 gnus-cache-active-hashtb))))
3759 (goto-char (point-min))
3760 (gnus-group-position-point))
3761
3762(defun gnus-group-list-dormant (level &optional lowest)
3763 "List all groups with dormant articles.
3764If the prefix LEVEL is non-nil, it should be a number that says which
3765level to cut off listing groups.
3766If LOWEST, don't list groups with level lower than LOWEST.
3767
3768This command may read the active file."
3769 (interactive "P")
3770 (when level
3771 (setq level (prefix-numeric-value level)))
3772 (when (or (not level) (>= level gnus-level-zombie))
3773 (gnus-cache-open))
3774 (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed)
3775 #'(lambda (info)
3776 (let ((marks (gnus-info-marks info)))
3777 (assq 'dormant marks)))
3778 lowest)
3779 (goto-char (point-min))
3780 (gnus-group-position-point))
3781
3388(provide 'gnus-group) 3782(provide 'gnus-group)
3389 3783
3390;;; gnus-group.el ends here 3784;;; gnus-group.el ends here
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index 992eac52c4a..7f80f8ea049 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1,5 +1,6 @@
1;;; gnus-msg.el --- mail and post interface for Gnus 1;;; gnus-msg.el --- mail and post interface for Gnus
2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. 2;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3;; Free Software Foundation, Inc.
3 4
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@gnus.org> 6;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -28,26 +29,24 @@
28 29
29(eval-when-compile (require 'cl)) 30(eval-when-compile (require 'cl))
30 31
31(eval-when-compile (require 'cl))
32
33(require 'gnus) 32(require 'gnus)
34(require 'gnus-ems) 33(require 'gnus-ems)
35(require 'message) 34(require 'message)
36(require 'gnus-art) 35(require 'gnus-art)
37 36
38(defcustom gnus-post-method nil 37(defcustom gnus-post-method 'current
39 "*Preferred method for posting USENET news. 38 "*Preferred method for posting USENET news.
40 39
41If this variable is `current', Gnus will use the \"current\" select 40If this variable is `current', Gnus will use the \"current\" select
42method when posting. If it is nil (which is the default), Gnus will 41method when posting. If it is nil (which is the default), Gnus will
43use the native posting method of the server. 42use the native select method when posting.
44 43
45This method will not be used in mail groups and the like, only in 44This method will not be used in mail groups and the like, only in
46\"real\" newsgroups. 45\"real\" newsgroups.
47 46
48If not nil nor `native', the value must be a valid method as discussed 47If not nil nor `native', the value must be a valid method as discussed
49in the documentation of `gnus-select-method'. It can also be a list of 48in the documentation of `gnus-select-method'. It can also be a list of
50methods. If that is the case, the user will be queried for what select 49methods. If that is the case, the user will be queried for what select
51method to use when posting." 50method to use when posting."
52 :group 'gnus-group-foreign 51 :group 'gnus-group-foreign
53 :type `(choice (const nil) 52 :type `(choice (const nil)
@@ -102,13 +101,37 @@ the second with the current group name.")
102(defvar gnus-posting-styles nil 101(defvar gnus-posting-styles nil
103 "*Alist of styles to use when posting.") 102 "*Alist of styles to use when posting.")
104 103
105(defvar gnus-posting-style-alist 104(defcustom gnus-group-posting-charset-alist
106 '((organization . message-user-organization) 105 '(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
107 (signature . message-signature) 106 ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
108 (signature-file . message-signature-file) 107 (message-this-is-mail nil nil)
109 (address . user-mail-address) 108 (message-this-is-news nil t))
110 (name . user-full-name)) 109 "Alist of regexps and permitted unencoded charsets for posting.
111 "*Mapping from style parameters to variables.") 110Each element of the alist has the form (TEST HEADER BODY-LIST), where
111TEST is either a regular expression matching the newsgroup header or a
112variable to query,
113HEADER is the charset which may be left unencoded in the header (nil
114means encode all charsets),
115BODY-LIST is a list of charsets which may be encoded using 8bit
116content-transfer encoding in the body, or one of the special values
117nil (always encode using quoted-printable) or t (always use 8bit).
118
119Note that any value other than nil for HEADER infringes some RFCs, so
120use this option with care."
121 :type '(repeat (list :tag "Permitted unencoded charsets"
122 (choice :tag "Where"
123 (regexp :tag "Group")
124 (const :tag "Mail message" :value message-this-is-mail)
125 (const :tag "News article" :value message-this-is-news))
126 (choice :tag "Header"
127 (const :tag "None" nil)
128 (symbol :tag "Charset"))
129 (choice :tag "Body"
130 (const :tag "Any" :value t)
131 (const :tag "None" :value nil)
132 (repeat :tag "Charsets"
133 (symbol :tag "Charset")))))
134 :group 'gnus-charset)
112 135
113;;; Internal variables. 136;;; Internal variables.
114 137
@@ -127,9 +150,10 @@ the second with the current group name.")
127The buffer below is a mail buffer. When you press `C-c C-c', it will 150The buffer below is a mail buffer. When you press `C-c C-c', it will
128be sent to the Gnus Bug Exterminators. 151be sent to the Gnus Bug Exterminators.
129 152
130At the bottom of the buffer you'll see lots of variable settings. 153The thing near the bottom of the buffer is how the environment
131Please do not delete those. They will tell the Bug People what your 154settings will be included in the mail. Please do not delete that.
132environment is, so that it will be easier to locate the bugs. 155They will tell the Bug People what your environment is, so that it
156will be easier to locate the bugs.
133 157
134If you have found a bug that makes Emacs go \"beep\", set 158If you have found a bug that makes Emacs go \"beep\", set
135debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') 159debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
@@ -159,6 +183,7 @@ Thank you for your help in stamping out bugs.
159 "c" gnus-summary-cancel-article 183 "c" gnus-summary-cancel-article
160 "s" gnus-summary-supersede-article 184 "s" gnus-summary-supersede-article
161 "r" gnus-summary-reply 185 "r" gnus-summary-reply
186 "y" gnus-summary-yank-message
162 "R" gnus-summary-reply-with-original 187 "R" gnus-summary-reply-with-original
163 "w" gnus-summary-wide-reply 188 "w" gnus-summary-wide-reply
164 "W" gnus-summary-wide-reply-with-original 189 "W" gnus-summary-wide-reply-with-original
@@ -177,6 +202,20 @@ Thank you for your help in stamping out bugs.
177 ;; "c" gnus-summary-send-draft 202 ;; "c" gnus-summary-send-draft
178 "r" gnus-summary-resend-message) 203 "r" gnus-summary-resend-message)
179 204
205;;;###autoload
206(defun gnus-msg-mail (&rest args)
207 "Start editing a mail message to be sent.
208Like `message-mail', but with Gnus paraphernalia, particularly the
209the Gcc: header for archiving purposes."
210 (interactive)
211 (gnus-setup-message 'message
212 (apply 'message-mail args)))
213
214;;;###autoload
215(define-mail-user-agent 'gnus-user-agent
216 'gnus-msg-mail 'message-send-and-exit
217 'message-kill-buffer 'message-send-hook)
218
180;;; Internal functions. 219;;; Internal functions.
181 220
182(defvar gnus-article-reply nil) 221(defvar gnus-article-reply nil)
@@ -191,7 +230,9 @@ Thank you for your help in stamping out bugs.
191 (,group gnus-newsgroup-name) 230 (,group gnus-newsgroup-name)
192 (message-header-setup-hook 231 (message-header-setup-hook
193 (copy-sequence message-header-setup-hook)) 232 (copy-sequence message-header-setup-hook))
233 (mbl mml-buffer-list)
194 (message-mode-hook (copy-sequence message-mode-hook))) 234 (message-mode-hook (copy-sequence message-mode-hook)))
235 (setq mml-buffer-list nil)
195 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) 236 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
196 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) 237 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
197 (add-hook 'message-mode-hook 'gnus-configure-posting-styles) 238 (add-hook 'message-mode-hook 'gnus-configure-posting-styles)
@@ -202,12 +243,37 @@ Thank you for your help in stamping out bugs.
202 (setq gnus-message-buffer (current-buffer)) 243 (setq gnus-message-buffer (current-buffer))
203 (set (make-local-variable 'gnus-message-group-art) 244 (set (make-local-variable 'gnus-message-group-art)
204 (cons ,group ,article)) 245 (cons ,group ,article))
205 (make-local-variable 'gnus-newsgroup-name) 246 (set (make-local-variable 'gnus-newsgroup-name) ,group)
206 (gnus-run-hooks 'gnus-message-setup-hook)) 247 (gnus-run-hooks 'gnus-message-setup-hook)
248 (if (eq major-mode 'message-mode)
249 ;; Make mml-buffer-list local.
250 ;; Restore global mml-buffer-list value as mbl.
251 ;; What a hack! -- Shenghuo
252 (let ((mml-buffer-list mml-buffer-list))
253 (setq mml-buffer-list mbl)
254 (make-local-variable 'mml-buffer-list)
255 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
256 (mml-destroy-buffers)
257 (setq mml-buffer-list mbl)))
207 (gnus-add-buffer) 258 (gnus-add-buffer)
208 (gnus-configure-windows ,config t) 259 (gnus-configure-windows ,config t)
209 (set-buffer-modified-p nil)))) 260 (set-buffer-modified-p nil))))
210 261
262(defun gnus-setup-posting-charset (group)
263 (let ((alist gnus-group-posting-charset-alist)
264 (group (or group ""))
265 elem)
266 (when group
267 (catch 'found
268 (while (setq elem (pop alist))
269 (when (or (and (stringp (car elem))
270 (string-match (car elem) group))
271 (and (gnus-functionp (car elem))
272 (funcall (car elem) group))
273 (and (symbolp (car elem))
274 (symbol-value (car elem))))
275 (throw 'found (cons (cadr elem) (caddr elem)))))))))
276
211(defun gnus-inews-add-send-actions (winconf buffer article) 277(defun gnus-inews-add-send-actions (winconf buffer article)
212 (make-local-hook 'message-sent-hook) 278 (make-local-hook 'message-sent-hook)
213 (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) 279 (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
@@ -230,11 +296,29 @@ Thank you for your help in stamping out bugs.
230 296
231;;; Post news commands of Gnus group mode and summary mode 297;;; Post news commands of Gnus group mode and summary mode
232 298
233(defun gnus-group-mail () 299(defun gnus-group-mail (&optional arg)
234 "Start composing a mail." 300 "Start composing a mail.
235 (interactive) 301If ARG, use the group under the point to find a posting style.
236 (gnus-setup-message 'message 302If ARG is 1, prompt for a group name to find the posting style."
237 (message-mail))) 303 (interactive "P")
304 ;; We can't `let' gnus-newsgroup-name here, since that leads
305 ;; to local variables leaking.
306 (let ((group gnus-newsgroup-name)
307 (buffer (current-buffer)))
308 (unwind-protect
309 (progn
310 (setq gnus-newsgroup-name
311 (if arg
312 (if (= 1 (prefix-numeric-value arg))
313 (completing-read "Use posting style of group: "
314 gnus-active-hashtb nil
315 (gnus-read-active-file-p))
316 (gnus-group-group-name))
317 ""))
318 (gnus-setup-message 'message (message-mail)))
319 (save-excursion
320 (set-buffer buffer)
321 (setq gnus-newsgroup-name group)))))
238 322
239(defun gnus-group-post-news (&optional arg) 323(defun gnus-group-post-news (&optional arg)
240 "Start composing a news message. 324 "Start composing a news message.
@@ -355,7 +439,9 @@ header line with the old Message-ID."
355 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used 439 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
356 ;; this buffer should be passed to all mail/news reply/post routines. 440 ;; this buffer should be passed to all mail/news reply/post routines.
357 (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) 441 (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
358 (buffer-disable-undo gnus-article-copy) 442 (save-excursion
443 (set-buffer gnus-article-copy)
444 (mm-enable-multibyte))
359 (let ((article-buffer (or article-buffer gnus-article-buffer)) 445 (let ((article-buffer (or article-buffer gnus-article-buffer))
360 end beg) 446 end beg)
361 (if (not (and (get-buffer article-buffer) 447 (if (not (and (get-buffer article-buffer)
@@ -374,7 +460,7 @@ header line with the old Message-ID."
374 (gnus-remove-text-with-property 'gnus-next) 460 (gnus-remove-text-with-property 'gnus-next)
375 (insert 461 (insert
376 (prog1 462 (prog1
377 (format "%s" (buffer-string)) 463 (buffer-substring-no-properties (point-min) (point-max))
378 (erase-buffer))) 464 (erase-buffer)))
379 ;; Find the original headers. 465 ;; Find the original headers.
380 (set-buffer gnus-original-article-buffer) 466 (set-buffer gnus-original-article-buffer)
@@ -386,10 +472,10 @@ header line with the old Message-ID."
386 ;; Delete the headers from the displayed articles. 472 ;; Delete the headers from the displayed articles.
387 (set-buffer gnus-article-copy) 473 (set-buffer gnus-article-copy)
388 (delete-region (goto-char (point-min)) 474 (delete-region (goto-char (point-min))
389 (or (search-forward "\n\n" nil t) (point))) 475 (or (search-forward "\n\n" nil t) (point-max)))
390 ;; Insert the original article headers. 476 ;; Insert the original article headers.
391 (insert-buffer-substring gnus-original-article-buffer beg end) 477 (insert-buffer-substring gnus-original-article-buffer beg end)
392 (gnus-article-decode-rfc1522))) 478 (article-decode-encoded-words)))
393 gnus-article-copy))) 479 gnus-article-copy)))
394 480
395(defun gnus-post-news (post &optional group header article-buffer yank subject 481(defun gnus-post-news (post &optional group header article-buffer yank subject
@@ -402,6 +488,7 @@ header line with the old Message-ID."
402 (article-buffer 'reply) 488 (article-buffer 'reply)
403 (t 'message)) 489 (t 'message))
404 (let* ((group (or group gnus-newsgroup-name)) 490 (let* ((group (or group gnus-newsgroup-name))
491 (charset (gnus-group-name-charset nil group))
405 (pgroup group) 492 (pgroup group)
406 to-address to-group mailing-list to-list 493 to-address to-group mailing-list to-list
407 newsgroup-p) 494 newsgroup-p)
@@ -412,7 +499,8 @@ header line with the old Message-ID."
412 newsgroup-p (gnus-group-find-parameter group 'newsgroup) 499 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
413 mailing-list (when gnus-mailing-list-groups 500 mailing-list (when gnus-mailing-list-groups
414 (string-match gnus-mailing-list-groups group)) 501 (string-match gnus-mailing-list-groups group))
415 group (gnus-group-real-name group))) 502 group (gnus-group-name-decode (gnus-group-real-name group)
503 charset)))
416 (if (or (and to-group 504 (if (or (and to-group
417 (gnus-news-group-p to-group)) 505 (gnus-news-group-p to-group))
418 newsgroup-p 506 newsgroup-p
@@ -464,7 +552,7 @@ If SILENT, don't prompt the user."
464 ;; the default method. 552 ;; the default method.
465 ((null group-method) 553 ((null group-method)
466 (or (and (null (eq gnus-post-method 'active)) gnus-post-method) 554 (or (and (null (eq gnus-post-method 'active)) gnus-post-method)
467 gnus-select-method message-post-method)) 555 gnus-select-method message-post-method))
468 ;; We want the inverse of the default 556 ;; We want the inverse of the default
469 ((and arg (not (eq arg 0))) 557 ((and arg (not (eq arg 0)))
470 (if (eq gnus-post-method 'active) 558 (if (eq gnus-post-method 'active)
@@ -485,14 +573,16 @@ If SILENT, don't prompt the user."
485 (list gnus-post-method))) 573 (list gnus-post-method)))
486 gnus-secondary-select-methods 574 gnus-secondary-select-methods
487 (mapcar 'cdr gnus-server-alist) 575 (mapcar 'cdr gnus-server-alist)
576 (mapcar 'car gnus-opened-servers)
488 (list gnus-select-method) 577 (list gnus-select-method)
489 (list group-method))) 578 (list group-method)))
490 method-alist post-methods method) 579 method-alist post-methods method)
491 ;; Weed out all mail methods. 580 ;; Weed out all mail methods.
492 (while methods 581 (while methods
493 (setq method (gnus-server-get-method "" (pop methods))) 582 (setq method (gnus-server-get-method "" (pop methods)))
494 (when (or (gnus-method-option-p method 'post) 583 (when (and (or (gnus-method-option-p method 'post)
495 (gnus-method-option-p method 'post-mail)) 584 (gnus-method-option-p method 'post-mail))
585 (not (member method post-methods)))
496 (push method post-methods))) 586 (push method post-methods)))
497 ;; Create a name-method alist. 587 ;; Create a name-method alist.
498 (setq method-alist 588 (setq method-alist
@@ -515,8 +605,9 @@ If SILENT, don't prompt the user."
515 ;; Override normal method. 605 ;; Override normal method.
516 ((and (eq gnus-post-method 'current) 606 ((and (eq gnus-post-method 'current)
517 (not (eq (car group-method) 'nndraft)) 607 (not (eq (car group-method) 'nndraft))
608 (gnus-get-function group-method 'request-post t)
518 (not arg)) 609 (not arg))
519 group-method) 610 group-method)
520 ((and gnus-post-method 611 ((and gnus-post-method
521 (not (eq gnus-post-method 'current))) 612 (not (eq gnus-post-method 'current)))
522 gnus-post-method) 613 gnus-post-method)
@@ -525,69 +616,32 @@ If SILENT, don't prompt the user."
525 616
526 617
527 618
528;; Dummy to avoid byte-compile warning. 619;; Dummies to avoid byte-compile warning.
529(defvar nnspool-rejected-article-hook) 620(defvar nnspool-rejected-article-hook)
530(defvar xemacs-codename) 621(defvar xemacs-codename)
531 622
532;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
533;;; as well include the Emacs version as well.
534;;; The following function works with later GNU Emacs, and XEmacs.
535(defun gnus-extended-version () 623(defun gnus-extended-version ()
536 "Stringified Gnus version and Emacs version." 624 "Stringified Gnus version and Emacs version."
537 (interactive) 625 (interactive)
538 (concat 626 (concat
539 gnus-version 627 "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)
540 "/" 628 " (" gnus-version ")"
629 " "
541 (cond 630 (cond
542 ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) 631 ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
543 (concat "Emacs " (substring emacs-version 632 (concat "Emacs/" (match-string 1 emacs-version)))
544 (match-beginning 1)
545 (match-end 1))))
546 ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" 633 ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
547 emacs-version) 634 emacs-version)
548 (concat (substring emacs-version 635 (concat (match-string 1 emacs-version)
549 (match-beginning 1) 636 (format "/%d.%d" emacs-major-version emacs-minor-version)
550 (match-end 1))
551 (format " %d.%d" emacs-major-version emacs-minor-version)
552 (if (match-beginning 3) 637 (if (match-beginning 3)
553 (substring emacs-version 638 (match-string 3 emacs-version)
554 (match-beginning 3)
555 (match-end 3))
556 "") 639 "")
557 (if (boundp 'xemacs-codename) 640 (if (boundp 'xemacs-codename)
558 (concat " - \"" xemacs-codename "\"")))) 641 (concat " (" xemacs-codename ")")
642 "")))
559 (t emacs-version)))) 643 (t emacs-version))))
560 644
561;; Written by "Mr. Per Persson" <pp@gnu.org>.
562(defun gnus-inews-insert-mime-headers ()
563 "Insert MIME headers.
564Assumes ISO-Latin-1 is used iff 8-bit characters are present."
565 (goto-char (point-min))
566 (let ((mail-header-separator
567 (progn
568 (goto-char (point-min))
569 (if (and (search-forward (concat "\n" mail-header-separator "\n")
570 nil t)
571 (not (search-backward "\n\n" nil t)))
572 mail-header-separator
573 ""))))
574 (or (mail-position-on-field "Mime-Version")
575 (insert "1.0")
576 (cond ((save-restriction
577 (widen)
578 (goto-char (point-min))
579 (re-search-forward "[^\000-\177]" nil t))
580 (or (mail-position-on-field "Content-Type")
581 (insert "text/plain; charset=ISO-8859-1"))
582 (or (mail-position-on-field "Content-Transfer-Encoding")
583 (insert "8bit")))
584 (t (or (mail-position-on-field "Content-Type")
585 (insert "text/plain; charset=US-ASCII"))
586 (or (mail-position-on-field "Content-Transfer-Encoding")
587 (insert "7bit")))))))
588
589(custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers)
590
591 645
592;;; 646;;;
593;;; Gnus Mail Functions 647;;; Gnus Mail Functions
@@ -610,6 +664,10 @@ automatically."
610 (gnus-summary-select-article) 664 (gnus-summary-select-article)
611 (set-buffer (gnus-copy-article-buffer)) 665 (set-buffer (gnus-copy-article-buffer))
612 (gnus-msg-treat-broken-reply-to) 666 (gnus-msg-treat-broken-reply-to)
667 (save-restriction
668 (message-narrow-to-head)
669 (goto-char (point-max)))
670 (mml-quote-region (point) (point-max))
613 (message-reply nil wide) 671 (message-reply nil wide)
614 (when yank 672 (when yank
615 (gnus-inews-yank-articles yank))))) 673 (gnus-inews-yank-articles yank)))))
@@ -635,16 +693,50 @@ The original article will be yanked."
635 (interactive "P") 693 (interactive "P")
636 (gnus-summary-reply-with-original n t)) 694 (gnus-summary-reply-with-original n t))
637 695
638(defun gnus-summary-mail-forward (&optional full-headers post) 696(defun gnus-summary-mail-forward (&optional arg post)
639 "Forward the current message to another user. 697 "Forward the current message to another user.
640If FULL-HEADERS (the prefix), include full headers when forwarding." 698If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
699if ARG is 1, decode the message and forward directly inline;
700if ARG is 2, foward message as an rfc822 MIME section;
701if ARG is 3, decode message and forward as an rfc822 MIME section;
702if ARG is 4, foward message directly inline;
703otherwise, use flipped `message-forward-as-mime'.
704If POST, post instead of mail."
641 (interactive "P") 705 (interactive "P")
642 (gnus-setup-message 'forward 706 (let ((message-forward-as-mime message-forward-as-mime)
643 (gnus-summary-select-article) 707 (message-forward-show-mml message-forward-show-mml))
644 (set-buffer gnus-original-article-buffer) 708 (cond
645 (let ((message-included-forward-headers 709 ((null arg))
646 (if full-headers "" message-included-forward-headers))) 710 ((eq arg 1) (setq message-forward-as-mime nil
647 (message-forward post)))) 711 message-forward-show-mml t))
712 ((eq arg 2) (setq message-forward-as-mime t
713 message-forward-show-mml nil))
714 ((eq arg 3) (setq message-forward-as-mime t
715 message-forward-show-mml t))
716 ((eq arg 4) (setq message-forward-as-mime nil
717 message-forward-show-mml nil))
718 (t (setq message-forward-as-mime (not message-forward-as-mime))))
719 (gnus-setup-message 'forward
720 (gnus-summary-select-article)
721 (let ((mail-parse-charset gnus-newsgroup-charset)
722 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
723 text)
724 (save-excursion
725 (set-buffer gnus-original-article-buffer)
726 (setq text (buffer-string)))
727 (set-buffer
728 (gnus-get-buffer-create
729 (generate-new-buffer-name " *Gnus forward*")))
730 (erase-buffer)
731 (unless message-forward-show-mml
732 (mm-disable-multibyte))
733 (insert text)
734 (goto-char (point-min))
735 (when (looking-at "From ")
736 (replace-match "X-From-Line: ") )
737 (when message-forward-show-mml
738 (mime-to-mml))
739 (message-forward post)))))
648 740
649(defun gnus-summary-resend-message (address n) 741(defun gnus-summary-resend-message (address n)
650 "Resend the current article to ADDRESS." 742 "Resend the current article to ADDRESS."
@@ -657,11 +749,11 @@ If FULL-HEADERS (the prefix), include full headers when forwarding."
657 (set-buffer gnus-original-article-buffer) 749 (set-buffer gnus-original-article-buffer)
658 (message-resend address))))) 750 (message-resend address)))))
659 751
660(defun gnus-summary-post-forward (&optional full-headers) 752(defun gnus-summary-post-forward (&optional arg)
661 "Forward the current article to a newsgroup. 753 "Forward the current article to a newsgroup.
662If FULL-HEADERS (the prefix), include full headers when forwarding." 754See `gnus-summary-mail-forward' for ARG."
663 (interactive "P") 755 (interactive "P")
664 (gnus-summary-mail-forward full-headers t)) 756 (gnus-summary-mail-forward arg t))
665 757
666(defvar gnus-nastygram-message 758(defvar gnus-nastygram-message
667 "The following article was inappropriately posted to %s.\n\n" 759 "The following article was inappropriately posted to %s.\n\n"
@@ -694,7 +786,8 @@ The current group name will be inserted at \"%s\".")
694 (gnus-summary-select-article) 786 (gnus-summary-select-article)
695 (set-buffer gnus-original-article-buffer) 787 (set-buffer gnus-original-article-buffer)
696 (if (and (<= (length (message-tokenize-header 788 (if (and (<= (length (message-tokenize-header
697 (setq newsgroups (mail-fetch-field "newsgroups")) 789 (setq newsgroups
790 (mail-fetch-field "newsgroups"))
698 ", ")) 791 ", "))
699 1) 792 1)
700 (or (not (setq followup-to (mail-fetch-field "followup-to"))) 793 (or (not (setq followup-to (mail-fetch-field "followup-to")))
@@ -833,7 +926,12 @@ If YANK is non-nil, include the original article."
833 (stringp nntp-server-type)) 926 (stringp nntp-server-type))
834 (insert nntp-server-type)) 927 (insert nntp-server-type))
835 (insert "\n\n\n\n\n") 928 (insert "\n\n\n\n\n")
836 (gnus-debug) 929 (let (text)
930 (save-excursion
931 (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
932 (gnus-debug)
933 (setq text (buffer-string)))
934 (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
837 (goto-char (point-min)) 935 (goto-char (point-min))
838 (search-forward "Subject: " nil t) 936 (search-forward "Subject: " nil t)
839 (message ""))) 937 (message "")))
@@ -842,6 +940,19 @@ If YANK is non-nil, include the original article."
842 (when (get-buffer "*Gnus Help Bug*") 940 (when (get-buffer "*Gnus Help Bug*")
843 (kill-buffer "*Gnus Help Bug*"))) 941 (kill-buffer "*Gnus Help Bug*")))
844 942
943(defun gnus-summary-yank-message (buffer n)
944 "Yank the current article into a composed message."
945 (interactive
946 (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
947 current-prefix-arg))
948 (gnus-summary-iterate n
949 (let ((gnus-display-mime-function nil)
950 (gnus-inhibit-treatment t))
951 (gnus-summary-select-article))
952 (save-excursion
953 (set-buffer buffer)
954 (message-yank-buffer gnus-article-buffer))))
955
845(defun gnus-debug () 956(defun gnus-debug ()
846 "Attempts to go through the Gnus source file and report what variables have been changed. 957 "Attempts to go through the Gnus source file and report what variables have been changed.
847The source file has to be in the Emacs load path." 958The source file has to be in the Emacs load path."
@@ -857,7 +968,6 @@ The source file has to be in the Emacs load path."
857 ;; Go through all the files looking for non-default values for variables. 968 ;; Go through all the files looking for non-default values for variables.
858 (save-excursion 969 (save-excursion
859 (set-buffer (gnus-get-buffer-create " *gnus bug info*")) 970 (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
860 (buffer-disable-undo (current-buffer))
861 (while files 971 (while files
862 (erase-buffer) 972 (erase-buffer)
863 (when (and (setq file (locate-library (pop files))) 973 (when (and (setq file (locate-library (pop files)))
@@ -940,7 +1050,8 @@ this is a reply."
940 (when gcc 1050 (when gcc
941 (message-remove-header "gcc") 1051 (message-remove-header "gcc")
942 (widen) 1052 (widen)
943 (setq groups (message-tokenize-header gcc " ,")) 1053 (setq groups (message-unquote-tokens
1054 (message-tokenize-header gcc " ,")))
944 ;; Copy the article over to some group(s). 1055 ;; Copy the article over to some group(s).
945 (while (setq group (pop groups)) 1056 (while (setq group (pop groups))
946 (gnus-check-server 1057 (gnus-check-server
@@ -964,12 +1075,20 @@ this is a reply."
964 (save-excursion 1075 (save-excursion
965 (nnheader-set-temp-buffer " *acc*") 1076 (nnheader-set-temp-buffer " *acc*")
966 (insert-buffer-substring cur) 1077 (insert-buffer-substring cur)
1078 (message-encode-message-body)
1079 (save-restriction
1080 (message-narrow-to-headers)
1081 (let ((mail-parse-charset message-default-charset)
1082 (rfc2047-header-encoding-alist
1083 (cons '("Newsgroups" . default)
1084 rfc2047-header-encoding-alist)))
1085 (mail-encode-encoded-word-buffer)))
967 (goto-char (point-min)) 1086 (goto-char (point-min))
968 (when (re-search-forward 1087 (when (re-search-forward
969 (concat "^" (regexp-quote mail-header-separator) "$") 1088 (concat "^" (regexp-quote mail-header-separator) "$")
970 nil t) 1089 nil t)
971 (replace-match "" t t )) 1090 (replace-match "" t t ))
972 (unless (gnus-request-accept-article group method t) 1091 (unless (gnus-request-accept-article group method t t)
973 (gnus-message 1 "Couldn't store article in group %s: %s" 1092 (gnus-message 1 "Couldn't store article in group %s: %s"
974 group (gnus-status-message method)) 1093 group (gnus-status-message method))
975 (sit-for 2)) 1094 (sit-for 2))
@@ -998,9 +1117,10 @@ this is a reply."
998 (group (or group gnus-newsgroup-name "")) 1117 (group (or group gnus-newsgroup-name ""))
999 (gcc-self-val 1118 (gcc-self-val
1000 (and gnus-newsgroup-name 1119 (and gnus-newsgroup-name
1120 (not (equal gnus-newsgroup-name ""))
1001 (gnus-group-find-parameter 1121 (gnus-group-find-parameter
1002 gnus-newsgroup-name 'gcc-self))) 1122 gnus-newsgroup-name 'gcc-self)))
1003 result 1123 result
1004 (groups 1124 (groups
1005 (cond 1125 (cond
1006 ((null gnus-message-archive-method) 1126 ((null gnus-message-archive-method)
@@ -1068,86 +1188,131 @@ this is a reply."
1068 1188
1069;;; Posting styles. 1189;;; Posting styles.
1070 1190
1071(defvar gnus-message-style-insertions nil)
1072
1073(defun gnus-configure-posting-styles () 1191(defun gnus-configure-posting-styles ()
1074 "Configure posting styles according to `gnus-posting-styles'." 1192 "Configure posting styles according to `gnus-posting-styles'."
1075 (unless gnus-inhibit-posting-styles 1193 (unless gnus-inhibit-posting-styles
1076 (let ((styles gnus-posting-styles) 1194 (let ((group (or gnus-newsgroup-name ""))
1077 (gnus-newsgroup-name (or gnus-newsgroup-name "")) 1195 (styles gnus-posting-styles)
1078 style match variable attribute value value-value) 1196 style match variable attribute value v results
1079 (make-local-variable 'gnus-message-style-insertions) 1197 filep name address element)
1198 ;; If the group has a posting-style parameter, add it at the end with a
1199 ;; regexp matching everything, to be sure it takes precedence over all
1200 ;; the others.
1201 (when gnus-newsgroup-name
1202 (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
1203 (when tmp-style
1204 (setq styles (append styles (list (cons ".*" tmp-style)))))))
1080 ;; Go through all styles and look for matches. 1205 ;; Go through all styles and look for matches.
1081 (while styles 1206 (dolist (style styles)
1082 (setq style (pop styles) 1207 (setq match (pop style))
1083 match (pop style)) 1208 (goto-char (point-min))
1084 (when (cond ((stringp match) 1209 (when (cond
1085 ;; Regexp string match on the group name. 1210 ((stringp match)
1086 (string-match match gnus-newsgroup-name)) 1211 ;; Regexp string match on the group name.
1087 ((or (symbolp match) 1212 (string-match match group))
1088 (gnus-functionp match)) 1213 ((eq match 'header)
1089 (cond ((gnus-functionp match) 1214 (let ((header (message-fetch-field (pop style))))
1090 ;; Function to be called. 1215 (and header
1091 (funcall match)) 1216 (string-match (pop style) header))))
1092 ((boundp match) 1217 ((or (symbolp match)
1093 ;; Variable to be checked. 1218 (gnus-functionp match))
1094 (symbol-value match)))) 1219 (cond
1095 ((listp match) 1220 ((gnus-functionp match)
1096 ;; This is a form to be evaled. 1221 ;; Function to be called.
1097 (eval match))) 1222 (funcall match))
1223 ((boundp match)
1224 ;; Variable to be checked.
1225 (symbol-value match))))
1226 ((listp match)
1227 ;; This is a form to be evaled.
1228 (eval match)))
1098 ;; We have a match, so we set the variables. 1229 ;; We have a match, so we set the variables.
1099 (while style 1230 (dolist (attribute style)
1100 (setq attribute (pop style) 1231 (setq element (pop attribute)
1101 value (cadr attribute) 1232 variable nil
1102 variable nil) 1233 filep nil)
1103 ;; We find the variable that is to be modified. 1234 (setq value
1104 (if (and (not (stringp (car attribute))) 1235 (cond
1105 (not (eq 'body (car attribute))) 1236 ((eq (car attribute) :file)
1106 (not (setq variable 1237 (setq filep t)
1107 (cdr (assq (car attribute) 1238 (cadr attribute))
1108 gnus-posting-style-alist))))) 1239 ((eq (car attribute) :value)
1109 (message "Couldn't find attribute %s" (car attribute)) 1240 (cadr attribute))
1110 ;; We get the value. 1241 (t
1111 (setq value-value 1242 (car attribute))))
1112 (cond ((stringp value) 1243 ;; We get the value.
1113 value) 1244 (setq v
1114 ((or (symbolp value) 1245 (cond
1115 (gnus-functionp value)) 1246 ((stringp value)
1116 (cond ((gnus-functionp value) 1247 value)
1117 (funcall value)) 1248 ((or (symbolp value)
1118 ((boundp value) 1249 (gnus-functionp value))
1119 (symbol-value value)))) 1250 (cond ((gnus-functionp value)
1120 ((listp value) 1251 (funcall value))
1121 (eval value)))) 1252 ((boundp value)
1122 (if variable 1253 (symbol-value value))))
1123 ;; This is an ordinary variable. 1254 ((listp value)
1124 (set (make-local-variable variable) value-value) 1255 (eval value))))
1125 ;; This is either a body or a header to be inserted in the 1256 ;; Translate obsolescent value.
1126 ;; message. 1257 (when (eq element 'signature-file)
1127 (when value-value 1258 (setq element 'signature
1128 (let ((attr (car attribute))) 1259 filep t))
1129 (make-local-variable 'message-setup-hook) 1260 ;; Get the contents of file elems.
1130 (if (eq 'body attr) 1261 (when (and filep v)
1131 (add-hook 'message-setup-hook 1262 (setq v (with-temp-buffer
1132 `(lambda () 1263 (insert-file-contents v)
1133 (save-excursion 1264 (buffer-string))))
1134 (message-goto-body) 1265 (setq results (delq (assoc element results) results))
1135 (insert ,value-value)))) 1266 (push (cons element v) results))))
1136 (add-hook 'message-setup-hook 1267 ;; Now we have all the styles, so we insert them.
1137 'gnus-message-insert-stylings) 1268 (setq name (assq 'name results)
1138 (push (cons (if (stringp attr) attr 1269 address (assq 'address results))
1139 (symbol-name attr)) 1270 (setq results (delq name (delq address results)))
1140 value-value) 1271 (make-local-variable 'message-setup-hook)
1141 gnus-message-style-insertions)))))))))))) 1272 (dolist (result results)
1142 1273 (add-hook 'message-setup-hook
1143(defun gnus-message-insert-stylings () 1274 (cond
1144 (let (val) 1275 ((eq 'eval (car result))
1145 (save-excursion 1276 'ignore)
1146 (message-goto-eoh) 1277 ((eq 'body (car result))
1147 (while (setq val (pop gnus-message-style-insertions)) 1278 `(lambda ()
1148 (when (cdr val) 1279 (save-excursion
1149 (insert (car val) ": " (cdr val) "\n")) 1280 (message-goto-body)
1150 (gnus-pull (car val) gnus-message-style-insertions))))) 1281 (insert ,(cdr result)))))
1282 ((eq 'signature (car result))
1283 (set (make-local-variable 'message-signature) nil)
1284 (set (make-local-variable 'message-signature-file) nil)
1285 (if (not (cdr result))
1286 'ignore
1287 `(lambda ()
1288 (save-excursion
1289 (let ((message-signature ,(cdr result)))
1290 (when message-signature
1291 (message-insert-signature)))))))
1292 (t
1293 (let ((header
1294 (if (symbolp (car result))
1295 (capitalize (symbol-name (car result)))
1296 (car result))))
1297 `(lambda ()
1298 (save-excursion
1299 (message-remove-header ,header)
1300 (let ((value ,(cdr result)))
1301 (when value
1302 (message-goto-eoh)
1303 (insert ,header ": " value "\n"))))))))))
1304 (when (or name address)
1305 (add-hook 'message-setup-hook
1306 `(lambda ()
1307 (set (make-local-variable 'user-mail-address)
1308 ,(or (cdr address) user-mail-address))
1309 (let ((user-full-name ,(or (cdr name) (user-full-name)))
1310 (user-mail-address
1311 ,(or (cdr address) user-mail-address)))
1312 (save-excursion
1313 (message-remove-header "From")
1314 (message-goto-eoh)
1315 (insert "From: " (message-make-from) "\n")))))))))
1151 1316
1152;;; Allow redefinition of functions. 1317;;; Allow redefinition of functions.
1153 1318
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 45658018139..999e3b039fe 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1,5 +1,6 @@
1;;; gnus-sum.el --- summary mode commands for Gnus 1;;; gnus-sum.el --- summary mode commands for Gnus
2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. 2;; Copyright (C) 1996, 1997, 1998, 1999, 2000
3;; Free Software Foundation, Inc.
3 4
4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 6;; Keywords: news
@@ -27,8 +28,6 @@
27 28
28(eval-when-compile (require 'cl)) 29(eval-when-compile (require 'cl))
29 30
30(eval-when-compile (require 'cl))
31
32(require 'gnus) 31(require 'gnus)
33(require 'gnus-group) 32(require 'gnus-group)
34(require 'gnus-spec) 33(require 'gnus-spec)
@@ -36,6 +35,7 @@
36(require 'gnus-int) 35(require 'gnus-int)
37(require 'gnus-undo) 36(require 'gnus-undo)
38(require 'gnus-util) 37(require 'gnus-util)
38(require 'mm-decode)
39(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) 39(autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t)
40 40
41(defcustom gnus-kill-summary-on-exit t 41(defcustom gnus-kill-summary-on-exit t
@@ -169,10 +169,15 @@ This variable will only be used if the value of
169 :type 'string) 169 :type 'string)
170 170
171(defcustom gnus-summary-goto-unread t 171(defcustom gnus-summary-goto-unread t
172 "*If t, marking commands will go to the next unread article. 172 "*If t, many commands will go to the next unread article.
173If `never', commands that usually go to the next unread article, will 173This applies to marking commands as well as other commands that
174go to the next article, whether it is read or not. 174\"naturally\" select the next article, like, for instance, `SPC' at
175If nil, only the marking commands will go to the next (un)read article." 175the end of an article.
176
177If nil, the marking commands do NOT go to the next unread article
178(they go to the next article instead). If `never', commands that
179usually go to the next unread article, will go to the next article,
180whether it is read or not."
176 :group 'gnus-summary-marks 181 :group 'gnus-summary-marks
177 :link '(custom-manual "(gnus)Setting Marks") 182 :link '(custom-manual "(gnus)Setting Marks")
178 :type '(choice (const :tag "off" nil) 183 :type '(choice (const :tag "off" nil)
@@ -254,8 +259,12 @@ equal will be included."
254(defcustom gnus-auto-select-first t 259(defcustom gnus-auto-select-first t
255 "*If nil, don't select the first unread article when entering a group. 260 "*If nil, don't select the first unread article when entering a group.
256If this variable is `best', select the highest-scored unread article 261If this variable is `best', select the highest-scored unread article
257in the group. If neither nil nor `best', select the first unread 262in the group. If t, select the first unread article.
258article. 263
264This variable can also be a function to place point on a likely
265subject line. Useful values include `gnus-summary-first-unread-subject',
266`gnus-summary-first-unread-article' and
267`gnus-summary-best-unread-article'.
259 268
260If you want to prevent automatic selection of the first unread article 269If you want to prevent automatic selection of the first unread article
261in some newsgroups, set the variable to nil in 270in some newsgroups, set the variable to nil in
@@ -263,7 +272,10 @@ in some newsgroups, set the variable to nil in
263 :group 'gnus-group-select 272 :group 'gnus-group-select
264 :type '(choice (const :tag "none" nil) 273 :type '(choice (const :tag "none" nil)
265 (const best) 274 (const best)
266 (sexp :menu-tag "first" t))) 275 (sexp :menu-tag "first" t)
276 (function-item gnus-summary-first-unread-subject)
277 (function-item gnus-summary-first-unread-article)
278 (function-item gnus-summary-best-unread-article)))
267 279
268(defcustom gnus-auto-select-next t 280(defcustom gnus-auto-select-next t
269 "*If non-nil, offer to go to the next group from the end of the previous. 281 "*If non-nil, offer to go to the next group from the end of the previous.
@@ -304,6 +316,7 @@ and non-`vertical', do both horizontal and vertical recentering."
304 :group 'gnus-summary-maneuvering 316 :group 'gnus-summary-maneuvering
305 :type '(choice (const :tag "none" nil) 317 :type '(choice (const :tag "none" nil)
306 (const vertical) 318 (const vertical)
319 (integer :tag "height")
307 (sexp :menu-tag "both" t))) 320 (sexp :menu-tag "both" t)))
308 321
309(defcustom gnus-show-all-headers nil 322(defcustom gnus-show-all-headers nil
@@ -330,13 +343,6 @@ variable."
330 :group 'gnus-article-various 343 :group 'gnus-article-various
331 :type 'boolean) 344 :type 'boolean)
332 345
333(defcustom gnus-show-mime nil
334 "*If non-nil, do mime processing of articles.
335The articles will simply be fed to the function given by
336`gnus-show-mime-method'."
337 :group 'gnus-article-mime
338 :type 'boolean)
339
340(defcustom gnus-move-split-methods nil 346(defcustom gnus-move-split-methods nil
341 "*Variable used to suggest where articles are to be moved to. 347 "*Variable used to suggest where articles are to be moved to.
342It uses the same syntax as the `gnus-split-methods' variable." 348It uses the same syntax as the `gnus-split-methods' variable."
@@ -345,7 +351,7 @@ It uses the same syntax as the `gnus-split-methods' variable."
345 (cons :value ("" "") regexp (repeat string)) 351 (cons :value ("" "") regexp (repeat string))
346 (sexp :value nil)))) 352 (sexp :value nil))))
347 353
348(defcustom gnus-unread-mark ? ;space 354(defcustom gnus-unread-mark ? ;Whitespace
349 "*Mark used for unread articles." 355 "*Mark used for unread articles."
350 :group 'gnus-summary-marks 356 :group 'gnus-summary-marks
351 :type 'character) 357 :type 'character)
@@ -460,7 +466,7 @@ It uses the same syntax as the `gnus-split-methods' variable."
460 :group 'gnus-summary-marks 466 :group 'gnus-summary-marks
461 :type 'character) 467 :type 'character)
462 468
463(defcustom gnus-empty-thread-mark ? ;space 469(defcustom gnus-empty-thread-mark ? ;Whitespace
464 "*There is no thread under the article." 470 "*There is no thread under the article."
465 :group 'gnus-summary-marks 471 :group 'gnus-summary-marks
466 :type 'character) 472 :type 'character)
@@ -475,6 +481,19 @@ It uses the same syntax as the `gnus-split-methods' variable."
475 :group 'gnus-extract-view 481 :group 'gnus-extract-view
476 :type 'boolean) 482 :type 'boolean)
477 483
484(defcustom gnus-auto-expirable-marks
485 (list gnus-killed-mark gnus-del-mark gnus-catchup-mark
486 gnus-low-score-mark gnus-ancient-mark gnus-read-mark
487 gnus-souped-mark gnus-duplicate-mark)
488 "*The list of marks converted into expiration if a group is auto-expirable."
489 :group 'gnus-summary
490 :type '(repeat character))
491
492(defcustom gnus-inhibit-user-auto-expire t
493 "*If non-nil, user marking commands will not mark an article as expirable, even if the group has auto-expire turned on."
494 :group 'gnus-summary
495 :type 'boolean)
496
478(defcustom gnus-view-pseudos nil 497(defcustom gnus-view-pseudos nil
479 "*If `automatic', pseudo-articles will be viewed automatically. 498 "*If `automatic', pseudo-articles will be viewed automatically.
480If `not-confirm', pseudos will be viewed automatically, and the user 499If `not-confirm', pseudos will be viewed automatically, and the user
@@ -506,7 +525,7 @@ with some simple extensions.
506 :group 'gnus-threading 525 :group 'gnus-threading
507 :type 'string) 526 :type 'string)
508 527
509(defcustom gnus-summary-mode-line-format "Gnus: %%b [%A] %Z" 528(defcustom gnus-summary-mode-line-format "Gnus: %g [%A] %Z"
510 "*The format specification for the summary mode line. 529 "*The format specification for the summary mode line.
511It works along the same lines as a normal formatting string, 530It works along the same lines as a normal formatting string,
512with some simple extensions: 531with some simple extensions:
@@ -529,6 +548,15 @@ with some simple extensions:
529 :group 'gnus-summary-format 548 :group 'gnus-summary-format
530 :type 'string) 549 :type 'string)
531 550
551(defcustom gnus-list-identifiers nil
552 "Regexp that matches list identifiers to be removed from subject.
553This can also be a list of regexps."
554 :group 'gnus-summary-format
555 :group 'gnus-article-hiding
556 :type '(choice (const :tag "none" nil)
557 (regexp :value ".*")
558 (repeat :value (".*") regexp)))
559
532(defcustom gnus-summary-mark-below 0 560(defcustom gnus-summary-mark-below 0
533 "*Mark all articles with a score below this variable as read. 561 "*Mark all articles with a score below this variable as read.
534This variable is local to each summary buffer and usually set by the 562This variable is local to each summary buffer and usually set by the
@@ -593,7 +621,7 @@ See `gnus-thread-score-function' for en explanation of what a
593\"thread score\" is. 621\"thread score\" is.
594 622
595This variable is local to the summary buffers." 623This variable is local to the summary buffers."
596 :group 'gnus-treading 624 :group 'gnus-threading
597 :group 'gnus-score-default 625 :group 'gnus-score-default
598 :type '(choice (const :tag "off" nil) 626 :type '(choice (const :tag "off" nil)
599 integer)) 627 integer))
@@ -665,38 +693,14 @@ is not run if `gnus-visual' is nil."
665 :group 'gnus-summary-visual 693 :group 'gnus-summary-visual
666 :type 'hook) 694 :type 'hook)
667 695
668(defcustom gnus-structured-field-decoder 696(defcustom gnus-parse-headers-hook nil
669 (if (and (featurep 'mule)
670 (boundp 'enable-multibyte-characters))
671 (lambda (string)
672 (if (and enable-multibyte-characters gnus-mule-coding-system)
673 (decode-coding-string string gnus-mule-coding-system)
674 string))
675 'identity)
676 "Function to decode non-ASCII characters in structured field for summary."
677 :group 'gnus-various
678 :type 'function)
679
680(defcustom gnus-unstructured-field-decoder
681 (if (and (featurep 'mule)
682 (boundp 'enable-multibyte-characters))
683 (lambda (string)
684 (if (and enable-multibyte-characters gnus-mule-coding-system)
685 (decode-coding-string string gnus-mule-coding-system)
686 string))
687 'identity)
688 "Function to decode non-ASCII characters in unstructured field for summary."
689 :group 'gnus-various
690 :type 'function)
691
692(defcustom gnus-parse-headers-hook
693 (list 'gnus-hack-decode-rfc1522 'gnus-decode-rfc1522)
694 "*A hook called before parsing the headers." 697 "*A hook called before parsing the headers."
695 :group 'gnus-various 698 :group 'gnus-various
696 :type 'hook) 699 :type 'hook)
697 700
698(defcustom gnus-exit-group-hook nil 701(defcustom gnus-exit-group-hook nil
699 "*A hook called when exiting (not quitting) summary mode." 702 "*A hook called when exiting summary mode.
703This hook is not called from the non-updating exit commands like `Q'."
700 :group 'gnus-various 704 :group 'gnus-various
701 :type 'hook) 705 :type 'hook)
702 706
@@ -795,10 +799,107 @@ mark: The articles mark."
795The function is called with one parameter, the article header vector, 799The function is called with one parameter, the article header vector,
796which it may alter in any way.") 800which it may alter in any way.")
797 801
802(defvar gnus-decode-encoded-word-function 'mail-decode-encoded-word-string
803 "Variable that says which function should be used to decode a string with encoded words.")
804
805(defcustom gnus-extra-headers nil
806 "*Extra headers to parse."
807 :group 'gnus-summary
808 :type '(repeat symbol))
809
810(defcustom gnus-ignored-from-addresses
811 (and user-mail-address (regexp-quote user-mail-address))
812 "*Regexp of From headers that may be suppressed in favor of To headers."
813 :group 'gnus-summary
814 :type 'regexp)
815
816(defcustom gnus-group-charset-alist
817 '(("^hk\\>\\|^tw\\>\\|\\<big5\\>" cn-big5)
818 ("^cn\\>\\|\\<chinese\\>" cn-gb-2312)
819 ("^fj\\>\\|^japan\\>" iso-2022-jp-2)
820 ("^tnn\\>\\|^pin\\>\\|^sci.lang.japan" iso-2022-7bit)
821 ("^relcom\\>" koi8-r)
822 ("^fido7\\>" koi8-r)
823 ("^\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2)
824 ("^israel\\>" iso-8859-1)
825 ("^han\\>" euc-kr)
826 ("^alt.chinese.text.big5\\>" chinese-big5)
827 ("^soc.culture.vietnamese\\>" vietnamese-viqr)
828 ("^\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1)
829 (".*" iso-8859-1))
830 "Alist of regexps (to match group names) and default charsets to be used when reading."
831 :type '(repeat (list (regexp :tag "Group")
832 (symbol :tag "Charset")))
833 :group 'gnus-charset)
834
835(defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit x-unknown)
836 "List of charsets that should be ignored.
837When these charsets are used in the \"charset\" parameter, the
838default charset will be used instead."
839 :type '(repeat symbol)
840 :group 'gnus-charset)
841
842(defcustom gnus-group-ignored-charsets-alist
843 '(("alt\\.chinese\\.text" iso-8859-1))
844 "Alist of regexps (to match group names) and charsets that should be ignored.
845When these charsets are used in the \"charset\" parameter, the
846default charset will be used instead."
847 :type '(repeat (cons (regexp :tag "Group")
848 (repeat symbol)))
849 :group 'gnus-charset)
850
851(defcustom gnus-group-highlight-words-alist nil
852 "Alist of group regexps and highlight regexps.
853This variable uses the same syntax as `gnus-emphasis-alist'."
854 :type '(repeat (cons (regexp :tag "Group")
855 (repeat (list (regexp :tag "Highlight regexp")
856 (number :tag "Group for entire word" 0)
857 (number :tag "Group for displayed part" 0)
858 (symbol :tag "Face"
859 gnus-emphasis-highlight-words)))))
860 :group 'gnus-summary-visual)
861
862(defcustom gnus-summary-show-article-charset-alist
863 nil
864 "Alist of number and charset.
865The article will be shown with the charset corresponding to the
866numbered argument.
867For example: ((1 . cn-gb-2312) (2 . big5))."
868 :type '(repeat (cons (number :tag "Argument" 1)
869 (symbol :tag "Charset")))
870 :group 'gnus-charset)
871
872(defcustom gnus-preserve-marks t
873 "Whether marks are preserved when moving, copying and respooling messages."
874 :type 'boolean
875 :group 'gnus-summary-marks)
876
877(defcustom gnus-alter-articles-to-read-function nil
878 "Function to be called to alter the list of articles to be selected."
879 :type 'function
880 :group 'gnus-summary)
881
882(defcustom gnus-orphan-score nil
883 "*All orphans get this score added. Set in the score file."
884 :group 'gnus-score-default
885 :type '(choice (const nil)
886 integer))
887
888(defcustom gnus-summary-save-parts-default-mime "image/.*"
889 "*A regexp to match MIME parts when saving multiple parts of a message
890with gnus-summary-save-parts (X m). This regexp will be used by default
891when prompting the user for which type of files to save."
892 :group 'gnus-summary
893 :type 'regexp)
894
895
798;;; Internal variables 896;;; Internal variables
799 897
898(defvar gnus-article-mime-handles nil)
899(defvar gnus-article-decoded-p nil)
800(defvar gnus-scores-exclude-files nil) 900(defvar gnus-scores-exclude-files nil)
801(defvar gnus-page-broken nil) 901(defvar gnus-page-broken nil)
902(defvar gnus-inhibit-mime-unbuttonizing nil)
802 903
803(defvar gnus-original-article nil) 904(defvar gnus-original-article nil)
804(defvar gnus-article-internal-prepare-hook nil) 905(defvar gnus-article-internal-prepare-hook nil)
@@ -806,6 +907,11 @@ which it may alter in any way.")
806 907
807(defvar gnus-thread-indent-array nil) 908(defvar gnus-thread-indent-array nil)
808(defvar gnus-thread-indent-array-level gnus-thread-indent-level) 909(defvar gnus-thread-indent-array-level gnus-thread-indent-level)
910(defvar gnus-sort-gathered-threads-function 'gnus-thread-sort-by-number
911 "Function called to sort the articles within a thread after it has been gathered together.")
912
913(defvar gnus-summary-save-parts-type-history nil)
914(defvar gnus-summary-save-parts-last-directory nil)
809 915
810;; Avoid highlighting in kill files. 916;; Avoid highlighting in kill files.
811(defvar gnus-summary-inhibit-highlight nil) 917(defvar gnus-summary-inhibit-highlight nil)
@@ -853,6 +959,7 @@ which it may alter in any way.")
853 (?l (bbb-grouplens-score gnus-tmp-header) ?s) 959 (?l (bbb-grouplens-score gnus-tmp-header) ?s)
854 (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) 960 (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d)
855 (?U gnus-tmp-unread ?c) 961 (?U gnus-tmp-unread ?c)
962 (?f (gnus-summary-from-or-to-or-newsgroups gnus-tmp-header) ?s)
856 (?t (gnus-summary-number-of-articles-in-thread 963 (?t (gnus-summary-number-of-articles-in-thread
857 (and (boundp 'thread) (car thread)) gnus-tmp-level) 964 (and (boundp 'thread) (car thread)) gnus-tmp-level)
858 ?d) 965 ?d)
@@ -861,9 +968,9 @@ which it may alter in any way.")
861 ?c) 968 ?c)
862 (?u gnus-tmp-user-defined ?s) 969 (?u gnus-tmp-user-defined ?s)
863 (?P (gnus-pick-line-number) ?d)) 970 (?P (gnus-pick-line-number) ?d))
864 "An alist of format specifications that can appear in summary lines, 971 "An alist of format specifications that can appear in summary lines.
865and what variables they correspond with, along with the type of the 972These are paired with what variables they correspond with, along with
866variable (string, integer, character, etc).") 973the type of the variable (string, integer, character, etc).")
867 974
868(defvar gnus-summary-dummy-line-format-alist 975(defvar gnus-summary-dummy-line-format-alist
869 `((?S gnus-tmp-subject ?s) 976 `((?S gnus-tmp-subject ?s)
@@ -979,6 +1086,9 @@ variable (string, integer, character, etc).")
979(defvar gnus-have-all-headers nil) 1086(defvar gnus-have-all-headers nil)
980(defvar gnus-last-article nil) 1087(defvar gnus-last-article nil)
981(defvar gnus-newsgroup-history nil) 1088(defvar gnus-newsgroup-history nil)
1089(defvar gnus-newsgroup-charset nil)
1090(defvar gnus-newsgroup-ephemeral-charset nil)
1091(defvar gnus-newsgroup-ephemeral-ignored-charsets nil)
982 1092
983(defconst gnus-summary-local-variables 1093(defconst gnus-summary-local-variables
984 '(gnus-newsgroup-name 1094 '(gnus-newsgroup-name
@@ -1000,8 +1110,10 @@ variable (string, integer, character, etc).")
1000 gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay 1110 gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay
1001 gnus-newsgroup-scored gnus-newsgroup-kill-headers 1111 gnus-newsgroup-scored gnus-newsgroup-kill-headers
1002 gnus-thread-expunge-below 1112 gnus-thread-expunge-below
1003 gnus-score-alist gnus-current-score-file gnus-summary-expunge-below 1113 gnus-score-alist gnus-current-score-file
1114 (gnus-summary-expunge-below . global)
1004 (gnus-summary-mark-below . global) 1115 (gnus-summary-mark-below . global)
1116 (gnus-orphan-score . global)
1005 gnus-newsgroup-active gnus-scores-exclude-files 1117 gnus-newsgroup-active gnus-scores-exclude-files
1006 gnus-newsgroup-history gnus-newsgroup-ancient 1118 gnus-newsgroup-history gnus-newsgroup-ancient
1007 gnus-newsgroup-sparse gnus-newsgroup-process-stack 1119 gnus-newsgroup-sparse gnus-newsgroup-process-stack
@@ -1010,16 +1122,55 @@ variable (string, integer, character, etc).")
1010 (gnus-newsgroup-expunged-tally . 0) 1122 (gnus-newsgroup-expunged-tally . 0)
1011 gnus-cache-removable-articles gnus-newsgroup-cached 1123 gnus-cache-removable-articles gnus-newsgroup-cached
1012 gnus-newsgroup-data gnus-newsgroup-data-reverse 1124 gnus-newsgroup-data gnus-newsgroup-data-reverse
1013 gnus-newsgroup-limit gnus-newsgroup-limits) 1125 gnus-newsgroup-limit gnus-newsgroup-limits
1126 gnus-newsgroup-charset)
1014 "Variables that are buffer-local to the summary buffers.") 1127 "Variables that are buffer-local to the summary buffers.")
1015 1128
1016;; Byte-compiler warning. 1129;; Byte-compiler warning.
1017(defvar gnus-article-mode-map) 1130(defvar gnus-article-mode-map)
1018 1131
1132;; MIME stuff.
1133
1134(defvar gnus-decode-encoded-word-methods
1135 '(mail-decode-encoded-word-string)
1136 "List of methods used to decode encoded words.
1137
1138This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
1139FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
1140(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
1141whose names match REGEXP.
1142
1143For example:
1144((\"chinese\" . gnus-decode-encoded-word-string-by-guess)
1145 mail-decode-encoded-word-string
1146 (\"chinese\" . rfc1843-decode-string))")
1147
1148(defvar gnus-decode-encoded-word-methods-cache nil)
1149
1150(defun gnus-multi-decode-encoded-word-string (string)
1151 "Apply the functions from `gnus-encoded-word-methods' that match."
1152 (unless (and gnus-decode-encoded-word-methods-cache
1153 (eq gnus-newsgroup-name
1154 (car gnus-decode-encoded-word-methods-cache)))
1155 (setq gnus-decode-encoded-word-methods-cache (list gnus-newsgroup-name))
1156 (mapcar (lambda (x)
1157 (if (symbolp x)
1158 (nconc gnus-decode-encoded-word-methods-cache (list x))
1159 (if (and gnus-newsgroup-name
1160 (string-match (car x) gnus-newsgroup-name))
1161 (nconc gnus-decode-encoded-word-methods-cache
1162 (list (cdr x))))))
1163 gnus-decode-encoded-word-methods))
1164 (let ((xlist gnus-decode-encoded-word-methods-cache))
1165 (pop xlist)
1166 (while xlist
1167 (setq string (funcall (pop xlist) string))))
1168 string)
1169
1019;; Subject simplification. 1170;; Subject simplification.
1020 1171
1021(defun gnus-simplify-whitespace (str) 1172(defun gnus-simplify-whitespace (str)
1022 "Remove excessive whitespace." 1173 "Remove excessive whitespace from STR."
1023 (let ((mystr str)) 1174 (let ((mystr str))
1024 ;; Multiple spaces. 1175 ;; Multiple spaces.
1025 (while (string-match "[ \t][ \t]+" mystr) 1176 (while (string-match "[ \t][ \t]+" mystr)
@@ -1064,7 +1215,7 @@ If RE-ONLY is non-nil, strip leading `Re:'s only."
1064(defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext) 1215(defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext)
1065 (goto-char (point-min)) 1216 (goto-char (point-min))
1066 (while (re-search-forward regexp nil t) 1217 (while (re-search-forward regexp nil t)
1067 (replace-match (or newtext "")))) 1218 (replace-match (or newtext ""))))
1068 1219
1069(defun gnus-simplify-buffer-fuzzy () 1220(defun gnus-simplify-buffer-fuzzy ()
1070 "Simplify string in the buffer fuzzily. 1221 "Simplify string in the buffer fuzzily.
@@ -1072,7 +1223,7 @@ The string in the accessible portion of the current buffer is simplified.
1072It is assumed to be a single-line subject. 1223It is assumed to be a single-line subject.
1073Whitespace is generally cleaned up, and miscellaneous leading/trailing 1224Whitespace is generally cleaned up, and miscellaneous leading/trailing
1074matter is removed. Additional things can be deleted by setting 1225matter is removed. Additional things can be deleted by setting
1075gnus-simplify-subject-fuzzy-regexp." 1226`gnus-simplify-subject-fuzzy-regexp'."
1076 (let ((case-fold-search t) 1227 (let ((case-fold-search t)
1077 (modified-tick)) 1228 (modified-tick))
1078 (gnus-simplify-buffer-fuzzy-step "\t" " ") 1229 (gnus-simplify-buffer-fuzzy-step "\t" " ")
@@ -1196,6 +1347,8 @@ increase the score of each group you read."
1196 "\M-\C-h" gnus-summary-hide-thread 1347 "\M-\C-h" gnus-summary-hide-thread
1197 "\M-\C-f" gnus-summary-next-thread 1348 "\M-\C-f" gnus-summary-next-thread
1198 "\M-\C-b" gnus-summary-prev-thread 1349 "\M-\C-b" gnus-summary-prev-thread
1350 [(meta down)] gnus-summary-next-thread
1351 [(meta up)] gnus-summary-prev-thread
1199 "\M-\C-u" gnus-summary-up-thread 1352 "\M-\C-u" gnus-summary-up-thread
1200 "\M-\C-d" gnus-summary-down-thread 1353 "\M-\C-d" gnus-summary-down-thread
1201 "&" gnus-summary-execute-command 1354 "&" gnus-summary-execute-command
@@ -1206,6 +1359,7 @@ increase the score of each group you read."
1206 "\C-c\M-\C-s" gnus-summary-limit-include-expunged 1359 "\C-c\M-\C-s" gnus-summary-limit-include-expunged
1207 "\C-c\C-s\C-n" gnus-summary-sort-by-number 1360 "\C-c\C-s\C-n" gnus-summary-sort-by-number
1208 "\C-c\C-s\C-l" gnus-summary-sort-by-lines 1361 "\C-c\C-s\C-l" gnus-summary-sort-by-lines
1362 "\C-c\C-s\C-c" gnus-summary-sort-by-chars
1209 "\C-c\C-s\C-a" gnus-summary-sort-by-author 1363 "\C-c\C-s\C-a" gnus-summary-sort-by-author
1210 "\C-c\C-s\C-s" gnus-summary-sort-by-subject 1364 "\C-c\C-s\C-s" gnus-summary-sort-by-subject
1211 "\C-c\C-s\C-d" gnus-summary-sort-by-date 1365 "\C-c\C-s\C-d" gnus-summary-sort-by-date
@@ -1215,7 +1369,6 @@ increase the score of each group you read."
1215 "\M-g" gnus-summary-rescan-group 1369 "\M-g" gnus-summary-rescan-group
1216 "w" gnus-summary-stop-page-breaking 1370 "w" gnus-summary-stop-page-breaking
1217 "\C-c\C-r" gnus-summary-caesar-message 1371 "\C-c\C-r" gnus-summary-caesar-message
1218 "\M-t" gnus-summary-toggle-mime
1219 "f" gnus-summary-followup 1372 "f" gnus-summary-followup
1220 "F" gnus-summary-followup-with-original 1373 "F" gnus-summary-followup-with-original
1221 "C" gnus-summary-cancel-article 1374 "C" gnus-summary-cancel-article
@@ -1237,13 +1390,14 @@ increase the score of each group you read."
1237 "a" gnus-summary-post-news 1390 "a" gnus-summary-post-news
1238 "x" gnus-summary-limit-to-unread 1391 "x" gnus-summary-limit-to-unread
1239 "s" gnus-summary-isearch-article 1392 "s" gnus-summary-isearch-article
1240 "t" gnus-article-hide-headers 1393 "t" gnus-summary-toggle-header
1241 "g" gnus-summary-show-article 1394 "g" gnus-summary-show-article
1242 "l" gnus-summary-goto-last-article 1395 "l" gnus-summary-goto-last-article
1243 "\C-c\C-v\C-v" gnus-uu-decode-uu-view 1396 "\C-c\C-v\C-v" gnus-uu-decode-uu-view
1244 "\C-d" gnus-summary-enter-digest-group 1397 "\C-d" gnus-summary-enter-digest-group
1245 "\M-\C-d" gnus-summary-read-document 1398 "\M-\C-d" gnus-summary-read-document
1246 "\M-\C-e" gnus-summary-edit-parameters 1399 "\M-\C-e" gnus-summary-edit-parameters
1400 "\M-\C-a" gnus-summary-customize-parameters
1247 "\C-c\C-b" gnus-bug 1401 "\C-c\C-b" gnus-bug
1248 "*" gnus-cache-enter-article 1402 "*" gnus-cache-enter-article
1249 "\M-*" gnus-cache-remove-article 1403 "\M-*" gnus-cache-remove-article
@@ -1254,6 +1408,9 @@ increase the score of each group you read."
1254 "\M-i" gnus-symbolic-argument 1408 "\M-i" gnus-symbolic-argument
1255 "h" gnus-summary-select-article-buffer 1409 "h" gnus-summary-select-article-buffer
1256 1410
1411 "b" gnus-article-view-part
1412 "\M-t" gnus-summary-toggle-display-buttonized
1413
1257 "V" gnus-summary-score-map 1414 "V" gnus-summary-score-map
1258 "X" gnus-uu-extract-map 1415 "X" gnus-uu-extract-map
1259 "S" gnus-summary-send-map) 1416 "S" gnus-summary-send-map)
@@ -1295,12 +1452,14 @@ increase the score of each group you read."
1295 "a" gnus-summary-limit-to-author 1452 "a" gnus-summary-limit-to-author
1296 "u" gnus-summary-limit-to-unread 1453 "u" gnus-summary-limit-to-unread
1297 "m" gnus-summary-limit-to-marks 1454 "m" gnus-summary-limit-to-marks
1455 "M" gnus-summary-limit-exclude-marks
1298 "v" gnus-summary-limit-to-score 1456 "v" gnus-summary-limit-to-score
1299 "*" gnus-summary-limit-include-cached 1457 "*" gnus-summary-limit-include-cached
1300 "D" gnus-summary-limit-include-dormant 1458 "D" gnus-summary-limit-include-dormant
1301 "T" gnus-summary-limit-include-thread 1459 "T" gnus-summary-limit-include-thread
1302 "d" gnus-summary-limit-exclude-dormant 1460 "d" gnus-summary-limit-exclude-dormant
1303 "t" gnus-summary-limit-to-age 1461 "t" gnus-summary-limit-to-age
1462 "x" gnus-summary-limit-to-extra
1304 "E" gnus-summary-limit-include-expunged 1463 "E" gnus-summary-limit-include-expunged
1305 "c" gnus-summary-limit-exclude-childless-dormant 1464 "c" gnus-summary-limit-exclude-childless-dormant
1306 "C" gnus-summary-limit-mark-excluded-as-read) 1465 "C" gnus-summary-limit-mark-excluded-as-read)
@@ -1371,11 +1530,13 @@ increase the score of each group you read."
1371 "e" gnus-summary-end-of-article 1530 "e" gnus-summary-end-of-article
1372 "^" gnus-summary-refer-parent-article 1531 "^" gnus-summary-refer-parent-article
1373 "r" gnus-summary-refer-parent-article 1532 "r" gnus-summary-refer-parent-article
1533 "D" gnus-summary-enter-digest-group
1374 "R" gnus-summary-refer-references 1534 "R" gnus-summary-refer-references
1375 "T" gnus-summary-refer-thread 1535 "T" gnus-summary-refer-thread
1376 "g" gnus-summary-show-article 1536 "g" gnus-summary-show-article
1377 "s" gnus-summary-isearch-article 1537 "s" gnus-summary-isearch-article
1378 "P" gnus-summary-print-article) 1538 "P" gnus-summary-print-article
1539 "t" gnus-article-babel)
1379 1540
1380 (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) 1541 (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map)
1381 "b" gnus-article-add-buttons 1542 "b" gnus-article-add-buttons
@@ -1383,15 +1544,19 @@ increase the score of each group you read."
1383 "o" gnus-article-treat-overstrike 1544 "o" gnus-article-treat-overstrike
1384 "e" gnus-article-emphasize 1545 "e" gnus-article-emphasize
1385 "w" gnus-article-fill-cited-article 1546 "w" gnus-article-fill-cited-article
1547 "Q" gnus-article-fill-long-lines
1548 "C" gnus-article-capitalize-sentences
1386 "c" gnus-article-remove-cr 1549 "c" gnus-article-remove-cr
1387 "q" gnus-article-de-quoted-unreadable 1550 "q" gnus-article-de-quoted-unreadable
1551 "6" gnus-article-de-base64-unreadable
1552 "Z" gnus-article-decode-HZ
1553 "h" gnus-article-wash-html
1388 "f" gnus-article-display-x-face 1554 "f" gnus-article-display-x-face
1389 "l" gnus-summary-stop-page-breaking 1555 "l" gnus-summary-stop-page-breaking
1390 "r" gnus-summary-caesar-message 1556 "r" gnus-summary-caesar-message
1391 "t" gnus-article-hide-headers 1557 "t" gnus-summary-toggle-header
1392 "v" gnus-summary-verbose-headers 1558 "v" gnus-summary-verbose-headers
1393 "m" gnus-summary-toggle-mime 1559 "H" gnus-article-strip-headers-in-body
1394 "h" gnus-article-treat-html
1395 "d" gnus-article-treat-dumbquotes) 1560 "d" gnus-article-treat-dumbquotes)
1396 1561
1397 (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) 1562 (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map)
@@ -1401,7 +1566,9 @@ increase the score of each group you read."
1401 "s" gnus-article-hide-signature 1566 "s" gnus-article-hide-signature
1402 "c" gnus-article-hide-citation 1567 "c" gnus-article-hide-citation
1403 "C" gnus-article-hide-citation-in-followups 1568 "C" gnus-article-hide-citation-in-followups
1569 "l" gnus-article-hide-list-identifiers
1404 "p" gnus-article-hide-pgp 1570 "p" gnus-article-hide-pgp
1571 "B" gnus-article-strip-banner
1405 "P" gnus-article-hide-pem 1572 "P" gnus-article-hide-pem
1406 "\C-c" gnus-article-hide-citation-maybe) 1573 "\C-c" gnus-article-hide-citation-maybe)
1407 1574
@@ -1411,6 +1578,12 @@ increase the score of each group you read."
1411 "c" gnus-article-highlight-citation 1578 "c" gnus-article-highlight-citation
1412 "s" gnus-article-highlight-signature) 1579 "s" gnus-article-highlight-signature)
1413 1580
1581 (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map)
1582 "w" gnus-article-decode-mime-words
1583 "c" gnus-article-decode-charset
1584 "v" gnus-mime-view-all-parts
1585 "b" gnus-article-view-part)
1586
1414 (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) 1587 (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map)
1415 "z" gnus-article-date-ut 1588 "z" gnus-article-date-ut
1416 "u" gnus-article-date-ut 1589 "u" gnus-article-date-ut
@@ -1426,7 +1599,8 @@ increase the score of each group you read."
1426 "m" gnus-article-strip-multiple-blank-lines 1599 "m" gnus-article-strip-multiple-blank-lines
1427 "a" gnus-article-strip-blank-lines 1600 "a" gnus-article-strip-blank-lines
1428 "A" gnus-article-strip-all-blank-lines 1601 "A" gnus-article-strip-all-blank-lines
1429 "s" gnus-article-strip-leading-space) 1602 "s" gnus-article-strip-leading-space
1603 "e" gnus-article-strip-trailing-space)
1430 1604
1431 (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) 1605 (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map)
1432 "v" gnus-version 1606 "v" gnus-version
@@ -1440,6 +1614,7 @@ increase the score of each group you read."
1440 "\M-\C-e" gnus-summary-expire-articles-now 1614 "\M-\C-e" gnus-summary-expire-articles-now
1441 "\177" gnus-summary-delete-article 1615 "\177" gnus-summary-delete-article
1442 [delete] gnus-summary-delete-article 1616 [delete] gnus-summary-delete-article
1617 [backspace] gnus-summary-delete-article
1443 "m" gnus-summary-move-article 1618 "m" gnus-summary-move-article
1444 "r" gnus-summary-respool-article 1619 "r" gnus-summary-respool-article
1445 "w" gnus-summary-edit-article 1620 "w" gnus-summary-edit-article
@@ -1460,7 +1635,17 @@ increase the score of each group you read."
1460 "h" gnus-summary-save-article-folder 1635 "h" gnus-summary-save-article-folder
1461 "v" gnus-summary-save-article-vm 1636 "v" gnus-summary-save-article-vm
1462 "p" gnus-summary-pipe-output 1637 "p" gnus-summary-pipe-output
1463 "s" gnus-soup-add-article)) 1638 "s" gnus-soup-add-article)
1639
1640 (gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map)
1641 "b" gnus-summary-display-buttonized
1642 "m" gnus-summary-repair-multipart
1643 "v" gnus-article-view-part
1644 "o" gnus-article-save-part
1645 "c" gnus-article-copy-part
1646 "e" gnus-article-externalize-part
1647 "i" gnus-article-inline-part
1648 "|" gnus-article-pipe-part))
1464 1649
1465(defun gnus-summary-make-menu-bar () 1650(defun gnus-summary-make-menu-bar ()
1466 (gnus-turn-off-edit-menu 'summary) 1651 (gnus-turn-off-edit-menu 'summary)
@@ -1503,13 +1688,21 @@ increase the score of each group you read."
1503 ["Headers" gnus-article-hide-headers t] 1688 ["Headers" gnus-article-hide-headers t]
1504 ["Signature" gnus-article-hide-signature t] 1689 ["Signature" gnus-article-hide-signature t]
1505 ["Citation" gnus-article-hide-citation t] 1690 ["Citation" gnus-article-hide-citation t]
1691 ["List identifiers" gnus-article-hide-list-identifiers t]
1506 ["PGP" gnus-article-hide-pgp t] 1692 ["PGP" gnus-article-hide-pgp t]
1693 ["Banner" gnus-article-strip-banner t]
1507 ["Boring headers" gnus-article-hide-boring-headers t]) 1694 ["Boring headers" gnus-article-hide-boring-headers t])
1508 ("Highlight" 1695 ("Highlight"
1509 ["All" gnus-article-highlight t] 1696 ["All" gnus-article-highlight t]
1510 ["Headers" gnus-article-highlight-headers t] 1697 ["Headers" gnus-article-highlight-headers t]
1511 ["Signature" gnus-article-highlight-signature t] 1698 ["Signature" gnus-article-highlight-signature t]
1512 ["Citation" gnus-article-highlight-citation t]) 1699 ["Citation" gnus-article-highlight-citation t])
1700 ("MIME"
1701 ["Words" gnus-article-decode-mime-words t]
1702 ["Charset" gnus-article-decode-charset t]
1703 ["QP" gnus-article-de-quoted-unreadable t]
1704 ["Base64" gnus-article-de-base64-unreadable t]
1705 ["View all" gnus-mime-view-all-parts t])
1513 ("Date" 1706 ("Date"
1514 ["Local" gnus-article-date-local t] 1707 ["Local" gnus-article-date-local t]
1515 ["ISO8601" gnus-article-date-iso8601 t] 1708 ["ISO8601" gnus-article-date-iso8601 t]
@@ -1524,23 +1717,27 @@ increase the score of each group you read."
1524 ["Trailing" gnus-article-remove-trailing-blank-lines t] 1717 ["Trailing" gnus-article-remove-trailing-blank-lines t]
1525 ["All of the above" gnus-article-strip-blank-lines t] 1718 ["All of the above" gnus-article-strip-blank-lines t]
1526 ["All" gnus-article-strip-all-blank-lines t] 1719 ["All" gnus-article-strip-all-blank-lines t]
1527 ["Leading space" gnus-article-strip-leading-space t]) 1720 ["Leading space" gnus-article-strip-leading-space t]
1721 ["Trailing space" gnus-article-strip-trailing-space t])
1528 ["Overstrike" gnus-article-treat-overstrike t] 1722 ["Overstrike" gnus-article-treat-overstrike t]
1529 ["Dumb quotes" gnus-article-treat-dumbquotes t] 1723 ["Dumb quotes" gnus-article-treat-dumbquotes t]
1530 ["Emphasis" gnus-article-emphasize t] 1724 ["Emphasis" gnus-article-emphasize t]
1531 ["Word wrap" gnus-article-fill-cited-article t] 1725 ["Word wrap" gnus-article-fill-cited-article t]
1726 ["Fill long lines" gnus-article-fill-long-lines t]
1727 ["Capitalize sentences" gnus-article-capitalize-sentences t]
1532 ["CR" gnus-article-remove-cr t] 1728 ["CR" gnus-article-remove-cr t]
1533 ["Show X-Face" gnus-article-display-x-face t] 1729 ["Show X-Face" gnus-article-display-x-face t]
1534 ["Quoted-Printable" gnus-article-de-quoted-unreadable t] 1730 ["Quoted-Printable" gnus-article-de-quoted-unreadable t]
1535 ["UnHTMLize" gnus-article-treat-html t] 1731 ["Base64" gnus-article-de-base64-unreadable t]
1536 ["Rot 13" gnus-summary-caesar-message t] 1732 ["Rot 13" gnus-summary-caesar-message t]
1537 ["Unix pipe" gnus-summary-pipe-message t] 1733 ["Unix pipe" gnus-summary-pipe-message t]
1538 ["Add buttons" gnus-article-add-buttons t] 1734 ["Add buttons" gnus-article-add-buttons t]
1539 ["Add buttons to head" gnus-article-add-buttons-to-head t] 1735 ["Add buttons to head" gnus-article-add-buttons-to-head t]
1540 ["Stop page breaking" gnus-summary-stop-page-breaking t] 1736 ["Stop page breaking" gnus-summary-stop-page-breaking t]
1541 ["Toggle MIME" gnus-summary-toggle-mime t]
1542 ["Verbose header" gnus-summary-verbose-headers t] 1737 ["Verbose header" gnus-summary-verbose-headers t]
1543 ["Toggle header" gnus-summary-toggle-header t]) 1738 ["Toggle header" gnus-summary-toggle-header t]
1739 ["Html" gnus-article-wash-html t]
1740 ["HZ" gnus-article-decode-HZ t])
1544 ("Output" 1741 ("Output"
1545 ["Save in default format" gnus-summary-save-article t] 1742 ["Save in default format" gnus-summary-save-article t]
1546 ["Save in file" gnus-summary-save-article-file t] 1743 ["Save in file" gnus-summary-save-article-file t]
@@ -1584,6 +1781,7 @@ increase the score of each group you read."
1584 ("Cache" 1781 ("Cache"
1585 ["Enter article" gnus-cache-enter-article t] 1782 ["Enter article" gnus-cache-enter-article t]
1586 ["Remove article" gnus-cache-remove-article t]) 1783 ["Remove article" gnus-cache-remove-article t])
1784 ["Translate" gnus-article-babel t]
1587 ["Select article buffer" gnus-summary-select-article-buffer t] 1785 ["Select article buffer" gnus-summary-select-article-buffer t]
1588 ["Enter digest buffer" gnus-summary-enter-digest-group t] 1786 ["Enter digest buffer" gnus-summary-enter-digest-group t]
1589 ["Isearch article..." gnus-summary-isearch-article t] 1787 ["Isearch article..." gnus-summary-isearch-article t]
@@ -1618,8 +1816,7 @@ increase the score of each group you read."
1618 ["Mark thread as read" gnus-summary-kill-thread t] 1816 ["Mark thread as read" gnus-summary-kill-thread t]
1619 ["Lower thread score" gnus-summary-lower-thread t] 1817 ["Lower thread score" gnus-summary-lower-thread t]
1620 ["Raise thread score" gnus-summary-raise-thread t] 1818 ["Raise thread score" gnus-summary-raise-thread t]
1621 ["Rethread current" gnus-summary-rethread-current t] 1819 ["Rethread current" gnus-summary-rethread-current t]))
1622 ))
1623 1820
1624 (easy-menu-define 1821 (easy-menu-define
1625 gnus-summary-post-menu gnus-summary-mode-map "" 1822 gnus-summary-post-menu gnus-summary-mode-map ""
@@ -1674,6 +1871,7 @@ increase the score of each group you read."
1674 ["Subject..." gnus-summary-limit-to-subject t] 1871 ["Subject..." gnus-summary-limit-to-subject t]
1675 ["Author..." gnus-summary-limit-to-author t] 1872 ["Author..." gnus-summary-limit-to-author t]
1676 ["Age..." gnus-summary-limit-to-age t] 1873 ["Age..." gnus-summary-limit-to-age t]
1874 ["Extra..." gnus-summary-limit-to-extra t]
1677 ["Score" gnus-summary-limit-to-score t] 1875 ["Score" gnus-summary-limit-to-score t]
1678 ["Unread" gnus-summary-limit-to-unread t] 1876 ["Unread" gnus-summary-limit-to-unread t]
1679 ["Non-dormant" gnus-summary-limit-exclude-dormant t] 1877 ["Non-dormant" gnus-summary-limit-exclude-dormant t]
@@ -1683,6 +1881,7 @@ increase the score of each group you read."
1683 ["Hide childless dormant" 1881 ["Hide childless dormant"
1684 gnus-summary-limit-exclude-childless-dormant t] 1882 gnus-summary-limit-exclude-childless-dormant t]
1685 ;;["Hide thread" gnus-summary-limit-exclude-thread t] 1883 ;;["Hide thread" gnus-summary-limit-exclude-thread t]
1884 ["Hide marked" gnus-summary-limit-exclude-marks t]
1686 ["Show expunged" gnus-summary-show-all-expunged t]) 1885 ["Show expunged" gnus-summary-show-all-expunged t])
1687 ("Process Mark" 1886 ("Process Mark"
1688 ["Set mark" gnus-summary-mark-as-processable t] 1887 ["Set mark" gnus-summary-mark-as-processable t]
@@ -1729,7 +1928,8 @@ increase the score of each group you read."
1729 ["Sort by subject" gnus-summary-sort-by-subject t] 1928 ["Sort by subject" gnus-summary-sort-by-subject t]
1730 ["Sort by date" gnus-summary-sort-by-date t] 1929 ["Sort by date" gnus-summary-sort-by-date t]
1731 ["Sort by score" gnus-summary-sort-by-score t] 1930 ["Sort by score" gnus-summary-sort-by-score t]
1732 ["Sort by lines" gnus-summary-sort-by-lines t]) 1931 ["Sort by lines" gnus-summary-sort-by-lines t]
1932 ["Sort by characters" gnus-summary-sort-by-chars t])
1733 ("Help" 1933 ("Help"
1734 ["Fetch group FAQ" gnus-summary-fetch-faq t] 1934 ["Fetch group FAQ" gnus-summary-fetch-faq t]
1735 ["Describe group" gnus-summary-describe-group t] 1935 ["Describe group" gnus-summary-describe-group t]
@@ -1753,6 +1953,7 @@ increase the score of each group you read."
1753 ["Edit local kill file" gnus-summary-edit-local-kill t] 1953 ["Edit local kill file" gnus-summary-edit-local-kill t]
1754 ["Edit main kill file" gnus-summary-edit-global-kill t] 1954 ["Edit main kill file" gnus-summary-edit-global-kill t]
1755 ["Edit group parameters" gnus-summary-edit-parameters t] 1955 ["Edit group parameters" gnus-summary-edit-parameters t]
1956 ["Customize group parameters" gnus-summary-customize-parameters t]
1756 ["Send a bug report" gnus-bug t] 1957 ["Send a bug report" gnus-bug t]
1757 ("Exit" 1958 ("Exit"
1758 ["Catchup and exit" gnus-summary-catchup-and-exit t] 1959 ["Catchup and exit" gnus-summary-catchup-and-exit t]
@@ -1783,6 +1984,7 @@ increase the score of each group you read."
1783 ("article body" "body" string) 1984 ("article body" "body" string)
1784 ("article head" "head" string) 1985 ("article head" "head" string)
1785 ("xref" "xref" string) 1986 ("xref" "xref" string)
1987 ("extra header" "extra" string)
1786 ("lines" "lines" number) 1988 ("lines" "lines" number)
1787 ("followups to author" "followup" string))) 1989 ("followups to author" "followup" string)))
1788 (types '((number ("less than" <) 1990 (types '((number ("less than" <)
@@ -1837,7 +2039,8 @@ increase the score of each group you read."
1837 (list 'gnus-summary-header 2039 (list 'gnus-summary-header
1838 (nth 1 header))) 2040 (nth 1 header)))
1839 (list 'quote (nth 1 (car ts))) 2041 (list 'quote (nth 1 (car ts)))
1840 (list 'gnus-score-default nil) 2042 (list 'gnus-score-delta-default
2043 nil)
1841 (nth 1 (car ps)) 2044 (nth 1 (car ps))
1842 t) 2045 t)
1843 t) 2046 t)
@@ -1884,7 +2087,7 @@ The following commands are available:
1884 (setq mode-name "Summary") 2087 (setq mode-name "Summary")
1885 (make-local-variable 'minor-mode-alist) 2088 (make-local-variable 'minor-mode-alist)
1886 (use-local-map gnus-summary-mode-map) 2089 (use-local-map gnus-summary-mode-map)
1887 (buffer-disable-undo (current-buffer)) 2090 (buffer-disable-undo)
1888 (setq buffer-read-only t) ;Disable modification 2091 (setq buffer-read-only t) ;Disable modification
1889 (setq truncate-lines t) 2092 (setq truncate-lines t)
1890 (setq selective-display t) 2093 (setq selective-display t)
@@ -1897,19 +2100,17 @@ The following commands are available:
1897 (make-local-variable 'gnus-summary-dummy-line-format) 2100 (make-local-variable 'gnus-summary-dummy-line-format)
1898 (make-local-variable 'gnus-summary-dummy-line-format-spec) 2101 (make-local-variable 'gnus-summary-dummy-line-format-spec)
1899 (make-local-variable 'gnus-summary-mark-positions) 2102 (make-local-variable 'gnus-summary-mark-positions)
1900 (make-local-hook 'post-command-hook)
1901 (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
1902 (make-local-hook 'pre-command-hook) 2103 (make-local-hook 'pre-command-hook)
1903 (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) 2104 (add-hook 'pre-command-hook 'gnus-set-global-variables nil t)
1904 (gnus-run-hooks 'gnus-summary-mode-hook) 2105 (gnus-run-hooks 'gnus-summary-mode-hook)
2106 (mm-enable-multibyte)
1905 (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) 2107 (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy)
1906 (gnus-update-summary-mark-positions)) 2108 (gnus-update-summary-mark-positions))
1907 2109
1908(defun gnus-summary-make-local-variables () 2110(defun gnus-summary-make-local-variables ()
1909 "Make all the local summary buffer variables." 2111 "Make all the local summary buffer variables."
1910 (let ((locals gnus-summary-local-variables) 2112 (let (global)
1911 global local) 2113 (dolist (local gnus-summary-local-variables)
1912 (while (setq local (pop locals))
1913 (if (consp local) 2114 (if (consp local)
1914 (progn 2115 (progn
1915 (if (eq (cdr local) 'global) 2116 (if (eq (cdr local) 'global)
@@ -1917,11 +2118,9 @@ The following commands are available:
1917 (setq global (symbol-value (car local))) 2118 (setq global (symbol-value (car local)))
1918 ;; Use the value from the list. 2119 ;; Use the value from the list.
1919 (setq global (eval (cdr local)))) 2120 (setq global (eval (cdr local))))
1920 (make-local-variable (car local)) 2121 (set (make-local-variable (car local)) global))
1921 (set (car local) global))
1922 ;; Simple nil-valued local variable. 2122 ;; Simple nil-valued local variable.
1923 (make-local-variable local) 2123 (set (make-local-variable local) nil)))))
1924 (set local nil)))))
1925 2124
1926(defun gnus-summary-clear-local-variables () 2125(defun gnus-summary-clear-local-variables ()
1927 (let ((locals gnus-summary-local-variables)) 2126 (let ((locals gnus-summary-local-variables))
@@ -2215,26 +2414,6 @@ marks of articles."
2215 ,@forms) 2414 ,@forms)
2216 (gnus-restore-hidden-threads-configuration ,config))))) 2415 (gnus-restore-hidden-threads-configuration ,config)))))
2217 2416
2218(defun gnus-hidden-threads-configuration ()
2219 "Return the current hidden threads configuration."
2220 (save-excursion
2221 (let (config)
2222 (goto-char (point-min))
2223 (while (search-forward "\r" nil t)
2224 (push (1- (point)) config))
2225 config)))
2226
2227(defun gnus-restore-hidden-threads-configuration (config)
2228 "Restore hidden threads configuration from CONFIG."
2229 (let (point buffer-read-only)
2230 (while (setq point (pop config))
2231 (when (and (< point (point-max))
2232 (goto-char point)
2233 (= (following-char) ?\n))
2234 (subst-char-in-region point (1+ point) ?\n ?\r)))))
2235
2236;; This needs to be put here because it uses the
2237;; gnus-save-hidden-threads macro
2238(defun gnus-data-compute-positions () 2417(defun gnus-data-compute-positions ()
2239 "Compute the positions of all articles." 2418 "Compute the positions of all articles."
2240 (setq gnus-newsgroup-data-reverse nil) 2419 (setq gnus-newsgroup-data-reverse nil)
@@ -2250,6 +2429,25 @@ marks of articles."
2250 (setq data (cdr data)) 2429 (setq data (cdr data))
2251 (forward-line 1)))))) 2430 (forward-line 1))))))
2252 2431
2432(defun gnus-hidden-threads-configuration ()
2433 "Return the current hidden threads configuration."
2434 (save-excursion
2435 (let (config)
2436 (goto-char (point-min))
2437 (while (search-forward "\r" nil t)
2438 (push (1- (point)) config))
2439 config)))
2440
2441(defun gnus-restore-hidden-threads-configuration (config)
2442 "Restore hidden threads configuration from CONFIG."
2443 (save-excursion
2444 (let (point buffer-read-only)
2445 (while (setq point (pop config))
2446 (when (and (< point (point-max))
2447 (goto-char point)
2448 (eq (char-after) ?\n))
2449 (subst-char-in-region point (1+ point) ?\n ?\r))))))
2450
2253;; Various summary mode internalish functions. 2451;; Various summary mode internalish functions.
2254 2452
2255(defun gnus-mouse-pick-article (e) 2453(defun gnus-mouse-pick-article (e)
@@ -2258,9 +2456,10 @@ marks of articles."
2258 (gnus-summary-next-page nil t)) 2456 (gnus-summary-next-page nil t))
2259 2457
2260(defun gnus-summary-set-display-table () 2458(defun gnus-summary-set-display-table ()
2261 ;; Change the display table. Odd characters have a tendency to mess 2459 "Change the display table.
2262 ;; up nicely formatted displays - we make all possible glyphs 2460Odd characters have a tendency to mess
2263 ;; display only a single character. 2461up nicely formatted displays - we make all possible glyphs
2462display only a single character."
2264 2463
2265 ;; We start from the standard display table, if any. 2464 ;; We start from the standard display table, if any.
2266 (let ((table (or (copy-sequence standard-display-table) 2465 (let ((table (or (copy-sequence standard-display-table)
@@ -2304,9 +2503,9 @@ marks of articles."
2304 t))) 2503 t)))
2305 2504
2306(defun gnus-set-global-variables () 2505(defun gnus-set-global-variables ()
2307 ;; Set the global equivalents of the summary buffer-local variables 2506 "Set the global equivalents of the buffer-local variables.
2308 ;; to the latest values they had. These reflect the summary buffer 2507They are set to the latest values they had. These reflect the summary
2309 ;; that was in action when the last article was fetched. 2508buffer that was in action when the last article was fetched."
2310 (when (eq major-mode 'gnus-summary-mode) 2509 (when (eq major-mode 'gnus-summary-mode)
2311 (setq gnus-summary-buffer (current-buffer)) 2510 (setq gnus-summary-buffer (current-buffer))
2312 (let ((name gnus-newsgroup-name) 2511 (let ((name gnus-newsgroup-name)
@@ -2319,7 +2518,8 @@ marks of articles."
2319 (original gnus-original-article-buffer) 2518 (original gnus-original-article-buffer)
2320 (gac gnus-article-current) 2519 (gac gnus-article-current)
2321 (reffed gnus-reffed-article-number) 2520 (reffed gnus-reffed-article-number)
2322 (score-file gnus-current-score-file)) 2521 (score-file gnus-current-score-file)
2522 (default-charset gnus-newsgroup-charset))
2323 (save-excursion 2523 (save-excursion
2324 (set-buffer gnus-group-buffer) 2524 (set-buffer gnus-group-buffer)
2325 (setq gnus-newsgroup-name name 2525 (setq gnus-newsgroup-name name
@@ -2332,7 +2532,8 @@ marks of articles."
2332 gnus-article-buffer article-buffer 2532 gnus-article-buffer article-buffer
2333 gnus-original-article-buffer original 2533 gnus-original-article-buffer original
2334 gnus-reffed-article-number reffed 2534 gnus-reffed-article-number reffed
2335 gnus-current-score-file score-file) 2535 gnus-current-score-file score-file
2536 gnus-newsgroup-charset default-charset)
2336 ;; The article buffer also has local variables. 2537 ;; The article buffer also has local variables.
2337 (when (gnus-buffer-live-p gnus-article-buffer) 2538 (when (gnus-buffer-live-p gnus-article-buffer)
2338 (set-buffer gnus-article-buffer) 2539 (set-buffer gnus-article-buffer)
@@ -2351,7 +2552,8 @@ marks of articles."
2351(defun gnus-summary-last-article-p (&optional article) 2552(defun gnus-summary-last-article-p (&optional article)
2352 "Return whether ARTICLE is the last article in the buffer." 2553 "Return whether ARTICLE is the last article in the buffer."
2353 (if (not (setq article (or article (gnus-summary-article-number)))) 2554 (if (not (setq article (or article (gnus-summary-article-number))))
2354 t ; All non-existent numbers are the last article. :-) 2555 ;; All non-existent numbers are the last article. :-)
2556 t
2355 (not (cdr (gnus-data-find-list article))))) 2557 (not (cdr (gnus-data-find-list article)))))
2356 2558
2357(defun gnus-make-thread-indent-array () 2559(defun gnus-make-thread-indent-array ()
@@ -2381,7 +2583,7 @@ marks of articles."
2381 (let ((gnus-summary-line-format-spec spec) 2583 (let ((gnus-summary-line-format-spec spec)
2382 (gnus-newsgroup-downloadable '((0 . t)))) 2584 (gnus-newsgroup-downloadable '((0 . t))))
2383 (gnus-summary-insert-line 2585 (gnus-summary-insert-line
2384 [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) 2586 [0 "" "" "" "" "" 0 0 "" nil] 0 nil 128 t nil "" nil 1)
2385 (goto-char (point-min)) 2587 (goto-char (point-min))
2386 (setq pos (list (cons 'unread (and (search-forward "\200" nil t) 2588 (setq pos (list (cons 'unread (and (search-forward "\200" nil t)
2387 (- (point) 2))))) 2589 (- (point) 2)))))
@@ -2405,6 +2607,33 @@ marks of articles."
2405 (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) 2607 (point) (progn (eval gnus-summary-dummy-line-format-spec) (point))
2406 (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) 2608 (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number)))
2407 2609
2610(defun gnus-summary-from-or-to-or-newsgroups (header)
2611 (let ((to (cdr (assq 'To (mail-header-extra header))))
2612 (newsgroups (cdr (assq 'Newsgroups (mail-header-extra header))))
2613 (mail-parse-charset gnus-newsgroup-charset)
2614 (mail-parse-ignored-charsets
2615 (save-excursion (set-buffer gnus-summary-buffer)
2616 gnus-newsgroup-ignored-charsets)))
2617 (cond
2618 ((and to
2619 gnus-ignored-from-addresses
2620 (string-match gnus-ignored-from-addresses
2621 (mail-header-from header)))
2622 (concat "-> "
2623 (or (car (funcall gnus-extract-address-components
2624 (funcall
2625 gnus-decode-encoded-word-function to)))
2626 (funcall gnus-decode-encoded-word-function to))))
2627 ((and newsgroups
2628 gnus-ignored-from-addresses
2629 (string-match gnus-ignored-from-addresses
2630 (mail-header-from header)))
2631 (concat "=> " newsgroups))
2632 (t
2633 (or (car (funcall gnus-extract-address-components
2634 (mail-header-from header)))
2635 (mail-header-from header))))))
2636
2408(defun gnus-summary-insert-line (gnus-tmp-header 2637(defun gnus-summary-insert-line (gnus-tmp-header
2409 gnus-tmp-level gnus-tmp-current 2638 gnus-tmp-level gnus-tmp-current
2410 gnus-tmp-unread gnus-tmp-replied 2639 gnus-tmp-unread gnus-tmp-replied
@@ -2418,7 +2647,7 @@ marks of articles."
2418 (if (or (null gnus-summary-default-score) 2647 (if (or (null gnus-summary-default-score)
2419 (<= (abs (- gnus-tmp-score gnus-summary-default-score)) 2648 (<= (abs (- gnus-tmp-score gnus-summary-default-score))
2420 gnus-summary-zcore-fuzz)) 2649 gnus-summary-zcore-fuzz))
2421 ? ;space 2650 ? ;Whitespace
2422 (if (< gnus-tmp-score gnus-summary-default-score) 2651 (if (< gnus-tmp-score gnus-summary-default-score)
2423 gnus-score-below-mark gnus-score-over-mark))) 2652 gnus-score-below-mark gnus-score-over-mark)))
2424 (gnus-tmp-replied 2653 (gnus-tmp-replied
@@ -2451,7 +2680,7 @@ marks of articles."
2451 (setq gnus-tmp-name gnus-tmp-from)) 2680 (setq gnus-tmp-name gnus-tmp-from))
2452 (unless (numberp gnus-tmp-lines) 2681 (unless (numberp gnus-tmp-lines)
2453 (setq gnus-tmp-lines 0)) 2682 (setq gnus-tmp-lines 0))
2454 (gnus-put-text-property-excluding-characters-with-faces 2683 (gnus-put-text-property
2455 (point) 2684 (point)
2456 (progn (eval gnus-summary-line-format-spec) (point)) 2685 (progn (eval gnus-summary-line-format-spec) (point))
2457 'gnus-number gnus-tmp-number) 2686 'gnus-number gnus-tmp-number)
@@ -2461,7 +2690,7 @@ marks of articles."
2461 (forward-line 1)))) 2690 (forward-line 1))))
2462 2691
2463(defun gnus-summary-update-line (&optional dont-update) 2692(defun gnus-summary-update-line (&optional dont-update)
2464 ;; Update summary line after change. 2693 "Update summary line after change."
2465 (when (and gnus-summary-default-score 2694 (when (and gnus-summary-default-score
2466 (not gnus-summary-inhibit-highlight)) 2695 (not gnus-summary-inhibit-highlight))
2467 (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion. 2696 (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion.
@@ -2483,7 +2712,7 @@ marks of articles."
2483 (if (or (null gnus-summary-default-score) 2712 (if (or (null gnus-summary-default-score)
2484 (<= (abs (- score gnus-summary-default-score)) 2713 (<= (abs (- score gnus-summary-default-score))
2485 gnus-summary-zcore-fuzz)) 2714 gnus-summary-zcore-fuzz))
2486 ? ;space 2715 ? ;Whitespace
2487 (if (< score gnus-summary-default-score) 2716 (if (< score gnus-summary-default-score)
2488 gnus-score-below-mark gnus-score-over-mark)) 2717 gnus-score-below-mark gnus-score-over-mark))
2489 'score)) 2718 'score))
@@ -2552,7 +2781,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2552 kill-buffer no-display 2781 kill-buffer no-display
2553 select-articles) 2782 select-articles)
2554 (setq show-all nil 2783 (setq show-all nil
2555 select-articles nil))))) 2784 select-articles nil)))))
2556 (eq gnus-auto-select-next 'quietly)) 2785 (eq gnus-auto-select-next 'quietly))
2557 (set-buffer gnus-group-buffer) 2786 (set-buffer gnus-group-buffer)
2558 ;; The entry function called above goes to the next 2787 ;; The entry function called above goes to the next
@@ -2634,6 +2863,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2634 (gnus-summary-set-local-parameters gnus-newsgroup-name) 2863 (gnus-summary-set-local-parameters gnus-newsgroup-name)
2635 (gnus-update-format-specifications 2864 (gnus-update-format-specifications
2636 nil 'summary 'summary-mode 'summary-dummy) 2865 nil 'summary 'summary-mode 'summary-dummy)
2866 (gnus-update-summary-mark-positions)
2637 ;; Do score processing. 2867 ;; Do score processing.
2638 (when gnus-use-scoring 2868 (when gnus-use-scoring
2639 (gnus-possibly-score-headers)) 2869 (gnus-possibly-score-headers))
@@ -2646,6 +2876,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2646 (let ((gnus-newsgroup-dormant nil)) 2876 (let ((gnus-newsgroup-dormant nil))
2647 (gnus-summary-initial-limit show-all)) 2877 (gnus-summary-initial-limit show-all))
2648 (gnus-summary-initial-limit show-all)) 2878 (gnus-summary-initial-limit show-all))
2879 ;; When untreaded, all articles are always shown.
2649 (setq gnus-newsgroup-limit 2880 (setq gnus-newsgroup-limit
2650 (mapcar 2881 (mapcar
2651 (lambda (header) (mail-header-number header)) 2882 (lambda (header) (mail-header-number header))
@@ -2691,10 +2922,15 @@ If NO-DISPLAY, don't generate a summary buffer."
2691 (not no-display) 2922 (not no-display)
2692 gnus-newsgroup-unreads 2923 gnus-newsgroup-unreads
2693 gnus-auto-select-first) 2924 gnus-auto-select-first)
2694 (unless (if (eq gnus-auto-select-first 'best) 2925 (progn
2695 (gnus-summary-best-unread-article) 2926 (gnus-configure-windows 'summary)
2696 (gnus-summary-first-unread-article)) 2927 (cond
2697 (gnus-configure-windows 'summary)) 2928 ((eq gnus-auto-select-first 'best)
2929 (gnus-summary-best-unread-article))
2930 ((eq gnus-auto-select-first t)
2931 (gnus-summary-first-unread-article))
2932 ((gnus-functionp gnus-auto-select-first)
2933 (funcall gnus-auto-select-first))))
2698 ;; Don't select any articles, just move point to the first 2934 ;; Don't select any articles, just move point to the first
2699 ;; article in the group. 2935 ;; article in the group.
2700 (goto-char (point-min)) 2936 (goto-char (point-min))
@@ -2839,12 +3075,12 @@ If NO-DISPLAY, don't generate a summary buffer."
2839 result)) 3075 result))
2840 3076
2841(defun gnus-sort-gathered-threads (threads) 3077(defun gnus-sort-gathered-threads (threads)
2842 "Sort subtreads inside each gathered thread by article number." 3078 "Sort subtreads inside each gathered thread by `gnus-sort-gathered-threads-function'."
2843 (let ((result threads)) 3079 (let ((result threads))
2844 (while threads 3080 (while threads
2845 (when (stringp (caar threads)) 3081 (when (stringp (caar threads))
2846 (setcdr (car threads) 3082 (setcdr (car threads)
2847 (sort (cdar threads) 'gnus-thread-sort-by-number))) 3083 (sort (cdar threads) gnus-sort-gathered-threads-function)))
2848 (setq threads (cdr threads))) 3084 (setq threads (cdr threads)))
2849 result)) 3085 result))
2850 3086
@@ -2900,7 +3136,7 @@ If NO-DISPLAY, don't generate a summary buffer."
2900 threads)) 3136 threads))
2901 3137
2902;; Build the thread tree. 3138;; Build the thread tree.
2903(defun gnus-dependencies-add-header (header dependencies force-new) 3139(defsubst gnus-dependencies-add-header (header dependencies force-new)
2904 "Enter HEADER into the DEPENDENCIES table if it is not already there. 3140 "Enter HEADER into the DEPENDENCIES table if it is not already there.
2905 3141
2906If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even 3142If FORCE-NEW is not nil, enter HEADER into the DEPENDENCIES table even
@@ -2979,6 +3215,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
2979 3215
2980(defun gnus-build-sparse-threads () 3216(defun gnus-build-sparse-threads ()
2981 (let ((headers gnus-newsgroup-headers) 3217 (let ((headers gnus-newsgroup-headers)
3218 (mail-parse-charset gnus-newsgroup-charset)
2982 (gnus-summary-ignore-duplicates t) 3219 (gnus-summary-ignore-duplicates t)
2983 header references generation relations 3220 header references generation relations
2984 subject child end new-child date) 3221 subject child end new-child date)
@@ -3031,7 +3268,8 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3031 ;; fetch the headers for the articles that aren't there. This will 3268 ;; fetch the headers for the articles that aren't there. This will
3032 ;; build complete threads - if the roots haven't been expired by the 3269 ;; build complete threads - if the roots haven't been expired by the
3033 ;; server, that is. 3270 ;; server, that is.
3034 (let (id heads) 3271 (let ((mail-parse-charset gnus-newsgroup-charset)
3272 id heads)
3035 (mapatoms 3273 (mapatoms
3036 (lambda (refs) 3274 (lambda (refs)
3037 (when (not (car (symbol-value refs))) 3275 (when (not (car (symbol-value refs)))
@@ -3046,24 +3284,6 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3046 (setq heads nil))))) 3284 (setq heads nil)))))
3047 gnus-newsgroup-dependencies))) 3285 gnus-newsgroup-dependencies)))
3048 3286
3049;; The following macros and functions were written by Felix Lee
3050;; <flee@cse.psu.edu>.
3051
3052(defmacro gnus-nov-read-integer ()
3053 '(prog1
3054 (if (= (following-char) ?\t)
3055 0
3056 (let ((num (ignore-errors (read buffer))))
3057 (if (numberp num) num 0)))
3058 (unless (eobp)
3059 (search-forward "\t" eol 'move))))
3060
3061(defmacro gnus-nov-skip-field ()
3062 '(search-forward "\t" eol 'move))
3063
3064(defmacro gnus-nov-field ()
3065 '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol)))
3066
3067;; This function has to be called with point after the article number 3287;; This function has to be called with point after the article number
3068;; on the beginning of the line. 3288;; on the beginning of the line.
3069(defsubst gnus-nov-parse-line (number dependencies &optional force-new) 3289(defsubst gnus-nov-parse-line (number dependencies &optional force-new)
@@ -3081,18 +3301,20 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3081 (setq header 3301 (setq header
3082 (make-full-mail-header 3302 (make-full-mail-header
3083 number ; number 3303 number ; number
3084 (funcall 3304 (funcall gnus-decode-encoded-word-function
3085 gnus-unstructured-field-decoder (gnus-nov-field)) ; subject 3305 (nnheader-nov-field)) ; subject
3086 (funcall 3306 (funcall gnus-decode-encoded-word-function
3087 gnus-structured-field-decoder (gnus-nov-field)) ; from 3307 (nnheader-nov-field)) ; from
3088 (gnus-nov-field) ; date 3308 (nnheader-nov-field) ; date
3089 (or (gnus-nov-field) 3309 (nnheader-nov-read-message-id) ; id
3090 (nnheader-generate-fake-message-id)) ; id 3310 (nnheader-nov-field) ; refs
3091 (gnus-nov-field) ; refs 3311 (nnheader-nov-read-integer) ; chars
3092 (gnus-nov-read-integer) ; chars 3312 (nnheader-nov-read-integer) ; lines
3093 (gnus-nov-read-integer) ; lines 3313 (unless (eobp)
3094 (unless (= (following-char) ?\n) 3314 (if (looking-at "Xref: ")
3095 (gnus-nov-field))))) ; misc 3315 (goto-char (match-end 0)))
3316 (nnheader-nov-field)) ; Xref
3317 (nnheader-nov-parse-extra)))) ; extra
3096 3318
3097 (widen)) 3319 (widen))
3098 3320
@@ -3101,9 +3323,9 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3101 (gnus-dependencies-add-header header dependencies force-new))) 3323 (gnus-dependencies-add-header header dependencies force-new)))
3102 3324
3103(defun gnus-build-get-header (id) 3325(defun gnus-build-get-header (id)
3104 ;; Look through the buffer of NOV lines and find the header to 3326 "Look through the buffer of NOV lines and find the header to ID.
3105 ;; ID. Enter this line into the dependencies hash table, and return 3327Enter this line into the dependencies hash table, and return
3106 ;; the id of the parent article (if any). 3328the id of the parent article (if any)."
3107 (let ((deps gnus-newsgroup-dependencies) 3329 (let ((deps gnus-newsgroup-dependencies)
3108 found header) 3330 found header)
3109 (prog1 3331 (prog1
@@ -3138,6 +3360,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3138(defun gnus-build-all-threads () 3360(defun gnus-build-all-threads ()
3139 "Read all the headers." 3361 "Read all the headers."
3140 (let ((gnus-summary-ignore-duplicates t) 3362 (let ((gnus-summary-ignore-duplicates t)
3363 (mail-parse-charset gnus-newsgroup-charset)
3141 (dependencies gnus-newsgroup-dependencies) 3364 (dependencies gnus-newsgroup-dependencies)
3142 header article) 3365 header article)
3143 (save-excursion 3366 (save-excursion
@@ -3147,8 +3370,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3147 (while (not (eobp)) 3370 (while (not (eobp))
3148 (ignore-errors 3371 (ignore-errors
3149 (setq article (read (current-buffer)) 3372 (setq article (read (current-buffer))
3150 header (gnus-nov-parse-line 3373 header (gnus-nov-parse-line article dependencies)))
3151 article dependencies)))
3152 (when header 3374 (when header
3153 (save-excursion 3375 (save-excursion
3154 (set-buffer gnus-summary-buffer) 3376 (set-buffer gnus-summary-buffer)
@@ -3185,17 +3407,19 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
3185 (memq article gnus-newsgroup-expirable) 3407 (memq article gnus-newsgroup-expirable)
3186 ;; Only insert the Subject string when it's different 3408 ;; Only insert the Subject string when it's different
3187 ;; from the previous Subject string. 3409 ;; from the previous Subject string.
3188 (if (gnus-subject-equal 3410 (if (and
3189 (condition-case () 3411 gnus-show-threads
3190 (mail-header-subject 3412 (gnus-subject-equal
3191 (gnus-data-header 3413 (condition-case ()
3192 (cadr 3414 (mail-header-subject
3193 (gnus-data-find-list 3415 (gnus-data-header
3194 article 3416 (cadr
3195 (gnus-data-list t))))) 3417 (gnus-data-find-list
3196 ;; Error on the side of excessive subjects. 3418 article
3197 (error "")) 3419 (gnus-data-list t)))))
3198 (mail-header-subject header)) 3420 ;; Error on the side of excessive subjects.
3421 (error ""))
3422 (mail-header-subject header)))
3199 "" 3423 ""
3200 (mail-header-subject header)) 3424 (mail-header-subject header))
3201 nil (cdr (assq article gnus-newsgroup-scored)) 3425 nil (cdr (assq article gnus-newsgroup-scored))
@@ -3409,7 +3633,6 @@ If LINE, insert the rebuilt thread starting on line LINE."
3409 (while thread 3633 (while thread
3410 (gnus-remove-thread-1 (car thread)) 3634 (gnus-remove-thread-1 (car thread))
3411 (setq thread (cdr thread)))) 3635 (setq thread (cdr thread))))
3412 (gnus-summary-show-all-threads)
3413 (gnus-remove-thread-1 thread)))))))) 3636 (gnus-remove-thread-1 thread))))))))
3414 3637
3415(defun gnus-remove-thread-1 (thread) 3638(defun gnus-remove-thread-1 (thread)
@@ -3421,6 +3644,7 @@ If LINE, insert the rebuilt thread starting on line LINE."
3421 (gnus-remove-thread-1 (pop thread))) 3644 (gnus-remove-thread-1 (pop thread)))
3422 (when (setq d (gnus-data-find number)) 3645 (when (setq d (gnus-data-find number))
3423 (goto-char (gnus-data-pos d)) 3646 (goto-char (gnus-data-pos d))
3647 (gnus-summary-show-thread)
3424 (gnus-data-remove 3648 (gnus-data-remove
3425 number 3649 number
3426 (- (gnus-point-at-bol) 3650 (- (gnus-point-at-bol)
@@ -3428,13 +3652,22 @@ If LINE, insert the rebuilt thread starting on line LINE."
3428 (1+ (gnus-point-at-eol)) 3652 (1+ (gnus-point-at-eol))
3429 (gnus-delete-line))))))) 3653 (gnus-delete-line)))))))
3430 3654
3655(defun gnus-sort-threads-1 (threads func)
3656 (sort (mapcar (lambda (thread)
3657 (cons (car thread)
3658 (and (cdr thread)
3659 (gnus-sort-threads-1 (cdr thread) func))))
3660 threads) func))
3661
3431(defun gnus-sort-threads (threads) 3662(defun gnus-sort-threads (threads)
3432 "Sort THREADS." 3663 "Sort THREADS."
3433 (if (not gnus-thread-sort-functions) 3664 (if (not gnus-thread-sort-functions)
3434 threads 3665 threads
3435 (gnus-message 8 "Sorting threads...") 3666 (gnus-message 8 "Sorting threads...")
3436 (prog1 3667 (prog1
3437 (sort threads (gnus-make-sort-function gnus-thread-sort-functions)) 3668 (gnus-sort-threads-1
3669 threads
3670 (gnus-make-sort-function gnus-thread-sort-functions))
3438 (gnus-message 8 "Sorting threads...done")))) 3671 (gnus-message 8 "Sorting threads...done"))))
3439 3672
3440(defun gnus-sort-articles (articles) 3673(defun gnus-sort-articles (articles)
@@ -3449,12 +3682,12 @@ If LINE, insert the rebuilt thread starting on line LINE."
3449 3682
3450;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. 3683;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
3451(defmacro gnus-thread-header (thread) 3684(defmacro gnus-thread-header (thread)
3452 ;; Return header of first article in THREAD. 3685 "Return header of first article in THREAD.
3453 ;; Note that THREAD must never, ever be anything else than a variable - 3686Note that THREAD must never, ever be anything else than a variable -
3454 ;; using some other form will lead to serious barfage. 3687using some other form will lead to serious barfage."
3455 (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) 3688 (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread)))
3456 ;; (8% speedup to gnus-summary-prepare, just for fun :-) 3689 ;; (8% speedup to gnus-summary-prepare, just for fun :-)
3457 (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ; 3690 (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207"
3458 (vector thread) 2)) 3691 (vector thread) 2))
3459 3692
3460(defsubst gnus-article-sort-by-number (h1 h2) 3693(defsubst gnus-article-sort-by-number (h1 h2)
@@ -3477,6 +3710,16 @@ If LINE, insert the rebuilt thread starting on line LINE."
3477 (gnus-article-sort-by-lines 3710 (gnus-article-sort-by-lines
3478 (gnus-thread-header h1) (gnus-thread-header h2))) 3711 (gnus-thread-header h1) (gnus-thread-header h2)))
3479 3712
3713(defsubst gnus-article-sort-by-chars (h1 h2)
3714 "Sort articles by octet length."
3715 (< (mail-header-chars h1)
3716 (mail-header-chars h2)))
3717
3718(defun gnus-thread-sort-by-chars (h1 h2)
3719 "Sort threads by root article octet length."
3720 (gnus-article-sort-by-chars
3721 (gnus-thread-header h1) (gnus-thread-header h2)))
3722
3480(defsubst gnus-article-sort-by-author (h1 h2) 3723(defsubst gnus-article-sort-by-author (h1 h2)
3481 "Sort articles by root author." 3724 "Sort articles by root author."
3482 (string-lessp 3725 (string-lessp
@@ -3507,7 +3750,7 @@ If LINE, insert the rebuilt thread starting on line LINE."
3507 3750
3508(defsubst gnus-article-sort-by-date (h1 h2) 3751(defsubst gnus-article-sort-by-date (h1 h2)
3509 "Sort articles by root article date." 3752 "Sort articles by root article date."
3510 (gnus-time-less 3753 (time-less-p
3511 (gnus-date-get-time (mail-header-date h1)) 3754 (gnus-date-get-time (mail-header-date h1))
3512 (gnus-date-get-time (mail-header-date h2)))) 3755 (gnus-date-get-time (mail-header-date h2))))
3513 3756
@@ -3537,7 +3780,7 @@ Unscored articles will be counted as having a score of zero."
3537 (> (gnus-thread-total-score h1) (gnus-thread-total-score h2))) 3780 (> (gnus-thread-total-score h1) (gnus-thread-total-score h2)))
3538 3781
3539(defun gnus-thread-total-score (thread) 3782(defun gnus-thread-total-score (thread)
3540 ;; This function find the total score of THREAD. 3783 ;; This function find the total score of THREAD.
3541 (cond ((null thread) 3784 (cond ((null thread)
3542 0) 3785 0)
3543 ((consp thread) 3786 ((consp thread)
@@ -3568,6 +3811,12 @@ Unscored articles will be counted as having a score of zero."
3568(defvar gnus-tmp-root-expunged nil) 3811(defvar gnus-tmp-root-expunged nil)
3569(defvar gnus-tmp-dummy-line nil) 3812(defvar gnus-tmp-dummy-line nil)
3570 3813
3814(defvar gnus-tmp-header)
3815(defun gnus-extra-header (type &optional header)
3816 "Return the extra header of TYPE."
3817 (or (cdr (assq type (mail-header-extra (or header gnus-tmp-header))))
3818 ""))
3819
3571(defun gnus-summary-prepare-threads (threads) 3820(defun gnus-summary-prepare-threads (threads)
3572 "Prepare summary buffer from THREADS and indentation LEVEL. 3821 "Prepare summary buffer from THREADS and indentation LEVEL.
3573THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' 3822THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])'
@@ -3765,7 +4014,7 @@ or a straight list of headers."
3765 (if (or (null gnus-summary-default-score) 4014 (if (or (null gnus-summary-default-score)
3766 (<= (abs (- gnus-tmp-score gnus-summary-default-score)) 4015 (<= (abs (- gnus-tmp-score gnus-summary-default-score))
3767 gnus-summary-zcore-fuzz)) 4016 gnus-summary-zcore-fuzz))
3768 ? ;space 4017 ? ;Whitespace
3769 (if (< gnus-tmp-score gnus-summary-default-score) 4018 (if (< gnus-tmp-score gnus-summary-default-score)
3770 gnus-score-below-mark gnus-score-over-mark)) 4019 gnus-score-below-mark gnus-score-over-mark))
3771 gnus-tmp-replied 4020 gnus-tmp-replied
@@ -3795,7 +4044,7 @@ or a straight list of headers."
3795 (setq gnus-tmp-name gnus-tmp-from)) 4044 (setq gnus-tmp-name gnus-tmp-from))
3796 (unless (numberp gnus-tmp-lines) 4045 (unless (numberp gnus-tmp-lines)
3797 (setq gnus-tmp-lines 0)) 4046 (setq gnus-tmp-lines 0))
3798 (gnus-put-text-property-excluding-characters-with-faces 4047 (gnus-put-text-property
3799 (point) 4048 (point)
3800 (progn (eval gnus-summary-line-format-spec) (point)) 4049 (progn (eval gnus-summary-line-format-spec) (point))
3801 'gnus-number number) 4050 'gnus-number number)
@@ -3849,6 +4098,24 @@ or a straight list of headers."
3849 (cdr (assq number gnus-newsgroup-scored)) 4098 (cdr (assq number gnus-newsgroup-scored))
3850 (memq number gnus-newsgroup-processable)))))) 4099 (memq number gnus-newsgroup-processable))))))
3851 4100
4101(defun gnus-summary-remove-list-identifiers ()
4102 "Remove list identifiers in `gnus-list-identifiers' from articles in the current group."
4103 (let ((regexp (if (stringp gnus-list-identifiers)
4104 gnus-list-identifiers
4105 (mapconcat 'identity gnus-list-identifiers " *\\|"))))
4106 (dolist (header gnus-newsgroup-headers)
4107 (when (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
4108 " *\\)\\)+\\(Re: +\\)?\\)")
4109 (mail-header-subject header))
4110 (mail-header-set-subject
4111 header (concat (substring (mail-header-subject header)
4112 0 (match-beginning 1))
4113 (or
4114 (match-string 3 (mail-header-subject header))
4115 (match-string 5 (mail-header-subject header)))
4116 (substring (mail-header-subject header)
4117 (match-end 1))))))))
4118
3852(defun gnus-select-newsgroup (group &optional read-all select-articles) 4119(defun gnus-select-newsgroup (group &optional read-all select-articles)
3853 "Select newsgroup GROUP. 4120 "Select newsgroup GROUP.
3854If READ-ALL is non-nil, all articles in the group are selected. 4121If READ-ALL is non-nil, all articles in the group are selected.
@@ -3884,6 +4151,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3884 (setq gnus-newsgroup-name group) 4151 (setq gnus-newsgroup-name group)
3885 (setq gnus-newsgroup-unselected nil) 4152 (setq gnus-newsgroup-unselected nil)
3886 (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) 4153 (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group))
4154 (gnus-summary-setup-default-charset)
3887 4155
3888 ;; Adjust and set lists of article marks. 4156 ;; Adjust and set lists of article marks.
3889 (when info 4157 (when info
@@ -3918,6 +4186,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3918 ;; Init the dependencies hash table. 4186 ;; Init the dependencies hash table.
3919 (setq gnus-newsgroup-dependencies 4187 (setq gnus-newsgroup-dependencies
3920 (gnus-make-hashtable (length articles))) 4188 (gnus-make-hashtable (length articles)))
4189 (gnus-set-global-variables)
3921 ;; Retrieve the headers and read them in. 4190 ;; Retrieve the headers and read them in.
3922 (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) 4191 (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name)
3923 (setq gnus-newsgroup-headers 4192 (setq gnus-newsgroup-headers
@@ -3966,6 +4235,9 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3966 ;; Let the Gnus agent mark articles as read. 4235 ;; Let the Gnus agent mark articles as read.
3967 (when gnus-agent 4236 (when gnus-agent
3968 (gnus-agent-get-undownloaded-list)) 4237 (gnus-agent-get-undownloaded-list))
4238 ;; Remove list identifiers from subject
4239 (when gnus-list-identifiers
4240 (gnus-summary-remove-list-identifiers))
3969 ;; Check whether auto-expire is to be done in this group. 4241 ;; Check whether auto-expire is to be done in this group.
3970 (setq gnus-newsgroup-auto-expire 4242 (setq gnus-newsgroup-auto-expire
3971 (gnus-group-auto-expirable-p group)) 4243 (gnus-group-auto-expirable-p group))
@@ -3983,7 +4255,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3983 (or gnus-newsgroup-headers t))))) 4255 (or gnus-newsgroup-headers t)))))
3984 4256
3985(defun gnus-articles-to-read (group &optional read-all) 4257(defun gnus-articles-to-read (group &optional read-all)
3986 ;; Find out what articles the user wants to read. 4258 "Find out what articles the user wants to read."
3987 (let* ((articles 4259 (let* ((articles
3988 ;; Select all articles if `read-all' is non-nil, or if there 4260 ;; Select all articles if `read-all' is non-nil, or if there
3989 ;; are no unread articles. 4261 ;; are no unread articles.
@@ -3992,7 +4264,9 @@ If SELECT-ARTICLES, only select those articles from GROUP."
3992 (zerop (length gnus-newsgroup-unreads))) 4264 (zerop (length gnus-newsgroup-unreads)))
3993 (eq (gnus-group-find-parameter group 'display) 4265 (eq (gnus-group-find-parameter group 'display)
3994 'all)) 4266 'all))
3995 (gnus-uncompress-range (gnus-active group)) 4267 (or
4268 (gnus-uncompress-range (gnus-active group))
4269 (gnus-cache-articles-in-group group))
3996 (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked 4270 (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked
3997 (copy-sequence gnus-newsgroup-unreads)) 4271 (copy-sequence gnus-newsgroup-unreads))
3998 '<))) 4272 '<)))
@@ -4048,6 +4322,12 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4048 (gnus-sorted-intersection 4322 (gnus-sorted-intersection
4049 gnus-newsgroup-unreads 4323 gnus-newsgroup-unreads
4050 (gnus-sorted-complement gnus-newsgroup-unreads articles))) 4324 (gnus-sorted-complement gnus-newsgroup-unreads articles)))
4325 (when gnus-alter-articles-to-read-function
4326 (setq gnus-newsgroup-unreads
4327 (sort
4328 (funcall gnus-alter-articles-to-read-function
4329 gnus-newsgroup-name gnus-newsgroup-unreads)
4330 '<)))
4051 articles))) 4331 articles)))
4052 4332
4053(defun gnus-killed-articles (killed articles) 4333(defun gnus-killed-articles (killed articles)
@@ -4070,7 +4350,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4070 out)) 4350 out))
4071 4351
4072(defun gnus-adjust-marked-articles (info) 4352(defun gnus-adjust-marked-articles (info)
4073 "Set all article lists and remove all marks that are no longer legal." 4353 "Set all article lists and remove all marks that are no longer valid."
4074 (let* ((marked-lists (gnus-info-marks info)) 4354 (let* ((marked-lists (gnus-info-marks info))
4075 (active (gnus-active (gnus-info-group info))) 4355 (active (gnus-active (gnus-info-group info)))
4076 (min (car active)) 4356 (min (car active))
@@ -4128,15 +4408,16 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4128 (let ((types gnus-article-mark-lists) 4408 (let ((types gnus-article-mark-lists)
4129 (info (gnus-get-info gnus-newsgroup-name)) 4409 (info (gnus-get-info gnus-newsgroup-name))
4130 (uncompressed '(score bookmark killed)) 4410 (uncompressed '(score bookmark killed))
4131 type list newmarked symbol) 4411 type list newmarked symbol delta-marks)
4132 (when info 4412 (when info
4133 ;; Add all marks lists that are non-nil to the list of marks lists. 4413 ;; Add all marks lists to the list of marks lists.
4134 (while (setq type (pop types)) 4414 (while (setq type (pop types))
4135 (when (setq list (symbol-value 4415 (setq list (symbol-value
4136 (setq symbol 4416 (setq symbol
4137 (intern (format "gnus-newsgroup-%s" 4417 (intern (format "gnus-newsgroup-%s"
4138 (car type)))))) 4418 (car type))))))
4139 4419
4420 (when list
4140 ;; Get rid of the entries of the articles that have the 4421 ;; Get rid of the entries of the articles that have the
4141 ;; default score. 4422 ;; default score.
4142 (when (and (eq (cdr type) 'score) 4423 (when (and (eq (cdr type) 'score)
@@ -4151,14 +4432,38 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4151 (setcdr prev (cdr arts)) 4432 (setcdr prev (cdr arts))
4152 (setq prev arts)) 4433 (setq prev arts))
4153 (setq arts (cdr arts))) 4434 (setq arts (cdr arts)))
4154 (setq list (cdr all)))) 4435 (setq list (cdr all)))))
4155 4436
4156 (push (cons (cdr type) 4437 (unless (memq (cdr type) uncompressed)
4157 (if (memq (cdr type) uncompressed) list 4438 (setq list (gnus-compress-sequence (set symbol (sort list '<)) t)))
4158 (gnus-compress-sequence 4439
4159 (set symbol (sort list '<)) t))) 4440 (when (gnus-check-backend-function
4160 newmarked))) 4441 'request-set-mark gnus-newsgroup-name)
4161 4442 ;; propagate flags to server, with the following exceptions:
4443 ;; uncompressed:s are not proper flags (they are cons cells)
4444 ;; cache is a internal gnus flag
4445 ;; download are local to one gnus installation (well)
4446 ;; unsend are for nndraft groups only
4447 ;; xxx: generality of this? this suits nnimap anyway
4448 (unless (memq (cdr type) (append '(cache download unsend)
4449 uncompressed))
4450 (let* ((old (cdr (assq (cdr type) (gnus-info-marks info))))
4451 (del (gnus-remove-from-range (gnus-copy-sequence old) list))
4452 (add (gnus-remove-from-range
4453 (gnus-copy-sequence list) old)))
4454 (when add
4455 (push (list add 'add (list (cdr type))) delta-marks))
4456 (when del
4457 (push (list del 'del (list (cdr type))) delta-marks)))))
4458
4459 (when list
4460 (push (cons (cdr type) list) newmarked)))
4461
4462 (when delta-marks
4463 (unless (gnus-check-group gnus-newsgroup-name)
4464 (error "Can't open server for %s" gnus-newsgroup-name))
4465 (gnus-request-set-mark gnus-newsgroup-name delta-marks))
4466
4162 ;; Enter these new marks into the info of the group. 4467 ;; Enter these new marks into the info of the group.
4163 (if (nthcdr 3 info) 4468 (if (nthcdr 3 info)
4164 (setcar (nthcdr 3 info) newmarked) 4469 (setcar (nthcdr 3 info) newmarked)
@@ -4174,10 +4479,12 @@ If SELECT-ARTICLES, only select those articles from GROUP."
4174 (setcdr (nthcdr i info) nil))))))) 4479 (setcdr (nthcdr i info) nil)))))))
4175 4480
4176(defun gnus-set-mode-line (where) 4481(defun gnus-set-mode-line (where)
4177 "This function sets the mode line of the article or summary buffers. 4482 "Set the mode line of the article or summary buffers.
4178If WHERE is `summary', the summary mode line format will be used." 4483If WHERE is `summary', the summary mode line format will be used."
4179 ;; Is this mode line one we keep updated? 4484 ;; Is this mode line one we keep updated?
4180 (when (memq where gnus-updated-mode-lines) 4485 (when (and (memq where gnus-updated-mode-lines)
4486 (symbol-value
4487 (intern (format "gnus-%s-mode-line-format-spec" where))))
4181 (let (mode-string) 4488 (let (mode-string)
4182 (save-excursion 4489 (save-excursion
4183 ;; We evaluate this in the summary buffer since these 4490 ;; We evaluate this in the summary buffer since these
@@ -4188,7 +4495,11 @@ If WHERE is `summary', the summary mode line format will be used."
4188 (let* ((mformat (symbol-value 4495 (let* ((mformat (symbol-value
4189 (intern 4496 (intern
4190 (format "gnus-%s-mode-line-format-spec" where)))) 4497 (format "gnus-%s-mode-line-format-spec" where))))
4191 (gnus-tmp-group-name gnus-newsgroup-name) 4498 (gnus-tmp-group-name (gnus-group-name-decode
4499 gnus-newsgroup-name
4500 (gnus-group-name-charset
4501 nil
4502 gnus-newsgroup-name)))
4192 (gnus-tmp-article-number (or gnus-current-article 0)) 4503 (gnus-tmp-article-number (or gnus-current-article 0))
4193 (gnus-tmp-unread gnus-newsgroup-unreads) 4504 (gnus-tmp-unread gnus-newsgroup-unreads)
4194 (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) 4505 (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads))
@@ -4227,7 +4538,7 @@ If WHERE is `summary', the summary mode line format will be used."
4227 ;; We might have to chop a bit of the string off... 4538 ;; We might have to chop a bit of the string off...
4228 (when (> (length mode-string) max-len) 4539 (when (> (length mode-string) max-len)
4229 (setq mode-string 4540 (setq mode-string
4230 (concat (gnus-truncate-string mode-string (- max-len 3)) 4541 (concat (truncate-string-to-width mode-string (- max-len 3))
4231 "..."))) 4542 "...")))
4232 ;; Pad the mode string a bit. 4543 ;; Pad the mode string a bit.
4233 (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) 4544 (setq mode-string (format (format "%%-%ds" max-len) mode-string))))
@@ -4305,7 +4616,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4305 (active (gnus-active group)) 4616 (active (gnus-active group))
4306 ninfo) 4617 ninfo)
4307 (when entry 4618 (when entry
4308 ;; First peel off all illegal article numbers. 4619 ;; First peel off all invalid article numbers.
4309 (when active 4620 (when active
4310 (let ((ids articles) 4621 (let ((ids articles)
4311 id first) 4622 id first)
@@ -4374,15 +4685,6 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4374 ;; Update the group buffer. 4685 ;; Update the group buffer.
4375 (gnus-group-update-group group t))))) 4686 (gnus-group-update-group group t)))))
4376 4687
4377(defun gnus-methods-equal-p (m1 m2)
4378 (let ((m1 (or m1 gnus-select-method))
4379 (m2 (or m2 gnus-select-method)))
4380 (or (equal m1 m2)
4381 (and (eq (car m1) (car m2))
4382 (or (not (memq 'address (assoc (symbol-name (car m1))
4383 gnus-valid-select-methods)))
4384 (equal (nth 1 m1) (nth 1 m2)))))))
4385
4386(defvar gnus-newsgroup-none-id 0) 4688(defvar gnus-newsgroup-none-id 0)
4387 4689
4388(defun gnus-get-newsgroup-headers (&optional dependencies force-new) 4690(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
@@ -4391,11 +4693,18 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4391 (or dependencies 4693 (or dependencies
4392 (save-excursion (set-buffer gnus-summary-buffer) 4694 (save-excursion (set-buffer gnus-summary-buffer)
4393 gnus-newsgroup-dependencies))) 4695 gnus-newsgroup-dependencies)))
4394 headers id end ref) 4696 headers id end ref
4697 (mail-parse-charset gnus-newsgroup-charset)
4698 (mail-parse-ignored-charsets
4699 (save-excursion (condition-case nil
4700 (set-buffer gnus-summary-buffer)
4701 (error))
4702 gnus-newsgroup-ignored-charsets)))
4395 (save-excursion 4703 (save-excursion
4396 (set-buffer nntp-server-buffer) 4704 (set-buffer nntp-server-buffer)
4397 ;; Translate all TAB characters into SPACE characters. 4705 ;; Translate all TAB characters into SPACE characters.
4398 (subst-char-in-region (point-min) (point-max) ?\t ? t) 4706 (subst-char-in-region (point-min) (point-max) ?\t ? t)
4707 (subst-char-in-region (point-min) (point-max) ?\r ? t)
4399 (gnus-run-hooks 'gnus-parse-headers-hook) 4708 (gnus-run-hooks 'gnus-parse-headers-hook)
4400 (let ((case-fold-search t) 4709 (let ((case-fold-search t)
4401 in-reply-to header p lines chars) 4710 in-reply-to header p lines chars)
@@ -4427,15 +4736,15 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4427 (progn 4736 (progn
4428 (goto-char p) 4737 (goto-char p)
4429 (if (search-forward "\nsubject: " nil t) 4738 (if (search-forward "\nsubject: " nil t)
4430 (funcall 4739 (funcall gnus-decode-encoded-word-function
4431 gnus-unstructured-field-decoder (nnheader-header-value)) 4740 (nnheader-header-value))
4432 "(none)")) 4741 "(none)"))
4433 ;; From. 4742 ;; From.
4434 (progn 4743 (progn
4435 (goto-char p) 4744 (goto-char p)
4436 (if (search-forward "\nfrom: " nil t) 4745 (if (search-forward "\nfrom: " nil t)
4437 (funcall 4746 (funcall gnus-decode-encoded-word-function
4438 gnus-structured-field-decoder (nnheader-header-value)) 4747 (nnheader-header-value))
4439 "(nobody)")) 4748 "(nobody)"))
4440 ;; Date. 4749 ;; Date.
4441 (progn 4750 (progn
@@ -4505,7 +4814,19 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4505 (progn 4814 (progn
4506 (goto-char p) 4815 (goto-char p)
4507 (and (search-forward "\nxref: " nil t) 4816 (and (search-forward "\nxref: " nil t)
4508 (nnheader-header-value))))) 4817 (nnheader-header-value)))
4818 ;; Extra.
4819 (when gnus-extra-headers
4820 (let ((extra gnus-extra-headers)
4821 out)
4822 (while extra
4823 (goto-char p)
4824 (when (search-forward
4825 (concat "\n" (symbol-name (car extra)) ": ") nil t)
4826 (push (cons (car extra) (nnheader-header-value))
4827 out))
4828 (pop extra))
4829 out))))
4509 (when (equal id ref) 4830 (when (equal id ref)
4510 (setq ref nil)) 4831 (setq ref nil))
4511 4832
@@ -4526,16 +4847,20 @@ The resulting hash table is returned, or nil if no Xrefs were found."
4526(defun gnus-get-newsgroup-headers-xover (sequence &optional 4847(defun gnus-get-newsgroup-headers-xover (sequence &optional
4527 force-new dependencies 4848 force-new dependencies
4528 group also-fetch-heads) 4849 group also-fetch-heads)
4529 "Parse the news overview data in the server buffer, and return a 4850 "Parse the news overview data in the server buffer.
4530list of headers that match SEQUENCE (see `nntp-retrieve-headers')." 4851Return a list of headers that match SEQUENCE (see
4852`nntp-retrieve-headers')."
4531 ;; Get the Xref when the users reads the articles since most/some 4853 ;; Get the Xref when the users reads the articles since most/some
4532 ;; NNTP servers do not include Xrefs when using XOVER. 4854 ;; NNTP servers do not include Xrefs when using XOVER.
4533 (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) 4855 (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs))
4534 (let ((cur nntp-server-buffer) 4856 (let ((mail-parse-charset gnus-newsgroup-charset)
4857 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
4858 (cur nntp-server-buffer)
4535 (dependencies (or dependencies gnus-newsgroup-dependencies)) 4859 (dependencies (or dependencies gnus-newsgroup-dependencies))
4536 number headers header) 4860 number headers header)
4537 (save-excursion 4861 (save-excursion
4538 (set-buffer nntp-server-buffer) 4862 (set-buffer nntp-server-buffer)
4863 (subst-char-in-region (point-min) (point-max) ?\r ? t)
4539 ;; Allow the user to mangle the headers before parsing them. 4864 ;; Allow the user to mangle the headers before parsing them.
4540 (gnus-run-hooks 'gnus-parse-headers-hook) 4865 (gnus-run-hooks 'gnus-parse-headers-hook)
4541 (goto-char (point-min)) 4866 (goto-char (point-min))
@@ -4589,7 +4914,8 @@ This is meant to be called in `gnus-article-internal-prepare-hook'."
4589 (save-restriction 4914 (save-restriction
4590 (nnheader-narrow-to-headers) 4915 (nnheader-narrow-to-headers)
4591 (goto-char (point-min)) 4916 (goto-char (point-min))
4592 (when (or (and (eq (downcase (following-char)) ?x) 4917 (when (or (and (not (eobp))
4918 (eq (downcase (char-after)) ?x)
4593 (looking-at "Xref:")) 4919 (looking-at "Xref:"))
4594 (search-forward "\nXref:" nil t)) 4920 (search-forward "\nXref:" nil t))
4595 (goto-char (1+ (match-end 0))) 4921 (goto-char (1+ (match-end 0)))
@@ -4604,14 +4930,14 @@ the subject line on."
4604 (let* ((line (and (numberp old-header) old-header)) 4930 (let* ((line (and (numberp old-header) old-header))
4605 (old-header (and (vectorp old-header) old-header)) 4931 (old-header (and (vectorp old-header) old-header))
4606 (header (cond ((and old-header use-old-header) 4932 (header (cond ((and old-header use-old-header)
4607 old-header) 4933 old-header)
4608 ((and (numberp id) 4934 ((and (numberp id)
4609 (gnus-number-to-header id)) 4935 (gnus-number-to-header id))
4610 (gnus-number-to-header id)) 4936 (gnus-number-to-header id))
4611 (t 4937 (t
4612 (gnus-read-header id)))) 4938 (gnus-read-header id))))
4613 (number (and (numberp id) id)) 4939 (number (and (numberp id) id))
4614 d) 4940 d)
4615 (when header 4941 (when header
4616 ;; Rebuild the thread that this article is part of and go to the 4942 ;; Rebuild the thread that this article is part of and go to the
4617 ;; article we have fetched. 4943 ;; article we have fetched.
@@ -4706,7 +5032,8 @@ executed with point over the summary line of the articles."
4706 `(let ((,articles (gnus-summary-work-articles ,arg))) 5032 `(let ((,articles (gnus-summary-work-articles ,arg)))
4707 (while ,articles 5033 (while ,articles
4708 (gnus-summary-goto-subject (car ,articles)) 5034 (gnus-summary-goto-subject (car ,articles))
4709 ,@forms)))) 5035 ,@forms
5036 (pop ,articles)))))
4710 5037
4711(put 'gnus-summary-iterate 'lisp-indent-function 1) 5038(put 'gnus-summary-iterate 'lisp-indent-function 1)
4712(put 'gnus-summary-iterate 'edebug-form-spec '(form body)) 5039(put 'gnus-summary-iterate 'edebug-form-spec '(form body))
@@ -4851,9 +5178,12 @@ If `gnus-auto-center-summary' is nil, or the article buffer isn't
4851displayed, no centering will be performed." 5178displayed, no centering will be performed."
4852 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). 5179 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
4853 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. 5180 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
5181 (interactive)
4854 (let* ((top (cond ((< (window-height) 4) 0) 5182 (let* ((top (cond ((< (window-height) 4) 0)
4855 ((< (window-height) 7) 1) 5183 ((< (window-height) 7) 1)
4856 (t 2))) 5184 (t (if (numberp gnus-auto-center-summary)
5185 gnus-auto-center-summary
5186 2))))
4857 (height (1- (window-height))) 5187 (height (1- (window-height)))
4858 (bottom (save-excursion (goto-char (point-max)) 5188 (bottom (save-excursion (goto-char (point-max))
4859 (forward-line (- height)) 5189 (forward-line (- height))
@@ -4868,7 +5198,8 @@ displayed, no centering will be performed."
4868 ;; whichever is the least. 5198 ;; whichever is the least.
4869 (set-window-start 5199 (set-window-start
4870 window (min bottom (save-excursion 5200 window (min bottom (save-excursion
4871 (forward-line (- top)) (point))))) 5201 (forward-line (- top)) (point)))
5202 t))
4872 ;; Do horizontal recentering while we're at it. 5203 ;; Do horizontal recentering while we're at it.
4873 (when (and (get-buffer-window (current-buffer) t) 5204 (when (and (get-buffer-window (current-buffer) t)
4874 (not (eq gnus-auto-center-summary 'vertical))) 5205 (not (eq gnus-auto-center-summary 'vertical)))
@@ -4908,7 +5239,10 @@ displayed, no centering will be performed."
4908 ;; If the range of read articles is a single range, then the 5239 ;; If the range of read articles is a single range, then the
4909 ;; first unread article is the article after the last read 5240 ;; first unread article is the article after the last read
4910 ;; article. Sounds logical, doesn't it? 5241 ;; article. Sounds logical, doesn't it?
4911 (if (not (listp (cdr read))) 5242 (if (and (not (listp (cdr read)))
5243 (or (< (car read) (car active))
5244 (progn (setq read (list read))
5245 nil)))
4912 (setq first (max (car active) (1+ (cdr read)))) 5246 (setq first (max (car active) (1+ (cdr read))))
4913 ;; `read' is a list of ranges. 5247 ;; `read' is a list of ranges.
4914 (when (/= (setq nlast (or (and (numberp (car read)) (car read)) 5248 (when (/= (setq nlast (or (and (numberp (car read)) (car read))
@@ -4965,8 +5299,7 @@ displayed, no centering will be performed."
4965 (key-binding 5299 (key-binding
4966 (read-key-sequence 5300 (read-key-sequence
4967 (substitute-command-keys 5301 (substitute-command-keys
4968 "\\<gnus-summary-mode-map>\\[gnus-summary-universal-argument]" 5302 "\\<gnus-summary-mode-map>\\[gnus-summary-universal-argument]"))))
4969 ))))
4970 'undefined) 5303 'undefined)
4971 (gnus-error 1 "Undefined key") 5304 (gnus-error 1 "Undefined key")
4972 (save-excursion 5305 (save-excursion
@@ -5062,9 +5395,16 @@ If FORCE (the prefix), also save the .newsrc file(s)."
5062 5395
5063(defun gnus-summary-exit (&optional temporary) 5396(defun gnus-summary-exit (&optional temporary)
5064 "Exit reading current newsgroup, and then return to group selection mode. 5397 "Exit reading current newsgroup, and then return to group selection mode.
5065gnus-exit-group-hook is called with no arguments if that value is non-nil." 5398`gnus-exit-group-hook' is called with no arguments if that value is non-nil."
5066 (interactive) 5399 (interactive)
5067 (gnus-set-global-variables) 5400 (gnus-set-global-variables)
5401 (when (gnus-buffer-live-p gnus-article-buffer)
5402 (save-excursion
5403 (set-buffer gnus-article-buffer)
5404 (mm-destroy-parts gnus-article-mime-handles)
5405 ;; Set it to nil for safety reason.
5406 (setq gnus-article-mime-handle-alist nil)
5407 (setq gnus-article-mime-handles nil)))
5068 (gnus-kill-save-kill-buffer) 5408 (gnus-kill-save-kill-buffer)
5069 (gnus-async-halt-prefetch) 5409 (gnus-async-halt-prefetch)
5070 (let* ((group gnus-newsgroup-name) 5410 (let* ((group gnus-newsgroup-name)
@@ -5072,6 +5412,12 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
5072 (mode major-mode) 5412 (mode major-mode)
5073 (group-point nil) 5413 (group-point nil)
5074 (buf (current-buffer))) 5414 (buf (current-buffer)))
5415 (unless quit-config
5416 ;; Do adaptive scoring, and possibly save score files.
5417 (when gnus-newsgroup-adaptive
5418 (gnus-score-adaptive))
5419 (when gnus-use-scoring
5420 (gnus-score-save)))
5075 (gnus-run-hooks 'gnus-summary-prepare-exit-hook) 5421 (gnus-run-hooks 'gnus-summary-prepare-exit-hook)
5076 ;; If we have several article buffers, we kill them at exit. 5422 ;; If we have several article buffers, we kill them at exit.
5077 (unless gnus-single-article-buffer 5423 (unless gnus-single-article-buffer
@@ -5085,17 +5431,14 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
5085 (gnus-dup-enter-articles)) 5431 (gnus-dup-enter-articles))
5086 (when gnus-use-trees 5432 (when gnus-use-trees
5087 (gnus-tree-close group)) 5433 (gnus-tree-close group))
5434 (when gnus-use-cache
5435 (gnus-cache-write-active))
5088 ;; Remove entries for this group. 5436 ;; Remove entries for this group.
5089 (nnmail-purge-split-history (gnus-group-real-name group)) 5437 (nnmail-purge-split-history (gnus-group-real-name group))
5090 ;; Make all changes in this group permanent. 5438 ;; Make all changes in this group permanent.
5091 (unless quit-config 5439 (unless quit-config
5092 (gnus-run-hooks 'gnus-exit-group-hook) 5440 (gnus-run-hooks 'gnus-exit-group-hook)
5093 (gnus-summary-update-info) 5441 (gnus-summary-update-info))
5094 ;; Do adaptive scoring, and possibly save score files.
5095 (when gnus-newsgroup-adaptive
5096 (gnus-score-adaptive))
5097 (when gnus-use-scoring
5098 (gnus-score-save)))
5099 (gnus-close-group group) 5442 (gnus-close-group group)
5100 ;; Make sure where we were, and go to next newsgroup. 5443 ;; Make sure where we were, and go to next newsgroup.
5101 (set-buffer gnus-group-buffer) 5444 (set-buffer gnus-group-buffer)
@@ -5153,7 +5496,16 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
5153 gnus-expert-user 5496 gnus-expert-user
5154 (gnus-y-or-n-p "Discard changes to this group and exit? ")) 5497 (gnus-y-or-n-p "Discard changes to this group and exit? "))
5155 (gnus-async-halt-prefetch) 5498 (gnus-async-halt-prefetch)
5156 (gnus-run-hooks 'gnus-summary-prepare-exit-hook) 5499 (mapcar 'funcall
5500 (delq 'gnus-summary-expire-articles
5501 (copy-sequence gnus-summary-prepare-exit-hook)))
5502 (when (gnus-buffer-live-p gnus-article-buffer)
5503 (save-excursion
5504 (set-buffer gnus-article-buffer)
5505 (mm-destroy-parts gnus-article-mime-handles)
5506 ;; Set it to nil for safety reason.
5507 (setq gnus-article-mime-handle-alist nil)
5508 (setq gnus-article-mime-handles nil)))
5157 ;; If we have several article buffers, we kill them at exit. 5509 ;; If we have several article buffers, we kill them at exit.
5158 (unless gnus-single-article-buffer 5510 (unless gnus-single-article-buffer
5159 (gnus-kill-buffer gnus-article-buffer) 5511 (gnus-kill-buffer gnus-article-buffer)
@@ -5261,7 +5613,8 @@ The state which existed when entering the ephemeral is reset."
5261 (rename-buffer 5613 (rename-buffer
5262 (concat (substring name 0 (match-beginning 0)) "Dead " 5614 (concat (substring name 0 (match-beginning 0)) "Dead "
5263 (substring name (match-beginning 0))) 5615 (substring name (match-beginning 0)))
5264 t)))) 5616 t)
5617 (bury-buffer))))
5265 5618
5266(defun gnus-kill-or-deaden-summary (buffer) 5619(defun gnus-kill-or-deaden-summary (buffer)
5267 "Kill or deaden the summary BUFFER." 5620 "Kill or deaden the summary BUFFER."
@@ -5322,8 +5675,7 @@ in."
5322(defun gnus-summary-describe-briefly () 5675(defun gnus-summary-describe-briefly ()
5323 "Describe summary mode commands briefly." 5676 "Describe summary mode commands briefly."
5324 (interactive) 5677 (interactive)
5325 (gnus-message 6 5678 (gnus-message 6 (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
5326 (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
5327 5679
5328;; Walking around group mode buffer from summary mode. 5680;; Walking around group mode buffer from summary mode.
5329 5681
@@ -5429,8 +5781,8 @@ returned."
5429 (if backward 5781 (if backward
5430 (gnus-summary-find-prev unread) 5782 (gnus-summary-find-prev unread)
5431 (gnus-summary-find-next unread))) 5783 (gnus-summary-find-next unread)))
5432 (gnus-summary-show-thread) 5784 (unless (zerop (setq n (1- n)))
5433 (setq n (1- n))) 5785 (gnus-summary-show-thread)))
5434 (when (/= 0 n) 5786 (when (/= 0 n)
5435 (gnus-message 7 "No more%s articles" 5787 (gnus-message 7 "No more%s articles"
5436 (if unread " unread" ""))) 5788 (if unread " unread" "")))
@@ -5521,35 +5873,41 @@ be displayed."
5521 (set-buffer gnus-summary-buffer)) 5873 (set-buffer gnus-summary-buffer))
5522 (let ((article (or article (gnus-summary-article-number))) 5874 (let ((article (or article (gnus-summary-article-number)))
5523 (all-headers (not (not all-headers))) ;Must be T or NIL. 5875 (all-headers (not (not all-headers))) ;Must be T or NIL.
5524 gnus-summary-display-article-function 5876 gnus-summary-display-article-function)
5525 did)
5526 (and (not pseudo) 5877 (and (not pseudo)
5527 (gnus-summary-article-pseudo-p article) 5878 (gnus-summary-article-pseudo-p article)
5528 (error "This is a pseudo-article")) 5879 (error "This is a pseudo-article"))
5529 (prog1 5880 (save-excursion
5530 (save-excursion 5881 (set-buffer gnus-summary-buffer)
5531 (set-buffer gnus-summary-buffer) 5882 (if (or (and gnus-single-article-buffer
5532 (if (or (and gnus-single-article-buffer 5883 (or (null gnus-current-article)
5533 (or (null gnus-current-article) 5884 (null gnus-article-current)
5534 (null gnus-article-current) 5885 (null (get-buffer gnus-article-buffer))
5535 (null (get-buffer gnus-article-buffer)) 5886 (not (eq article (cdr gnus-article-current)))
5536 (not (eq article (cdr gnus-article-current))) 5887 (not (equal (car gnus-article-current)
5537 (not (equal (car gnus-article-current) 5888 gnus-newsgroup-name))))
5538 gnus-newsgroup-name)))) 5889 (and (not gnus-single-article-buffer)
5539 (and (not gnus-single-article-buffer) 5890 (or (null gnus-current-article)
5540 (or (null gnus-current-article) 5891 (not (eq gnus-current-article article))))
5541 (not (eq gnus-current-article article)))) 5892 force)
5542 force) 5893 ;; The requested article is different from the current article.
5543 ;; The requested article is different from the current article. 5894 (progn
5544 (prog1 5895 (when (gnus-buffer-live-p gnus-article-buffer)
5545 (gnus-summary-display-article article all-headers) 5896 (with-current-buffer gnus-article-buffer
5546 (setq did article)) 5897 (mm-enable-multibyte)))
5898 (gnus-summary-display-article article all-headers)
5899 (when (gnus-buffer-live-p gnus-article-buffer)
5900 (with-current-buffer gnus-article-buffer
5901 (if (not gnus-article-decoded-p) ;; a local variable
5902 (mm-disable-multibyte))))
5547 (when (or all-headers gnus-show-all-headers) 5903 (when (or all-headers gnus-show-all-headers)
5548 (gnus-article-show-all-headers)) 5904 (gnus-article-show-all-headers))
5549 'old)) 5905 (gnus-article-set-window-start
5550 (when did 5906 (cdr (assq article gnus-newsgroup-bookmarks)))
5551 (gnus-article-set-window-start 5907 article)
5552 (cdr (assq article gnus-newsgroup-bookmarks))))))) 5908 (when (or all-headers gnus-show-all-headers)
5909 (gnus-article-show-all-headers))
5910 'old))))
5553 5911
5554(defun gnus-summary-set-current-mark (&optional current-mark) 5912(defun gnus-summary-set-current-mark (&optional current-mark)
5555 "Obsolete function." 5913 "Obsolete function."
@@ -5821,15 +6179,25 @@ Return nil if there are no unread articles."
5821 (gnus-summary-display-article (gnus-summary-article-number))) 6179 (gnus-summary-display-article (gnus-summary-article-number)))
5822 (gnus-summary-position-point))) 6180 (gnus-summary-position-point)))
5823 6181
6182(defun gnus-summary-first-unread-subject ()
6183 "Place the point on the subject line of the first unread article.
6184Return nil if there are no unread articles."
6185 (interactive)
6186 (prog1
6187 (when (gnus-summary-first-subject t)
6188 (gnus-summary-show-thread)
6189 (gnus-summary-first-subject t))
6190 (gnus-summary-position-point)))
6191
5824(defun gnus-summary-first-article () 6192(defun gnus-summary-first-article ()
5825 "Select the first article. 6193 "Select the first article.
5826Return nil if there are no articles." 6194Return nil if there are no articles."
5827 (interactive) 6195 (interactive)
5828 (prog1 6196 (prog1
5829 (when (gnus-summary-first-subject) 6197 (when (gnus-summary-first-subject)
5830 (gnus-summary-show-thread) 6198 (gnus-summary-show-thread)
5831 (gnus-summary-first-subject) 6199 (gnus-summary-first-subject)
5832 (gnus-summary-display-article (gnus-summary-article-number))) 6200 (gnus-summary-display-article (gnus-summary-article-number)))
5833 (gnus-summary-position-point))) 6201 (gnus-summary-position-point)))
5834 6202
5835(defun gnus-summary-best-unread-article () 6203(defun gnus-summary-best-unread-article ()
@@ -5951,16 +6319,32 @@ If given a prefix, remove all limits."
5951 "Limit the summary buffer to articles that are older than (or equal) AGE days. 6319 "Limit the summary buffer to articles that are older than (or equal) AGE days.
5952If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to 6320If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to
5953articles that are younger than AGE days." 6321articles that are younger than AGE days."
5954 (interactive "nTime in days: \nP") 6322 (interactive
6323 (let ((younger current-prefix-arg)
6324 (days-got nil)
6325 days)
6326 (while (not days-got)
6327 (setq days (if younger
6328 (read-string "Limit to articles within (in days): ")
6329 (read-string "Limit to articles old than (in days): ")))
6330 (when (> (length days) 0)
6331 (setq days (read days)))
6332 (if (numberp days)
6333 (setq days-got t)
6334 (message "Please enter a number.")
6335 (sleep-for 1)))
6336 (list days younger)))
5955 (prog1 6337 (prog1
5956 (let ((data gnus-newsgroup-data) 6338 (let ((data gnus-newsgroup-data)
5957 (cutoff (nnmail-days-to-time age)) 6339 (cutoff (days-to-time age))
5958 articles d date is-younger) 6340 articles d date is-younger)
5959 (while (setq d (pop data)) 6341 (while (setq d (pop data))
5960 (when (and (vectorp (gnus-data-header d)) 6342 (when (and (vectorp (gnus-data-header d))
5961 (setq date (mail-header-date (gnus-data-header d)))) 6343 (setq date (mail-header-date (gnus-data-header d))))
5962 (setq is-younger (nnmail-time-less 6344 (setq is-younger (time-less-p
5963 (nnmail-time-since (nnmail-date-to-time date)) 6345 (time-since (condition-case ()
6346 (date-to-time date)
6347 (error '(0 0))))
5964 cutoff)) 6348 cutoff))
5965 (when (if younger-p 6349 (when (if younger-p
5966 is-younger 6350 is-younger
@@ -5969,6 +6353,30 @@ articles that are younger than AGE days."
5969 (gnus-summary-limit (nreverse articles))) 6353 (gnus-summary-limit (nreverse articles)))
5970 (gnus-summary-position-point))) 6354 (gnus-summary-position-point)))
5971 6355
6356(defun gnus-summary-limit-to-extra (header regexp)
6357 "Limit the summary buffer to articles that match an 'extra' header."
6358 (interactive
6359 (let ((header
6360 (intern
6361 (gnus-completing-read
6362 (symbol-name (car gnus-extra-headers))
6363 "Limit extra header:"
6364 (mapcar (lambda (x)
6365 (cons (symbol-name x) x))
6366 gnus-extra-headers)
6367 nil
6368 t))))
6369 (list header
6370 (read-string (format "Limit to header %s (regexp): " header)))))
6371 (when (not (equal "" regexp))
6372 (prog1
6373 (let ((articles (gnus-summary-find-matching
6374 (cons 'extra header) regexp 'all)))
6375 (unless articles
6376 (error "Found no matches for \"%s\"" regexp))
6377 (gnus-summary-limit articles))
6378 (gnus-summary-position-point))))
6379
5972(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) 6380(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
5973(make-obsolete 6381(make-obsolete
5974 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) 6382 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
@@ -6166,6 +6574,7 @@ If ALL, mark even excluded ticked and dormants as read."
6166 "Go forwards in the thread until we find an article that we want to display." 6574 "Go forwards in the thread until we find an article that we want to display."
6167 (when (or (eq gnus-fetch-old-headers 'some) 6575 (when (or (eq gnus-fetch-old-headers 'some)
6168 (eq gnus-fetch-old-headers 'invisible) 6576 (eq gnus-fetch-old-headers 'invisible)
6577 (numberp gnus-fetch-old-headers)
6169 (eq gnus-build-sparse-threads 'some) 6578 (eq gnus-build-sparse-threads 'some)
6170 (eq gnus-build-sparse-threads 'more)) 6579 (eq gnus-build-sparse-threads 'more))
6171 ;; Deal with old-fetched headers and sparse threads. 6580 ;; Deal with old-fetched headers and sparse threads.
@@ -6195,6 +6604,7 @@ If ALL, mark even excluded ticked and dormants as read."
6195 "Cut off all uninteresting articles from the beginning of threads." 6604 "Cut off all uninteresting articles from the beginning of threads."
6196 (when (or (eq gnus-fetch-old-headers 'some) 6605 (when (or (eq gnus-fetch-old-headers 'some)
6197 (eq gnus-fetch-old-headers 'invisible) 6606 (eq gnus-fetch-old-headers 'invisible)
6607 (numberp gnus-fetch-old-headers)
6198 (eq gnus-build-sparse-threads 'some) 6608 (eq gnus-build-sparse-threads 'some)
6199 (eq gnus-build-sparse-threads 'more)) 6609 (eq gnus-build-sparse-threads 'more))
6200 (let ((th threads)) 6610 (let ((th threads))
@@ -6212,6 +6622,7 @@ fetch-old-headers verbiage, and so on."
6212 (if (or gnus-inhibit-limiting 6622 (if (or gnus-inhibit-limiting
6213 (and (null gnus-newsgroup-dormant) 6623 (and (null gnus-newsgroup-dormant)
6214 (not (eq gnus-fetch-old-headers 'some)) 6624 (not (eq gnus-fetch-old-headers 'some))
6625 (not (numberp gnus-fetch-old-headers))
6215 (not (eq gnus-fetch-old-headers 'invisible)) 6626 (not (eq gnus-fetch-old-headers 'invisible))
6216 (null gnus-summary-expunge-below) 6627 (null gnus-summary-expunge-below)
6217 (not (eq gnus-build-sparse-threads 'some)) 6628 (not (eq gnus-build-sparse-threads 'some))
@@ -6265,7 +6676,8 @@ fetch-old-headers verbiage, and so on."
6265 (zerop children)) 6676 (zerop children))
6266 ;; If this is "fetch-old-headered" and there is no 6677 ;; If this is "fetch-old-headered" and there is no
6267 ;; visible children, then we don't want this article. 6678 ;; visible children, then we don't want this article.
6268 (and (eq gnus-fetch-old-headers 'some) 6679 (and (or (eq gnus-fetch-old-headers 'some)
6680 (numberp gnus-fetch-old-headers))
6269 (gnus-summary-article-ancient-p number) 6681 (gnus-summary-article-ancient-p number)
6270 (zerop children)) 6682 (zerop children))
6271 ;; If this is "fetch-old-headered" and `invisible', then 6683 ;; If this is "fetch-old-headered" and `invisible', then
@@ -6416,11 +6828,9 @@ of what's specified by the `gnus-refer-thread-limit' variable."
6416 (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) 6828 (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name))
6417 (gnus-summary-limit-include-thread id))) 6829 (gnus-summary-limit-include-thread id)))
6418 6830
6419(defun gnus-summary-refer-article (message-id &optional arg) 6831(defun gnus-summary-refer-article (message-id)
6420 "Fetch an article specified by MESSAGE-ID. 6832 "Fetch an article specified by MESSAGE-ID."
6421If ARG (the prefix), fetch the article using `gnus-refer-article-method' 6833 (interactive "sMessage-ID: ")
6422or `gnus-select-method', no matter what backend the article comes from."
6423 (interactive "sMessage-ID: \nP")
6424 (when (and (stringp message-id) 6834 (when (and (stringp message-id)
6425 (not (zerop (length message-id)))) 6835 (not (zerop (length message-id))))
6426 ;; Construct the correct Message-ID if necessary. 6836 ;; Construct the correct Message-ID if necessary.
@@ -6434,7 +6844,8 @@ or `gnus-select-method', no matter what backend the article comes from."
6434 (gnus-summary-article-sparse-p 6844 (gnus-summary-article-sparse-p
6435 (mail-header-number header)) 6845 (mail-header-number header))
6436 (memq (mail-header-number header) 6846 (memq (mail-header-number header)
6437 gnus-newsgroup-limit)))) 6847 gnus-newsgroup-limit)))
6848 number)
6438 (cond 6849 (cond
6439 ;; If the article is present in the buffer we just go to it. 6850 ;; If the article is present in the buffer we just go to it.
6440 ((and header 6851 ((and header
@@ -6447,28 +6858,48 @@ or `gnus-select-method', no matter what backend the article comes from."
6447 (when sparse 6858 (when sparse
6448 (gnus-summary-update-article (mail-header-number header))))) 6859 (gnus-summary-update-article (mail-header-number header)))))
6449 (t 6860 (t
6450 ;; We fetch the article 6861 ;; We fetch the article.
6451 (let ((gnus-override-method 6862 (catch 'found
6452 (cond ((gnus-news-group-p gnus-newsgroup-name) 6863 (dolist (gnus-override-method (gnus-refer-article-methods))
6453 gnus-refer-article-method) 6864 (gnus-check-server gnus-override-method)
6454 (arg 6865 ;; Fetch the header, and display the article.
6455 (or gnus-refer-article-method gnus-select-method)) 6866 (when (setq number (gnus-summary-insert-subject message-id))
6456 (t nil)))
6457 number)
6458 ;; Start the special refer-article method, if necessary.
6459 (when (and gnus-refer-article-method
6460 (gnus-news-group-p gnus-newsgroup-name))
6461 (gnus-check-server gnus-refer-article-method))
6462 ;; Fetch the header, and display the article.
6463 (if (setq number (gnus-summary-insert-subject message-id))
6464 (gnus-summary-select-article nil nil nil number) 6867 (gnus-summary-select-article nil nil nil number)
6465 (gnus-message 3 "Couldn't fetch article %s" message-id)))))))) 6868 (throw 'found t)))
6869 (gnus-message 3 "Couldn't fetch article %s" message-id)))))))
6870
6871(defun gnus-refer-article-methods ()
6872 "Return a list of referrable methods."
6873 (cond
6874 ;; No method, so we default to current and native.
6875 ((null gnus-refer-article-method)
6876 (list gnus-current-select-method gnus-select-method))
6877 ;; Current.
6878 ((eq 'current gnus-refer-article-method)
6879 (list gnus-current-select-method))
6880 ;; List of select methods.
6881 ((not (stringp (cadr gnus-refer-article-method)))
6882 (let (out)
6883 (dolist (method gnus-refer-article-method)
6884 (push (if (eq 'current method)
6885 gnus-current-select-method
6886 method)
6887 out))
6888 (nreverse out)))
6889 ;; One single select method.
6890 (t
6891 (list gnus-refer-article-method))))
6466 6892
6467(defun gnus-summary-edit-parameters () 6893(defun gnus-summary-edit-parameters ()
6468 "Edit the group parameters of the current group." 6894 "Edit the group parameters of the current group."
6469 (interactive) 6895 (interactive)
6470 (gnus-group-edit-group gnus-newsgroup-name 'params)) 6896 (gnus-group-edit-group gnus-newsgroup-name 'params))
6471 6897
6898(defun gnus-summary-customize-parameters ()
6899 "Customize the group parameters of the current group."
6900 (interactive)
6901 (gnus-group-customize gnus-newsgroup-name))
6902
6472(defun gnus-summary-enter-digest-group (&optional force) 6903(defun gnus-summary-enter-digest-group (&optional force)
6473 "Enter an nndoc group based on the current article. 6904 "Enter an nndoc group based on the current article.
6474If FORCE, force a digest interpretation. If not, try 6905If FORCE, force a digest interpretation. If not, try
@@ -6490,8 +6921,14 @@ to guess what the document format is."
6490 (list (cons 'save-article-group ogroup)))) 6921 (list (cons 'save-article-group ogroup))))
6491 (case-fold-search t) 6922 (case-fold-search t)
6492 (buf (current-buffer)) 6923 (buf (current-buffer))
6493 dig) 6924 dig to-address)
6494 (save-excursion 6925 (save-excursion
6926 (set-buffer gnus-original-article-buffer)
6927 ;; Have the digest group inherit the main mail address of
6928 ;; the parent article.
6929 (when (setq to-address (or (message-fetch-field "reply-to")
6930 (message-fetch-field "from")))
6931 (setq params (append (list (cons 'to-address to-address)))))
6495 (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) 6932 (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*"))
6496 (insert-buffer-substring gnus-original-article-buffer) 6933 (insert-buffer-substring gnus-original-article-buffer)
6497 ;; Remove lines that may lead nndoc to misinterpret the 6934 ;; Remove lines that may lead nndoc to misinterpret the
@@ -6500,14 +6937,17 @@ to guess what the document format is."
6500 (goto-char (point-min)) 6937 (goto-char (point-min))
6501 (or (search-forward "\n\n" nil t) (point))) 6938 (or (search-forward "\n\n" nil t) (point)))
6502 (goto-char (point-min)) 6939 (goto-char (point-min))
6503 (delete-matching-lines "^\\(Path\\):\\|^From ") 6940 (delete-matching-lines "^Path:\\|^From ")
6504 (widen)) 6941 (widen))
6505 (unwind-protect 6942 (unwind-protect
6506 (if (gnus-group-read-ephemeral-group 6943 (if (let ((gnus-newsgroup-ephemeral-charset gnus-newsgroup-charset)
6507 name `(nndoc ,name (nndoc-address ,(get-buffer dig)) 6944 (gnus-newsgroup-ephemeral-ignored-charsets
6508 (nndoc-article-type 6945 gnus-newsgroup-ignored-charsets))
6509 ,(if force 'digest 'guess))) t) 6946 (gnus-group-read-ephemeral-group
6510 ;; Make all postings to this group go to the parent group. 6947 name `(nndoc ,name (nndoc-address ,(get-buffer dig))
6948 (nndoc-article-type
6949 ,(if force 'mbox 'guess))) t))
6950 ;; Make all postings to this group go to the parent group.
6511 (nconc (gnus-info-params (gnus-get-info name)) 6951 (nconc (gnus-info-params (gnus-get-info name))
6512 params) 6952 params)
6513 ;; Couldn't select this doc group. 6953 ;; Couldn't select this doc group.
@@ -6533,7 +6973,7 @@ Obeys the standard process/prefix convention."
6533 (gnus-summary-remove-process-mark article) 6973 (gnus-summary-remove-process-mark article)
6534 (when (gnus-summary-display-article article) 6974 (when (gnus-summary-display-article article)
6535 (save-excursion 6975 (save-excursion
6536 (nnheader-temp-write nil 6976 (with-temp-buffer
6537 (insert-buffer-substring gnus-original-article-buffer) 6977 (insert-buffer-substring gnus-original-article-buffer)
6538 ;; Remove some headers that may lead nndoc to make 6978 ;; Remove some headers that may lead nndoc to make
6539 ;; the wrong guess. 6979 ;; the wrong guess.
@@ -6613,18 +7053,21 @@ Optional argument BACKWARD means do search for backward.
6613 ;; We have to require this here to make sure that the following 7053 ;; We have to require this here to make sure that the following
6614 ;; dynamic binding isn't shadowed by autoloading. 7054 ;; dynamic binding isn't shadowed by autoloading.
6615 (require 'gnus-async) 7055 (require 'gnus-async)
7056 (require 'gnus-art)
6616 (let ((gnus-select-article-hook nil) ;Disable hook. 7057 (let ((gnus-select-article-hook nil) ;Disable hook.
6617 (gnus-article-display-hook nil) 7058 (gnus-article-prepare-hook nil)
6618 (gnus-mark-article-hook nil) ;Inhibit marking as read. 7059 (gnus-mark-article-hook nil) ;Inhibit marking as read.
6619 (gnus-use-article-prefetch nil) 7060 (gnus-use-article-prefetch nil)
6620 (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. 7061 (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay.
6621 (gnus-use-trees nil) ;Inhibit updating tree buffer. 7062 (gnus-use-trees nil) ;Inhibit updating tree buffer.
6622 (sum (current-buffer)) 7063 (sum (current-buffer))
7064 (gnus-display-mime-function nil)
6623 (found nil) 7065 (found nil)
6624 point) 7066 point)
6625 (gnus-save-hidden-threads 7067 (gnus-save-hidden-threads
6626 (gnus-summary-select-article) 7068 (gnus-summary-select-article)
6627 (set-buffer gnus-article-buffer) 7069 (set-buffer gnus-article-buffer)
7070 (goto-char (window-point (get-buffer-window (current-buffer))))
6628 (when backward 7071 (when backward
6629 (forward-line -1)) 7072 (forward-line -1))
6630 (while (not found) 7073 (while (not found)
@@ -6640,6 +7083,9 @@ Optional argument BACKWARD means do search for backward.
6640 (get-buffer-window (current-buffer)) 7083 (get-buffer-window (current-buffer))
6641 (point)) 7084 (point))
6642 (forward-line 1) 7085 (forward-line 1)
7086 (set-window-point
7087 (get-buffer-window (current-buffer))
7088 (point))
6643 (set-buffer sum) 7089 (set-buffer sum)
6644 (setq point (point))) 7090 (setq point (point)))
6645 ;; We didn't find it, so we go to the next article. 7091 ;; We didn't find it, so we go to the next article.
@@ -6678,11 +7124,18 @@ in the comparisons."
6678 (let ((data (if (eq backward 'all) gnus-newsgroup-data 7124 (let ((data (if (eq backward 'all) gnus-newsgroup-data
6679 (gnus-data-find-list 7125 (gnus-data-find-list
6680 (gnus-summary-article-number) (gnus-data-list backward)))) 7126 (gnus-summary-article-number) (gnus-data-list backward))))
6681 (func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))
6682 (case-fold-search (not not-case-fold)) 7127 (case-fold-search (not not-case-fold))
6683 articles d) 7128 articles d func)
6684 (unless (fboundp (intern (concat "mail-header-" header))) 7129 (if (consp header)
6685 (error "%s is not a valid header" header)) 7130 (if (eq (car header) 'extra)
7131 (setq func
7132 `(lambda (h)
7133 (or (cdr (assq ',(cdr header) (mail-header-extra h)))
7134 "")))
7135 (error "%s is an invalid header" header))
7136 (unless (fboundp (intern (concat "mail-header-" header)))
7137 (error "%s is not a valid header" header))
7138 (setq func `(lambda (h) (,(intern (concat "mail-header-" header)) h))))
6686 (while data 7139 (while data
6687 (setq d (car data)) 7140 (setq d (car data))
6688 (and (or (not unread) ; We want all articles... 7141 (and (or (not unread) ; We want all articles...
@@ -6751,7 +7204,7 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead."
6751If N is negative, print the N previous articles. If N is nil and articles 7204If N is negative, print the N previous articles. If N is nil and articles
6752have been marked with the process mark, print these instead. 7205have been marked with the process mark, print these instead.
6753 7206
6754If the optional second argument FILENAME is nil, send the image to the 7207If the optional first argument FILENAME is nil, send the image to the
6755printer. If FILENAME is a string, save the PostScript image in a file with 7208printer. If FILENAME is a string, save the PostScript image in a file with
6756that name. If FILENAME is a number, prompt the user for the name of the file 7209that name. If FILENAME is a number, prompt the user for the name of the file
6757to save in." 7210to save in."
@@ -6784,20 +7237,42 @@ to save in."
6784 7237
6785(defun gnus-summary-show-article (&optional arg) 7238(defun gnus-summary-show-article (&optional arg)
6786 "Force re-fetching of the current article. 7239 "Force re-fetching of the current article.
6787If ARG (the prefix) is non-nil, show the raw article without any 7240If ARG (the prefix) is a number, show the article with the charset
6788article massaging functions being run." 7241defined in `gnus-summary-show-article-charset-alist', or the charset
7242inputed.
7243If ARG (the prefix) is non-nil and not a number, show the raw article
7244without any article massaging functions being run."
6789 (interactive "P") 7245 (interactive "P")
6790 (if (not arg) 7246 (cond
6791 ;; Select the article the normal way. 7247 ((numberp arg)
6792 (gnus-summary-select-article nil 'force) 7248 (let ((gnus-newsgroup-charset
7249 (or (cdr (assq arg gnus-summary-show-article-charset-alist))
7250 (read-coding-system "Charset: ")))
7251 (gnus-newsgroup-ignored-charsets 'gnus-all))
7252 (gnus-summary-select-article nil 'force)))
7253 ((not arg)
7254 ;; Select the article the normal way.
7255 (gnus-summary-select-article nil 'force))
7256 (t
7257 ;; We have to require this here to make sure that the following
7258 ;; dynamic binding isn't shadowed by autoloading.
7259 (require 'gnus-async)
7260 (require 'gnus-art)
6793 ;; Bind the article treatment functions to nil. 7261 ;; Bind the article treatment functions to nil.
6794 (let ((gnus-have-all-headers t) 7262 (let ((gnus-have-all-headers t)
6795 gnus-article-display-hook
6796 gnus-article-prepare-hook 7263 gnus-article-prepare-hook
6797 gnus-break-pages 7264 gnus-article-decode-hook
6798 gnus-show-mime 7265 gnus-display-mime-function
6799 gnus-visual) 7266 gnus-break-pages)
6800 (gnus-summary-select-article nil 'force))) 7267 ;; Destroy any MIME parts.
7268 (when (gnus-buffer-live-p gnus-article-buffer)
7269 (save-excursion
7270 (set-buffer gnus-article-buffer)
7271 (mm-destroy-parts gnus-article-mime-handles)
7272 ;; Set it to nil for safety reason.
7273 (setq gnus-article-mime-handle-alist nil)
7274 (setq gnus-article-mime-handles nil)))
7275 (gnus-summary-select-article nil 'force))))
6801 (gnus-summary-goto-subject gnus-current-article) 7276 (gnus-summary-goto-subject gnus-current-article)
6802 (gnus-summary-position-point)) 7277 (gnus-summary-position-point))
6803 7278
@@ -6821,40 +7296,42 @@ If ARG is a negative number, hide the unwanted header lines."
6821 (interactive "P") 7296 (interactive "P")
6822 (save-excursion 7297 (save-excursion
6823 (set-buffer gnus-article-buffer) 7298 (set-buffer gnus-article-buffer)
6824 (let* ((buffer-read-only nil) 7299 (save-restriction
6825 (inhibit-point-motion-hooks t) 7300 (let* ((buffer-read-only nil)
6826 (hidden (text-property-any 7301 (inhibit-point-motion-hooks t)
6827 (goto-char (point-min)) (search-forward "\n\n") 7302 hidden e)
6828 'invisible t)) 7303 (setq hidden
6829 e) 7304 (if (numberp arg)
6830 (goto-char (point-min)) 7305 (>= arg 0)
6831 (when (search-forward "\n\n" nil t) 7306 (save-restriction
6832 (delete-region (point-min) (1- (point)))) 7307 (article-narrow-to-head)
6833 (goto-char (point-min)) 7308 (gnus-article-hidden-text-p 'headers))))
6834 (save-excursion
6835 (set-buffer gnus-original-article-buffer)
6836 (goto-char (point-min)) 7309 (goto-char (point-min))
6837 (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) 7310 (when (search-forward "\n\n" nil t)
6838 (insert-buffer-substring gnus-original-article-buffer 1 e) 7311 (delete-region (point-min) (1- (point))))
6839 (let ((article-inhibit-hiding t)) 7312 (goto-char (point-min))
6840 (gnus-run-hooks 'gnus-article-display-hook)) 7313 (save-excursion
6841 (when (or (not hidden) (and (numberp arg) (< arg 0))) 7314 (set-buffer gnus-original-article-buffer)
6842 (gnus-article-hide-headers))))) 7315 (goto-char (point-min))
7316 (setq e (1- (or (search-forward "\n\n" nil t) (point-max)))))
7317 (insert-buffer-substring gnus-original-article-buffer 1 e)
7318 (save-restriction
7319 (narrow-to-region (point-min) (point))
7320 (article-decode-encoded-words)
7321 (if hidden
7322 (let ((gnus-treat-hide-headers nil)
7323 (gnus-treat-hide-boring-headers nil))
7324 (setq gnus-article-wash-types
7325 (delq 'headers gnus-article-wash-types))
7326 (gnus-treat-article 'head))
7327 (gnus-treat-article 'head)))
7328 (gnus-set-mode-line 'article)))))
6843 7329
6844(defun gnus-summary-show-all-headers () 7330(defun gnus-summary-show-all-headers ()
6845 "Make all header lines visible." 7331 "Make all header lines visible."
6846 (interactive) 7332 (interactive)
6847 (gnus-article-show-all-headers)) 7333 (gnus-article-show-all-headers))
6848 7334
6849(defun gnus-summary-toggle-mime (&optional arg)
6850 "Toggle MIME processing.
6851If ARG is a positive number, turn MIME processing on."
6852 (interactive "P")
6853 (setq gnus-show-mime
6854 (if (null arg) (not gnus-show-mime)
6855 (> (prefix-numeric-value arg) 0)))
6856 (gnus-summary-select-article t 'force))
6857
6858(defun gnus-summary-caesar-message (&optional arg) 7335(defun gnus-summary-caesar-message (&optional arg)
6859 "Caesar rotate the current article by 13. 7336 "Caesar rotate the current article by 13.
6860The numerical prefix specifies how many places to rotate each letter 7337The numerical prefix specifies how many places to rotate each letter
@@ -6895,7 +7372,9 @@ re-spool using this method.
6895 7372
6896For this function to work, both the current newsgroup and the 7373For this function to work, both the current newsgroup and the
6897newsgroup that you want to move to have to support the `request-move' 7374newsgroup that you want to move to have to support the `request-move'
6898and `request-accept' functions." 7375and `request-accept' functions.
7376
7377ACTION can be either `move' (the default), `crosspost' or `copy'."
6899 (interactive "P") 7378 (interactive "P")
6900 (unless action 7379 (unless action
6901 (setq action 'move)) 7380 (setq action 'move))
@@ -6913,7 +7392,10 @@ and `request-accept' functions."
6913 'request-replace-article gnus-newsgroup-name))) 7392 'request-replace-article gnus-newsgroup-name)))
6914 (error "The current group does not support article editing"))) 7393 (error "The current group does not support article editing")))
6915 (let ((articles (gnus-summary-work-articles n)) 7394 (let ((articles (gnus-summary-work-articles n))
6916 (prefix (gnus-group-real-prefix gnus-newsgroup-name)) 7395 (prefix (if (gnus-check-backend-function
7396 'request-move-article gnus-newsgroup-name)
7397 (gnus-group-real-prefix gnus-newsgroup-name)
7398 ""))
6917 (names '((move "Move" "Moving") 7399 (names '((move "Move" "Moving")
6918 (copy "Copy" "Copying") 7400 (copy "Copy" "Copying")
6919 (crosspost "Crosspost" "Crossposting"))) 7401 (crosspost "Crosspost" "Crossposting")))
@@ -6932,7 +7414,8 @@ and `request-accept' functions."
6932 articles prefix)) 7414 articles prefix))
6933 (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) 7415 (set (intern (format "gnus-current-%s-group" action)) to-newsgroup))
6934 (setq to-method (or select-method 7416 (setq to-method (or select-method
6935 (gnus-group-name-to-method to-newsgroup))) 7417 (gnus-server-to-method
7418 (gnus-group-method to-newsgroup))))
6936 ;; Check the method we are to move this article to... 7419 ;; Check the method we are to move this article to...
6937 (unless (gnus-check-backend-function 7420 (unless (gnus-check-backend-function
6938 'request-accept-article (car to-method)) 7421 'request-accept-article (car to-method))
@@ -6958,7 +7441,7 @@ and `request-accept' functions."
6958 gnus-newsgroup-name)) ; Server 7441 gnus-newsgroup-name)) ; Server
6959 (list 'gnus-request-accept-article 7442 (list 'gnus-request-accept-article
6960 to-newsgroup (list 'quote select-method) 7443 to-newsgroup (list 'quote select-method)
6961 (not articles)) ; Accept form 7444 (not articles) t) ; Accept form
6962 (not articles))) ; Only save nov last time 7445 (not articles))) ; Only save nov last time
6963 ;; Copy the article. 7446 ;; Copy the article.
6964 ((eq action 'copy) 7447 ((eq action 'copy)
@@ -6966,7 +7449,7 @@ and `request-accept' functions."
6966 (set-buffer copy-buf) 7449 (set-buffer copy-buf)
6967 (when (gnus-request-article-this-buffer article gnus-newsgroup-name) 7450 (when (gnus-request-article-this-buffer article gnus-newsgroup-name)
6968 (gnus-request-accept-article 7451 (gnus-request-accept-article
6969 to-newsgroup select-method (not articles))))) 7452 to-newsgroup select-method (not articles) t))))
6970 ;; Crosspost the article. 7453 ;; Crosspost the article.
6971 ((eq action 'crosspost) 7454 ((eq action 'crosspost)
6972 (let ((xref (message-tokenize-header 7455 (let ((xref (message-tokenize-header
@@ -6999,19 +7482,21 @@ and `request-accept' functions."
6999 art-group)))))) 7482 art-group))))))
7000 (cond 7483 (cond
7001 ((not art-group) 7484 ((not art-group)
7002 (gnus-message 1 "Couldn't %s article %s" 7485 (gnus-message 1 "Couldn't %s article %s: %s"
7003 (cadr (assq action names)) article)) 7486 (cadr (assq action names)) article
7004 ((and (eq art-group 'junk) 7487 (nnheader-get-report (car to-method))))
7005 (eq action 'move)) 7488 ((eq art-group 'junk)
7006 (gnus-summary-mark-article article gnus-canceled-mark) 7489 (when (eq action 'move)
7007 (gnus-message 4 "Deleted article %s" article)) 7490 (gnus-summary-mark-article article gnus-canceled-mark)
7491 (gnus-message 4 "Deleted article %s" article)))
7008 (t 7492 (t
7009 (let* ((pto-group (gnus-group-prefixed-name 7493 (let* ((pto-group (gnus-group-prefixed-name
7010 (car art-group) to-method)) 7494 (car art-group) to-method))
7011 (entry 7495 (entry
7012 (gnus-gethash pto-group gnus-newsrc-hashtb)) 7496 (gnus-gethash pto-group gnus-newsrc-hashtb))
7013 (info (nth 2 entry)) 7497 (info (nth 2 entry))
7014 (to-group (gnus-info-group info))) 7498 (to-group (gnus-info-group info))
7499 to-marks)
7015 ;; Update the group that has been moved to. 7500 ;; Update the group that has been moved to.
7016 (when (and info 7501 (when (and info
7017 (memq action '(move copy))) 7502 (memq action '(move copy)))
@@ -7019,49 +7504,54 @@ and `request-accept' functions."
7019 (push to-group to-groups)) 7504 (push to-group to-groups))
7020 7505
7021 (unless (memq article gnus-newsgroup-unreads) 7506 (unless (memq article gnus-newsgroup-unreads)
7507 (push 'read to-marks)
7022 (gnus-info-set-read 7508 (gnus-info-set-read
7023 info (gnus-add-to-range (gnus-info-read info) 7509 info (gnus-add-to-range (gnus-info-read info)
7024 (list (cdr art-group))))) 7510 (list (cdr art-group)))))
7025 7511
7026 ;; Copy any marks over to the new group. 7512 ;; See whether the article is to be put in the cache.
7027 (let ((marks gnus-article-mark-lists) 7513 (let ((marks gnus-article-mark-lists)
7028 (to-article (cdr art-group))) 7514 (to-article (cdr art-group)))
7029 7515
7030 ;; See whether the article is to be put in the cache. 7516 ;; Enter the article into the cache in the new group,
7517 ;; if that is required.
7031 (when gnus-use-cache 7518 (when gnus-use-cache
7032 (gnus-cache-possibly-enter-article 7519 (gnus-cache-possibly-enter-article
7033 to-group to-article 7520 to-group to-article
7034 (let ((header (copy-sequence
7035 (gnus-summary-article-header article))))
7036 (mail-header-set-number header to-article)
7037 header)
7038 (memq article gnus-newsgroup-marked) 7521 (memq article gnus-newsgroup-marked)
7039 (memq article gnus-newsgroup-dormant) 7522 (memq article gnus-newsgroup-dormant)
7040 (memq article gnus-newsgroup-unreads))) 7523 (memq article gnus-newsgroup-unreads)))
7041 7524
7042 (when (and (equal to-group gnus-newsgroup-name) 7525 (when gnus-preserve-marks
7043 (not (memq article gnus-newsgroup-unreads))) 7526 ;; Copy any marks over to the new group.
7044 ;; Mark this article as read in this group. 7527 (when (and (equal to-group gnus-newsgroup-name)
7045 (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) 7528 (not (memq article gnus-newsgroup-unreads)))
7046 (setcdr (gnus-active to-group) to-article) 7529 ;; Mark this article as read in this group.
7047 (setcdr gnus-newsgroup-active to-article)) 7530 (push (cons to-article gnus-read-mark) gnus-newsgroup-reads)
7048 7531 (setcdr (gnus-active to-group) to-article)
7049 (while marks 7532 (setcdr gnus-newsgroup-active to-article))
7050 (when (memq article (symbol-value 7533
7051 (intern (format "gnus-newsgroup-%s" 7534 (while marks
7052 (caar marks))))) 7535 (when (memq article (symbol-value
7053 ;; If the other group is the same as this group, 7536 (intern (format "gnus-newsgroup-%s"
7054 ;; then we have to add the mark to the list. 7537 (caar marks)))))
7055 (when (equal to-group gnus-newsgroup-name) 7538 (push (cdar marks) to-marks)
7056 (set (intern (format "gnus-newsgroup-%s" (caar marks))) 7539 ;; If the other group is the same as this group,
7057 (cons to-article 7540 ;; then we have to add the mark to the list.
7058 (symbol-value 7541 (when (equal to-group gnus-newsgroup-name)
7059 (intern (format "gnus-newsgroup-%s" 7542 (set (intern (format "gnus-newsgroup-%s" (caar marks)))
7060 (caar marks))))))) 7543 (cons to-article
7061 ;; Copy the marks to other group. 7544 (symbol-value
7062 (gnus-add-marked-articles 7545 (intern (format "gnus-newsgroup-%s"
7063 to-group (cdar marks) (list to-article) info)) 7546 (caar marks)))))))
7064 (setq marks (cdr marks))) 7547 ;; Copy the marks to other group.
7548 (gnus-add-marked-articles
7549 to-group (cdar marks) (list to-article) info))
7550 (setq marks (cdr marks)))
7551
7552 (gnus-request-set-mark to-group (list (list (list to-article)
7553 'set
7554 to-marks))))
7065 7555
7066 (gnus-dribble-enter 7556 (gnus-dribble-enter
7067 (concat "(gnus-group-set-info '" 7557 (concat "(gnus-group-set-info '"
@@ -7174,9 +7664,8 @@ latter case, they will be copied into the relevant groups."
7174 (error "Can't read %s" file)) 7664 (error "Can't read %s" file))
7175 (save-excursion 7665 (save-excursion
7176 (set-buffer (gnus-get-buffer-create " *import file*")) 7666 (set-buffer (gnus-get-buffer-create " *import file*"))
7177 (buffer-disable-undo (current-buffer))
7178 (erase-buffer) 7667 (erase-buffer)
7179 (insert-file-contents file) 7668 (nnheader-insert-file-contents file)
7180 (goto-char (point-min)) 7669 (goto-char (point-min))
7181 (unless (nnheader-article-p) 7670 (unless (nnheader-article-p)
7182 ;; This doesn't look like an article, so we fudge some headers. 7671 ;; This doesn't look like an article, so we fudge some headers.
@@ -7184,10 +7673,7 @@ latter case, they will be copied into the relevant groups."
7184 lines (count-lines (point-min) (point-max))) 7673 lines (count-lines (point-min) (point-max)))
7185 (insert "From: " (read-string "From: ") "\n" 7674 (insert "From: " (read-string "From: ") "\n"
7186 "Subject: " (read-string "Subject: ") "\n" 7675 "Subject: " (read-string "Subject: ") "\n"
7187 "Date: " (timezone-make-date-arpa-standard 7676 "Date: " (message-make-date (nth 5 atts))
7188 (current-time-string (nth 5 atts))
7189 (current-time-zone now)
7190 (current-time-zone now))
7191 "\n" 7677 "\n"
7192 "Message-ID: " (message-make-message-id) "\n" 7678 "Message-ID: " (message-make-message-id) "\n"
7193 "Lines: " (int-to-string lines) "\n" 7679 "Lines: " (int-to-string lines) "\n"
@@ -7196,12 +7682,11 @@ latter case, they will be copied into the relevant groups."
7196 (kill-buffer (current-buffer))))) 7682 (kill-buffer (current-buffer)))))
7197 7683
7198(defun gnus-summary-article-posted-p () 7684(defun gnus-summary-article-posted-p ()
7199 "Say whether the current (mail) article is available from `gnus-select-method' as well. 7685 "Say whether the current (mail) article is available from news as well.
7200This will be the case if the article has both been mailed and posted." 7686This will be the case if the article has both been mailed and posted."
7201 (interactive) 7687 (interactive)
7202 (let ((id (mail-header-references (gnus-summary-article-header))) 7688 (let ((id (mail-header-references (gnus-summary-article-header)))
7203 (gnus-override-method 7689 (gnus-override-method (car (gnus-refer-article-methods))))
7204 (or gnus-refer-article-method gnus-select-method)))
7205 (if (gnus-request-head id "") 7690 (if (gnus-request-head id "")
7206 (gnus-message 2 "The current message was found on %s" 7691 (gnus-message 2 "The current message was found on %s"
7207 gnus-override-method) 7692 gnus-override-method)
@@ -7229,11 +7714,16 @@ This will be the case if the article has both been mailed and posted."
7229 (expiry-wait (if now 'immediate 7714 (expiry-wait (if now 'immediate
7230 (gnus-group-find-parameter 7715 (gnus-group-find-parameter
7231 gnus-newsgroup-name 'expiry-wait))) 7716 gnus-newsgroup-name 'expiry-wait)))
7717 (nnmail-expiry-target
7718 (or (gnus-group-find-parameter gnus-newsgroup-name 'expiry-target)
7719 nnmail-expiry-target))
7232 es) 7720 es)
7233 (when expirable 7721 (when expirable
7234 ;; There are expirable articles in this group, so we run them 7722 ;; There are expirable articles in this group, so we run them
7235 ;; through the expiry process. 7723 ;; through the expiry process.
7236 (gnus-message 6 "Expiring articles...") 7724 (gnus-message 6 "Expiring articles...")
7725 (unless (gnus-check-group gnus-newsgroup-name)
7726 (error "Can't open server for %s" gnus-newsgroup-name))
7237 ;; The list of articles that weren't expired is returned. 7727 ;; The list of articles that weren't expired is returned.
7238 (save-excursion 7728 (save-excursion
7239 (if expiry-wait 7729 (if expiry-wait
@@ -7281,6 +7771,8 @@ delete these instead."
7281 (unless (gnus-check-backend-function 'request-expire-articles 7771 (unless (gnus-check-backend-function 'request-expire-articles
7282 gnus-newsgroup-name) 7772 gnus-newsgroup-name)
7283 (error "The current newsgroup does not support article deletion")) 7773 (error "The current newsgroup does not support article deletion"))
7774 (unless (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
7775 (error "Couldn't open server"))
7284 ;; Compute the list of articles to delete. 7776 ;; Compute the list of articles to delete.
7285 (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<)) 7777 (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<))
7286 not-deleted) 7778 not-deleted)
@@ -7307,28 +7799,63 @@ delete these instead."
7307 (gnus-set-mode-line 'summary) 7799 (gnus-set-mode-line 'summary)
7308 not-deleted)) 7800 not-deleted))
7309 7801
7310(defun gnus-summary-edit-article (&optional force) 7802(defun gnus-summary-edit-article (&optional arg)
7311 "Edit the current article. 7803 "Edit the current article.
7312This will have permanent effect only in mail groups. 7804This will have permanent effect only in mail groups.
7313If FORCE is non-nil, allow editing of articles even in read-only 7805If ARG is nil, edit the decoded articles.
7806If ARG is 1, edit the raw articles.
7807If ARG is 2, edit the raw articles even in read-only groups.
7808Otherwise, allow editing of articles even in read-only
7314groups." 7809groups."
7315 (interactive "P") 7810 (interactive "P")
7316 (save-excursion 7811 (let (force raw)
7317 (set-buffer gnus-summary-buffer) 7812 (cond
7318 (gnus-set-global-variables) 7813 ((null arg))
7319 (when (and (not force) 7814 ((eq arg 1) (setq raw t))
7320 (gnus-group-read-only-p)) 7815 ((eq arg 2) (setq raw t
7321 (error "The current newsgroup does not support article editing")) 7816 force t))
7322 ;; Select article if needed. 7817 (t (setq force t)))
7323 (unless (eq (gnus-summary-article-number) 7818 (if (and raw (not force) (equal gnus-newsgroup-name "nndraft:drafts"))
7324 gnus-current-article) 7819 (error "Can't edit the raw article in group nndraft:drafts."))
7325 (gnus-summary-select-article t)) 7820 (save-excursion
7326 (gnus-article-date-original) 7821 (set-buffer gnus-summary-buffer)
7327 (gnus-article-edit-article 7822 (let ((mail-parse-charset gnus-newsgroup-charset)
7328 `(lambda (no-highlight) 7823 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets))
7329 (gnus-summary-edit-article-done 7824 (gnus-set-global-variables)
7330 ,(or (mail-header-references gnus-current-headers) "") 7825 (when (and (not force)
7331 ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))) 7826 (gnus-group-read-only-p))
7827 (error "The current newsgroup does not support article editing"))
7828 (gnus-summary-show-article t)
7829 (when (and (not raw) (gnus-buffer-live-p gnus-article-buffer))
7830 (with-current-buffer gnus-article-buffer
7831 (mm-enable-multibyte)))
7832 (if (equal gnus-newsgroup-name "nndraft:drafts")
7833 (setq raw t))
7834 (gnus-article-edit-article
7835 (if raw 'ignore
7836 #'(lambda ()
7837 (let ((mbl mml-buffer-list))
7838 (setq mml-buffer-list nil)
7839 (mime-to-mml)
7840 (make-local-hook 'kill-buffer-hook)
7841 (let ((mml-buffer-list mml-buffer-list))
7842 (setq mml-buffer-list mbl)
7843 (make-local-variable 'mml-buffer-list))
7844 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))))
7845 `(lambda (no-highlight)
7846 (let ((mail-parse-charset ',gnus-newsgroup-charset)
7847 (mail-parse-ignored-charsets
7848 ',gnus-newsgroup-ignored-charsets))
7849 ,(if (not raw) '(progn
7850 (mml-to-mime)
7851 (mml-destroy-buffers)
7852 (remove-hook 'kill-buffer-hook
7853 'mml-destroy-buffers t)
7854 (kill-local-variable 'mml-buffer-list)))
7855 (gnus-summary-edit-article-done
7856 ,(or (mail-header-references gnus-current-headers) "")
7857 ,(gnus-group-read-only-p)
7858 ,gnus-summary-buffer no-highlight))))))))
7332 7859
7333(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) 7860(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit)
7334 7861
@@ -7338,12 +7865,12 @@ groups."
7338 (interactive) 7865 (interactive)
7339 ;; Replace the article. 7866 ;; Replace the article.
7340 (let ((buf (current-buffer))) 7867 (let ((buf (current-buffer)))
7341 (nnheader-temp-write nil 7868 (with-temp-buffer
7342 (insert-buffer buf) 7869 (insert-buffer-substring buf)
7343 (if (and (not read-only) 7870 (if (and (not read-only)
7344 (not (gnus-request-replace-article 7871 (not (gnus-request-replace-article
7345 (cdr gnus-article-current) (car gnus-article-current) 7872 (cdr gnus-article-current) (car gnus-article-current)
7346 (current-buffer)))) 7873 (current-buffer) t)))
7347 (error "Couldn't replace article") 7874 (error "Couldn't replace article")
7348 ;; Update the summary buffer. 7875 ;; Update the summary buffer.
7349 (if (and references 7876 (if (and references
@@ -7356,7 +7883,7 @@ groups."
7356 (message-narrow-to-head) 7883 (message-narrow-to-head)
7357 (let ((head (buffer-string)) 7884 (let ((head (buffer-string))
7358 header) 7885 header)
7359 (nnheader-temp-write nil 7886 (with-temp-buffer
7360 (insert (format "211 %d Article retrieved.\n" 7887 (insert (format "211 %d Article retrieved.\n"
7361 (cdr gnus-article-current))) 7888 (cdr gnus-article-current)))
7362 (insert head) 7889 (insert head)
@@ -7381,7 +7908,8 @@ groups."
7381 (unless no-highlight 7908 (unless no-highlight
7382 (save-excursion 7909 (save-excursion
7383 (set-buffer gnus-article-buffer) 7910 (set-buffer gnus-article-buffer)
7384 (gnus-run-hooks 'gnus-article-display-hook) 7911 ;;;!!! Fix this -- article should be rehighlighted.
7912 ;;;(gnus-run-hooks 'gnus-article-display-hook)
7385 (set-buffer gnus-original-article-buffer) 7913 (set-buffer gnus-original-article-buffer)
7386 (gnus-request-article 7914 (gnus-request-article
7387 (cdr gnus-article-current) 7915 (cdr gnus-article-current)
@@ -7544,7 +8072,7 @@ the actual number of articles marked is returned."
7544 "Mark ARTICLE replied and update the summary line." 8072 "Mark ARTICLE replied and update the summary line."
7545 (push article gnus-newsgroup-replied) 8073 (push article gnus-newsgroup-replied)
7546 (let ((buffer-read-only nil)) 8074 (let ((buffer-read-only nil))
7547 (when (gnus-summary-goto-subject article) 8075 (when (gnus-summary-goto-subject article nil t)
7548 (gnus-summary-update-secondary-mark article)))) 8076 (gnus-summary-update-secondary-mark article))))
7549 8077
7550(defun gnus-summary-set-bookmark (article) 8078(defun gnus-summary-set-bookmark (article)
@@ -7624,8 +8152,10 @@ the actual number of articles marked is returned."
7624 "Mark N articles as read forwards. 8152 "Mark N articles as read forwards.
7625If N is negative, mark backwards instead. Mark with MARK, ?r by default. 8153If N is negative, mark backwards instead. Mark with MARK, ?r by default.
7626The difference between N and the actual number of articles marked is 8154The difference between N and the actual number of articles marked is
7627returned." 8155returned.
8156Iff NO-EXPIRE, auto-expiry will be inhibited."
7628 (interactive "p") 8157 (interactive "p")
8158 (gnus-summary-show-thread)
7629 (let ((backward (< n 0)) 8159 (let ((backward (< n 0))
7630 (gnus-summary-goto-unread 8160 (gnus-summary-goto-unread
7631 (and gnus-summary-goto-unread 8161 (and gnus-summary-goto-unread
@@ -7663,11 +8193,7 @@ returned."
7663 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) 8193 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
7664 ;; Check for auto-expiry. 8194 ;; Check for auto-expiry.
7665 (when (and gnus-newsgroup-auto-expire 8195 (when (and gnus-newsgroup-auto-expire
7666 (or (= mark gnus-killed-mark) (= mark gnus-del-mark) 8196 (memq mark gnus-auto-expirable-marks))
7667 (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
7668 (= mark gnus-ancient-mark)
7669 (= mark gnus-read-mark) (= mark gnus-souped-mark)
7670 (= mark gnus-duplicate-mark)))
7671 (setq mark gnus-expirable-mark) 8197 (setq mark gnus-expirable-mark)
7672 ;; Let the backend know about the mark change. 8198 ;; Let the backend know about the mark change.
7673 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) 8199 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
@@ -7706,7 +8232,6 @@ returned."
7706 (save-excursion 8232 (save-excursion
7707 (gnus-cache-possibly-enter-article 8233 (gnus-cache-possibly-enter-article
7708 gnus-newsgroup-name article 8234 gnus-newsgroup-name article
7709 (gnus-summary-article-header article)
7710 (= mark gnus-ticked-mark) 8235 (= mark gnus-ticked-mark)
7711 (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) 8236 (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
7712 8237
@@ -7718,25 +8243,22 @@ returned."
7718 "Mark ARTICLE with MARK. MARK can be any character. 8243 "Mark ARTICLE with MARK. MARK can be any character.
7719Four MARK strings are reserved: `? ' (unread), `?!' (ticked), 8244Four MARK strings are reserved: `? ' (unread), `?!' (ticked),
7720`??' (dormant) and `?E' (expirable). 8245`??' (dormant) and `?E' (expirable).
7721If MARK is nil, then the default character `?D' is used. 8246If MARK is nil, then the default character `?r' is used.
7722If ARTICLE is nil, then the article on the current line will be 8247If ARTICLE is nil, then the article on the current line will be
7723marked." 8248marked.
8249Iff NO-EXPIRE, auto-expiry will be inhibited."
7724 ;; The mark might be a string. 8250 ;; The mark might be a string.
7725 (when (stringp mark) 8251 (when (stringp mark)
7726 (setq mark (aref mark 0))) 8252 (setq mark (aref mark 0)))
7727 ;; If no mark is given, then we check auto-expiring. 8253 ;; If no mark is given, then we check auto-expiring.
7728 (and (not no-expire) 8254 (when (null mark)
7729 gnus-newsgroup-auto-expire 8255 (setq mark gnus-del-mark))
7730 (or (not mark) 8256 (when (and (not no-expire)
7731 (and (gnus-characterp mark) 8257 gnus-newsgroup-auto-expire
7732 (or (= mark gnus-killed-mark) (= mark gnus-del-mark) 8258 (memq mark gnus-auto-expirable-marks))
7733 (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) 8259 (setq mark gnus-expirable-mark))
7734 (= mark gnus-read-mark) (= mark gnus-souped-mark) 8260 (let ((article (or article (gnus-summary-article-number)))
7735 (= mark gnus-duplicate-mark)))) 8261 (old-mark (gnus-summary-article-mark article)))
7736 (setq mark gnus-expirable-mark))
7737 (let* ((mark (or mark gnus-del-mark))
7738 (article (or article (gnus-summary-article-number)))
7739 (old-mark (gnus-summary-article-mark article)))
7740 ;; Allow the backend to change the mark. 8262 ;; Allow the backend to change the mark.
7741 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) 8263 (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark))
7742 (if (eq mark old-mark) 8264 (if (eq mark old-mark)
@@ -7756,7 +8278,6 @@ marked."
7756 (save-excursion 8278 (save-excursion
7757 (gnus-cache-possibly-enter-article 8279 (gnus-cache-possibly-enter-article
7758 gnus-newsgroup-name article 8280 gnus-newsgroup-name article
7759 (gnus-summary-article-header article)
7760 (= mark gnus-ticked-mark) 8281 (= mark gnus-ticked-mark)
7761 (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) 8282 (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
7762 8283
@@ -7788,19 +8309,19 @@ marked."
7788 (let ((forward (cdr (assq type gnus-summary-mark-positions))) 8309 (let ((forward (cdr (assq type gnus-summary-mark-positions)))
7789 (buffer-read-only nil)) 8310 (buffer-read-only nil))
7790 (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) 8311 (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit)
7791 (when (looking-at "\r") 8312 (when forward
7792 (incf forward)) 8313 (when (looking-at "\r")
7793 (when (and forward 8314 (incf forward))
7794 (<= (+ forward (point)) (point-max))) 8315 (when (<= (+ forward (point)) (point-max))
7795 ;; Go to the right position on the line. 8316 ;; Go to the right position on the line.
7796 (goto-char (+ forward (point))) 8317 (goto-char (+ forward (point)))
7797 ;; Replace the old mark with the new mark. 8318 ;; Replace the old mark with the new mark.
7798 (subst-char-in-region (point) (1+ (point)) (following-char) mark) 8319 (subst-char-in-region (point) (1+ (point)) (char-after) mark)
7799 ;; Optionally update the marks by some user rule. 8320 ;; Optionally update the marks by some user rule.
7800 (when (eq type 'unread) 8321 (when (eq type 'unread)
7801 (gnus-data-set-mark 8322 (gnus-data-set-mark
7802 (gnus-data-find (gnus-summary-article-number)) mark) 8323 (gnus-data-find (gnus-summary-article-number)) mark)
7803 (gnus-summary-update-line (eq mark gnus-unread-mark)))))) 8324 (gnus-summary-update-line (eq mark gnus-unread-mark)))))))
7804 8325
7805(defun gnus-mark-article-as-read (article &optional mark) 8326(defun gnus-mark-article-as-read (article &optional mark)
7806 "Enter ARTICLE in the pertinent lists and remove it from others." 8327 "Enter ARTICLE in the pertinent lists and remove it from others."
@@ -7881,14 +8402,15 @@ If N is negative, mark backwards instead.
7881The difference between N and the actual number of articles marked is 8402The difference between N and the actual number of articles marked is
7882returned." 8403returned."
7883 (interactive "p") 8404 (interactive "p")
7884 (gnus-summary-mark-forward n gnus-del-mark t)) 8405 (gnus-summary-mark-forward n gnus-del-mark gnus-inhibit-user-auto-expire))
7885 8406
7886(defun gnus-summary-mark-as-read-backward (n) 8407(defun gnus-summary-mark-as-read-backward (n)
7887 "Mark the N articles as read backwards. 8408 "Mark the N articles as read backwards.
7888The difference between N and the actual number of articles marked is 8409The difference between N and the actual number of articles marked is
7889returned." 8410returned."
7890 (interactive "p") 8411 (interactive "p")
7891 (gnus-summary-mark-forward (- n) gnus-del-mark t)) 8412 (gnus-summary-mark-forward
8413 (- n) gnus-del-mark gnus-inhibit-user-auto-expire))
7892 8414
7893(defun gnus-summary-mark-as-read (&optional article mark) 8415(defun gnus-summary-mark-as-read (&optional article mark)
7894 "Mark current article as read. 8416 "Mark current article as read.
@@ -8069,7 +8591,7 @@ If ALL is non-nil, also mark ticked and dormant articles as read."
8069 (gnus-summary-catchup t quietly)) 8591 (gnus-summary-catchup t quietly))
8070 8592
8071(defun gnus-summary-catchup-and-exit (&optional all quietly) 8593(defun gnus-summary-catchup-and-exit (&optional all quietly)
8072 "Mark all articles not marked as unread in this newsgroup as read, then exit. 8594 "Mark all unread articles in this group as read, then exit.
8073If prefix argument ALL is non-nil, all articles are marked as read." 8595If prefix argument ALL is non-nil, all articles are marked as read."
8074 (interactive "P") 8596 (interactive "P")
8075 (when (gnus-summary-catchup all quietly nil 'fast) 8597 (when (gnus-summary-catchup all quietly nil 'fast)
@@ -8084,7 +8606,6 @@ If prefix argument ALL is non-nil, all articles are marked as read."
8084 (interactive "P") 8606 (interactive "P")
8085 (gnus-summary-catchup-and-exit t quietly)) 8607 (gnus-summary-catchup-and-exit t quietly))
8086 8608
8087;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>.
8088(defun gnus-summary-catchup-and-goto-next-group (&optional all) 8609(defun gnus-summary-catchup-and-goto-next-group (&optional all)
8089 "Mark all articles in this group as read and select the next group. 8610 "Mark all articles in this group as read and select the next group.
8090If given a prefix, mark all articles, unread as well as ticked, as 8611If given a prefix, mark all articles, unread as well as ticked, as
@@ -8092,7 +8613,38 @@ read."
8092 (interactive "P") 8613 (interactive "P")
8093 (save-excursion 8614 (save-excursion
8094 (gnus-summary-catchup all)) 8615 (gnus-summary-catchup all))
8095 (gnus-summary-next-article t nil nil t)) 8616 (gnus-summary-next-group))
8617
8618;;;
8619;;; with article
8620;;;
8621
8622(defmacro gnus-with-article (article &rest forms)
8623 "Select ARTICLE and perform FORMS in the original article buffer.
8624Then replace the article with the result."
8625 `(progn
8626 ;; We don't want the article to be marked as read.
8627 (let (gnus-mark-article-hook)
8628 (gnus-summary-select-article t t nil ,article))
8629 (set-buffer gnus-original-article-buffer)
8630 ,@forms
8631 (if (not (gnus-check-backend-function
8632 'request-replace-article (car gnus-article-current)))
8633 (gnus-message 5 "Read-only group; not replacing")
8634 (unless (gnus-request-replace-article
8635 ,article (car gnus-article-current)
8636 (current-buffer) t)
8637 (error "Couldn't replace article")))
8638 ;; The cache and backlog have to be flushed somewhat.
8639 (when gnus-keep-backlog
8640 (gnus-backlog-remove-article
8641 (car gnus-article-current) (cdr gnus-article-current)))
8642 (when gnus-use-cache
8643 (gnus-cache-update-article
8644 (car gnus-article-current) (cdr gnus-article-current)))))
8645
8646(put 'gnus-with-article 'lisp-indent-function 1)
8647(put 'gnus-with-article 'edebug-form-spec '(form body))
8096 8648
8097;; Thread-based commands. 8649;; Thread-based commands.
8098 8650
@@ -8171,25 +8723,17 @@ is non-nil or the Subject: of both articles are the same."
8171 (gnus-summary-article-header parent-article)))) 8723 (gnus-summary-article-header parent-article))))
8172 (unless (and message-id (not (equal message-id ""))) 8724 (unless (and message-id (not (equal message-id "")))
8173 (error "No message-id in desired parent")) 8725 (error "No message-id in desired parent"))
8174 ;; We don't want the article to be marked as read. 8726 (gnus-with-article current-article
8175 (let (gnus-mark-article-hook) 8727 (save-restriction
8176 (gnus-summary-select-article t t nil current-article))
8177 (set-buffer gnus-original-article-buffer)
8178 (let ((buf (format "%s" (buffer-string))))
8179 (nnheader-temp-write nil
8180 (insert buf)
8181 (goto-char (point-min)) 8728 (goto-char (point-min))
8729 (message-narrow-to-head)
8182 (if (re-search-forward "^References: " nil t) 8730 (if (re-search-forward "^References: " nil t)
8183 (progn 8731 (progn
8184 (re-search-forward "^[^ \t]" nil t) 8732 (re-search-forward "^[^ \t]" nil t)
8185 (forward-line -1) 8733 (forward-line -1)
8186 (end-of-line) 8734 (end-of-line)
8187 (insert " " message-id)) 8735 (insert " " message-id))
8188 (insert "References: " message-id "\n")) 8736 (insert "References: " message-id "\n"))))
8189 (unless (gnus-request-replace-article
8190 current-article (car gnus-article-current)
8191 (current-buffer))
8192 (error "Couldn't replace article"))))
8193 (set-buffer gnus-summary-buffer) 8737 (set-buffer gnus-summary-buffer)
8194 (gnus-summary-unmark-all-processable) 8738 (gnus-summary-unmark-all-processable)
8195 (gnus-summary-update-article current-article) 8739 (gnus-summary-update-article current-article)
@@ -8264,9 +8808,7 @@ Returns nil if no threads were there to be hidden."
8264 (subst-char-in-region start (point) ?\n ?\^M) 8808 (subst-char-in-region start (point) ?\n ?\^M)
8265 (gnus-summary-goto-subject article)) 8809 (gnus-summary-goto-subject article))
8266 (goto-char start) 8810 (goto-char start)
8267 nil) 8811 nil)))))
8268 ;;(gnus-summary-position-point)
8269 ))))
8270 8812
8271(defun gnus-summary-go-to-next-thread (&optional previous) 8813(defun gnus-summary-go-to-next-thread (&optional previous)
8272 "Go to the same level (or less) next thread. 8814 "Go to the same level (or less) next thread.
@@ -8398,14 +8940,14 @@ Argument REVERSE means reverse order."
8398 8940
8399(defun gnus-summary-sort-by-author (&optional reverse) 8941(defun gnus-summary-sort-by-author (&optional reverse)
8400 "Sort the summary buffer by author name alphabetically. 8942 "Sort the summary buffer by author name alphabetically.
8401If case-fold-search is non-nil, case of letters is ignored. 8943If `case-fold-search' is non-nil, case of letters is ignored.
8402Argument REVERSE means reverse order." 8944Argument REVERSE means reverse order."
8403 (interactive "P") 8945 (interactive "P")
8404 (gnus-summary-sort 'author reverse)) 8946 (gnus-summary-sort 'author reverse))
8405 8947
8406(defun gnus-summary-sort-by-subject (&optional reverse) 8948(defun gnus-summary-sort-by-subject (&optional reverse)
8407 "Sort the summary buffer by subject alphabetically. `Re:'s are ignored. 8949 "Sort the summary buffer by subject alphabetically. `Re:'s are ignored.
8408If case-fold-search is non-nil, case of letters is ignored. 8950If `case-fold-search' is non-nil, case of letters is ignored.
8409Argument REVERSE means reverse order." 8951Argument REVERSE means reverse order."
8410 (interactive "P") 8952 (interactive "P")
8411 (gnus-summary-sort 'subject reverse)) 8953 (gnus-summary-sort 'subject reverse))
@@ -8423,27 +8965,33 @@ Argument REVERSE means reverse order."
8423 (gnus-summary-sort 'score reverse)) 8965 (gnus-summary-sort 'score reverse))
8424 8966
8425(defun gnus-summary-sort-by-lines (&optional reverse) 8967(defun gnus-summary-sort-by-lines (&optional reverse)
8426 "Sort the summary buffer by article length. 8968 "Sort the summary buffer by the number of lines.
8427Argument REVERSE means reverse order." 8969Argument REVERSE means reverse order."
8428 (interactive "P") 8970 (interactive "P")
8429 (gnus-summary-sort 'lines reverse)) 8971 (gnus-summary-sort 'lines reverse))
8430 8972
8973(defun gnus-summary-sort-by-chars (&optional reverse)
8974 "Sort the summary buffer by article length.
8975Argument REVERSE means reverse order."
8976 (interactive "P")
8977 (gnus-summary-sort 'chars reverse))
8978
8431(defun gnus-summary-sort (predicate reverse) 8979(defun gnus-summary-sort (predicate reverse)
8432 "Sort summary buffer by PREDICATE. REVERSE means reverse order." 8980 "Sort summary buffer by PREDICATE. REVERSE means reverse order."
8433 (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) 8981 (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate)))
8434 (article (intern (format "gnus-article-sort-by-%s" predicate))) 8982 (article (intern (format "gnus-article-sort-by-%s" predicate)))
8435 (gnus-thread-sort-functions 8983 (gnus-thread-sort-functions
8436 (list 8984 (if (not reverse)
8437 (if (not reverse) 8985 thread
8438 thread 8986 `(lambda (t1 t2)
8439 `(lambda (t1 t2) 8987 (,thread t2 t1))))
8440 (,thread t2 t1))))) 8988 (gnus-sort-gathered-threads-function
8989 gnus-thread-sort-functions)
8441 (gnus-article-sort-functions 8990 (gnus-article-sort-functions
8442 (list 8991 (if (not reverse)
8443 (if (not reverse) 8992 article
8444 article 8993 `(lambda (t1 t2)
8445 `(lambda (t1 t2) 8994 (,article t2 t1))))
8446 (,article t2 t1)))))
8447 (buffer-read-only) 8995 (buffer-read-only)
8448 (gnus-summary-prepare-hook nil)) 8996 (gnus-summary-prepare-hook nil))
8449 ;; We do the sorting by regenerating the threads. 8997 ;; We do the sorting by regenerating the threads.
@@ -8466,10 +9014,9 @@ The variable `gnus-default-article-saver' specifies the saver function."
8466 (save-buffer (save-excursion 9014 (save-buffer (save-excursion
8467 (nnheader-set-temp-buffer " *Gnus Save*"))) 9015 (nnheader-set-temp-buffer " *Gnus Save*")))
8468 (num (length articles)) 9016 (num (length articles))
8469 header article file) 9017 header file)
8470 (while articles 9018 (dolist (article articles)
8471 (setq header (gnus-summary-article-header 9019 (setq header (gnus-summary-article-header article))
8472 (setq article (pop articles))))
8473 (if (not (vectorp header)) 9020 (if (not (vectorp header))
8474 ;; This is a pseudo-article. 9021 ;; This is a pseudo-article.
8475 (if (assq 'name header) 9022 (if (assq 'name header)
@@ -8599,16 +9146,14 @@ save those articles instead."
8599 split-name)) 9146 split-name))
8600 ((consp result) 9147 ((consp result)
8601 (setq split-name (append result split-name))))))))) 9148 (setq split-name (append result split-name)))))))))
8602 split-name)) 9149 (nreverse split-name)))
8603 9150
8604(defun gnus-valid-move-group-p (group) 9151(defun gnus-valid-move-group-p (group)
8605 (and (boundp group) 9152 (and (boundp group)
8606 (symbol-name group) 9153 (symbol-name group)
8607 (memq 'respool 9154 (symbol-value group)
8608 (assoc (symbol-name 9155 (gnus-get-function (gnus-find-method-for-group
8609 (car (gnus-find-method-for-group 9156 (symbol-name group)) 'request-accept-article t)))
8610 (symbol-name group))))
8611 gnus-valid-select-methods))))
8612 9157
8613(defun gnus-read-move-group-name (prompt default articles prefix) 9158(defun gnus-read-move-group-name (prompt default articles prefix)
8614 "Read a group name." 9159 "Read a group name."
@@ -8639,7 +9184,8 @@ save those articles instead."
8639 (mapcar (lambda (el) (list el)) 9184 (mapcar (lambda (el) (list el))
8640 (nreverse split-name)) 9185 (nreverse split-name))
8641 nil nil nil 9186 nil nil nil
8642 'gnus-group-history))))) 9187 'gnus-group-history))))
9188 (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))))
8643 (when to-newsgroup 9189 (when to-newsgroup
8644 (if (or (string= to-newsgroup "") 9190 (if (or (string= to-newsgroup "")
8645 (string= to-newsgroup prefix)) 9191 (string= to-newsgroup prefix))
@@ -8647,18 +9193,62 @@ save those articles instead."
8647 (unless to-newsgroup 9193 (unless to-newsgroup
8648 (error "No group name entered")) 9194 (error "No group name entered"))
8649 (or (gnus-active to-newsgroup) 9195 (or (gnus-active to-newsgroup)
8650 (gnus-activate-group to-newsgroup) 9196 (gnus-activate-group to-newsgroup nil nil to-method)
8651 (if (gnus-y-or-n-p (format "No such group: %s. Create it? " 9197 (if (gnus-y-or-n-p (format "No such group: %s. Create it? "
8652 to-newsgroup)) 9198 to-newsgroup))
8653 (or (and (gnus-request-create-group 9199 (or (and (gnus-request-create-group to-newsgroup to-method)
8654 to-newsgroup (gnus-group-name-to-method to-newsgroup)) 9200 (gnus-activate-group
8655 (gnus-activate-group to-newsgroup nil nil 9201 to-newsgroup nil nil to-method)
8656 (gnus-group-name-to-method 9202 (gnus-subscribe-group to-newsgroup))
8657 to-newsgroup)))
8658 (error "Couldn't create group %s" to-newsgroup))) 9203 (error "Couldn't create group %s" to-newsgroup)))
8659 (error "No such group: %s" to-newsgroup))) 9204 (error "No such group: %s" to-newsgroup)))
8660 to-newsgroup)) 9205 to-newsgroup))
8661 9206
9207(defun gnus-summary-save-parts (type dir n &optional reverse)
9208 "Save parts matching TYPE to DIR.
9209If REVERSE, save parts that do not match TYPE."
9210 (interactive
9211 (list (read-string "Save parts of type: "
9212 (or (car gnus-summary-save-parts-type-history)
9213 gnus-summary-save-parts-default-mime)
9214 'gnus-summary-save-parts-type-history)
9215 (setq gnus-summary-save-parts-last-directory
9216 (read-file-name "Save to directory: "
9217 gnus-summary-save-parts-last-directory
9218 nil t))
9219 current-prefix-arg))
9220 (gnus-summary-iterate n
9221 (let ((gnus-display-mime-function nil)
9222 (gnus-inhibit-treatment t))
9223 (gnus-summary-select-article))
9224 (save-excursion
9225 (set-buffer gnus-article-buffer)
9226 (let ((handles (or gnus-article-mime-handles
9227 (mm-dissect-buffer) (mm-uu-dissect))))
9228 (when handles
9229 (gnus-summary-save-parts-1 type dir handles reverse)
9230 (unless gnus-article-mime-handles ;; Don't destroy this case.
9231 (mm-destroy-parts handles)))))))
9232
9233(defun gnus-summary-save-parts-1 (type dir handle reverse)
9234 (if (stringp (car handle))
9235 (mapcar (lambda (h) (gnus-summary-save-parts-1 type dir h reverse))
9236 (cdr handle))
9237 (when (if reverse
9238 (not (string-match type (mm-handle-media-type handle)))
9239 (string-match type (mm-handle-media-type handle)))
9240 (let ((file (expand-file-name
9241 (file-name-nondirectory
9242 (or
9243 (mail-content-type-get
9244 (mm-handle-disposition handle) 'filename)
9245 (concat gnus-newsgroup-name
9246 "." (number-to-string
9247 (cdr gnus-article-current)))))
9248 dir)))
9249 (unless (file-exists-p file)
9250 (mm-save-part-to-file handle file))))))
9251
8662;; Summary extract commands 9252;; Summary extract commands
8663 9253
8664(defun gnus-summary-insert-pseudos (pslist &optional not-view) 9254(defun gnus-summary-insert-pseudos (pslist &optional not-view)
@@ -8694,7 +9284,7 @@ save those articles instead."
8694 (lambda (f) 9284 (lambda (f)
8695 (if (equal f " ") 9285 (if (equal f " ")
8696 f 9286 f
8697 (gnus-quote-arg-for-sh-or-csh f))) 9287 (mm-quote-arg f)))
8698 files " "))))) 9288 files " ")))))
8699 (setq ps (cdr ps))))) 9289 (setq ps (cdr ps)))))
8700 (if (and gnus-view-pseudos (not not-view)) 9290 (if (and gnus-view-pseudos (not not-view))
@@ -8771,8 +9361,10 @@ save those articles instead."
8771 "Read the headers of article ID and enter them into the Gnus system." 9361 "Read the headers of article ID and enter them into the Gnus system."
8772 (let ((group gnus-newsgroup-name) 9362 (let ((group gnus-newsgroup-name)
8773 (gnus-override-method 9363 (gnus-override-method
8774 (and (gnus-news-group-p gnus-newsgroup-name) 9364 (or
8775 gnus-refer-article-method)) 9365 gnus-override-method
9366 (and (gnus-news-group-p gnus-newsgroup-name)
9367 (car (gnus-refer-article-methods)))))
8776 where) 9368 where)
8777 ;; First we check to see whether the header in question is already 9369 ;; First we check to see whether the header in question is already
8778 ;; fetched. 9370 ;; fetched.
@@ -8846,8 +9438,8 @@ save those articles instead."
8846;;; 9438;;;
8847 9439
8848(defun gnus-highlight-selected-summary () 9440(defun gnus-highlight-selected-summary ()
9441 "Highlight selected article in summary buffer."
8849 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. 9442 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
8850 ;; Highlight selected article in summary buffer
8851 (when gnus-summary-selected-face 9443 (when gnus-summary-selected-face
8852 (save-excursion 9444 (save-excursion
8853 (let* ((beg (progn (beginning-of-line) (point))) 9445 (let* ((beg (progn (beginning-of-line) (point)))
@@ -8938,19 +9530,38 @@ save those articles instead."
8938 (setq unread (cdr unread))) 9530 (setq unread (cdr unread)))
8939 (when (<= prev (cdr active)) 9531 (when (<= prev (cdr active))
8940 (push (cons prev (cdr active)) read)) 9532 (push (cons prev (cdr active)) read))
9533 (setq read (if (> (length read) 1) (nreverse read) read))
8941 (if compute 9534 (if compute
8942 (if (> (length read) 1) (nreverse read) read) 9535 read
8943 (save-excursion 9536 (save-excursion
8944 (set-buffer gnus-group-buffer) 9537 (let (setmarkundo)
8945 (gnus-undo-register 9538 ;; Propagate the read marks to the backend.
8946 `(progn 9539 (when (gnus-check-backend-function 'request-set-mark group)
8947 (gnus-info-set-marks ',info ',(gnus-info-marks info) t) 9540 (let ((del (gnus-remove-from-range (gnus-info-read info) read))
8948 (gnus-info-set-read ',info ',(gnus-info-read info)) 9541 (add (gnus-remove-from-range read (gnus-info-read info))))
8949 (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) 9542 (when (or add del)
8950 (gnus-group-update-group ,group t)))) 9543 (unless (gnus-check-group group)
9544 (error "Can't open server for %s" group))
9545 (gnus-request-set-mark
9546 group (delq nil (list (if add (list add 'add '(read)))
9547 (if del (list del 'del '(read))))))
9548 (setq setmarkundo
9549 `(gnus-request-set-mark
9550 ,group
9551 ',(delq nil (list
9552 (if del (list del 'add '(read)))
9553 (if add (list add 'del '(read))))))))))
9554 (set-buffer gnus-group-buffer)
9555 (gnus-undo-register
9556 `(progn
9557 (gnus-info-set-marks ',info ',(gnus-info-marks info) t)
9558 (gnus-info-set-read ',info ',(gnus-info-read info))
9559 (gnus-get-unread-articles-in-group ',info
9560 (gnus-active ,group))
9561 (gnus-group-update-group ,group t)
9562 ,setmarkundo))))
8951 ;; Enter this list into the group info. 9563 ;; Enter this list into the group info.
8952 (gnus-info-set-read 9564 (gnus-info-set-read info read)
8953 info (if (> (length read) 1) (nreverse read) read))
8954 ;; Set the number of unread articles in gnus-newsrc-hashtb. 9565 ;; Set the number of unread articles in gnus-newsrc-hashtb.
8955 (gnus-get-unread-articles-in-group info (gnus-active group)) 9566 (gnus-get-unread-articles-in-group info (gnus-active group))
8956 t)))) 9567 t))))
@@ -8983,6 +9594,165 @@ save those articles instead."
8983 (gnus-summary-exit)) 9594 (gnus-summary-exit))
8984 buffers))))) 9595 buffers)))))
8985 9596
9597(defun gnus-summary-setup-default-charset ()
9598 "Setup newsgroup default charset."
9599 (if (equal gnus-newsgroup-name "nndraft:drafts")
9600 (setq gnus-newsgroup-charset nil)
9601 (let* ((name (and gnus-newsgroup-name
9602 (gnus-group-real-name gnus-newsgroup-name)))
9603 (ignored-charsets
9604 (or gnus-newsgroup-ephemeral-ignored-charsets
9605 (append
9606 (and gnus-newsgroup-name
9607 (or (gnus-group-find-parameter gnus-newsgroup-name
9608 'ignored-charsets t)
9609 (let ((alist gnus-group-ignored-charsets-alist)
9610 elem (charsets nil))
9611 (while (setq elem (pop alist))
9612 (when (and name
9613 (string-match (car elem) name))
9614 (setq alist nil
9615 charsets (cdr elem))))
9616 charsets)))
9617 gnus-newsgroup-ignored-charsets))))
9618 (setq gnus-newsgroup-charset
9619 (or gnus-newsgroup-ephemeral-charset
9620 (and gnus-newsgroup-name
9621 (or (gnus-group-find-parameter gnus-newsgroup-name 'charset)
9622 (let ((alist gnus-group-charset-alist)
9623 elem charset)
9624 (while (setq elem (pop alist))
9625 (when (and name
9626 (string-match (car elem) name))
9627 (setq alist nil
9628 charset (cadr elem))))
9629 charset)))
9630 gnus-default-charset))
9631 (set (make-local-variable 'gnus-newsgroup-ignored-charsets)
9632 ignored-charsets))))
9633
9634;;;
9635;;; Mime Commands
9636;;;
9637
9638(defun gnus-summary-display-buttonized (&optional show-all-parts)
9639 "Display the current article buffer fully MIME-buttonized.
9640If SHOW-ALL-PARTS (the prefix) is non-nil, all multipart/* parts are
9641treated as multipart/mixed."
9642 (interactive "P")
9643 (require 'gnus-art)
9644 (let ((gnus-unbuttonized-mime-types nil)
9645 (gnus-mime-display-multipart-as-mixed show-all-parts))
9646 (gnus-summary-show-article)))
9647
9648(defun gnus-summary-repair-multipart (article)
9649 "Add a Content-Type header to a multipart article without one."
9650 (interactive (list (gnus-summary-article-number)))
9651 (gnus-with-article article
9652 (message-narrow-to-head)
9653 (goto-char (point-max))
9654 (widen)
9655 (when (search-forward "\n--" nil t)
9656 (let ((separator (buffer-substring (point) (gnus-point-at-eol))))
9657 (message-narrow-to-head)
9658 (message-remove-header "Mime-Version")
9659 (message-remove-header "Content-Type")
9660 (goto-char (point-max))
9661 (insert (format "Content-Type: multipart/mixed; boundary=\"%s\"\n"
9662 separator))
9663 (insert "Mime-Version: 1.0\n")
9664 (widen))))
9665 (let (gnus-mark-article-hook)
9666 (gnus-summary-select-article t t nil article)))
9667
9668(defun gnus-summary-toggle-display-buttonized ()
9669 "Toggle the buttonizing of the article buffer."
9670 (interactive)
9671 (require 'gnus-art)
9672 (if (setq gnus-inhibit-mime-unbuttonizing
9673 (not gnus-inhibit-mime-unbuttonizing))
9674 (let ((gnus-unbuttonized-mime-types nil))
9675 (gnus-summary-show-article))
9676 (gnus-summary-show-article)))
9677
9678;;;
9679;;; Generic summary marking commands
9680;;;
9681
9682(defvar gnus-summary-marking-alist
9683 '((read gnus-del-mark "d")
9684 (unread gnus-unread-mark "u")
9685 (ticked gnus-ticked-mark "!")
9686 (dormant gnus-dormant-mark "?")
9687 (expirable gnus-expirable-mark "e"))
9688 "An alist of names/marks/keystrokes.")
9689
9690(defvar gnus-summary-generic-mark-map (make-sparse-keymap))
9691(defvar gnus-summary-mark-map)
9692
9693(defun gnus-summary-make-all-marking-commands ()
9694 (define-key gnus-summary-mark-map "M" gnus-summary-generic-mark-map)
9695 (dolist (elem gnus-summary-marking-alist)
9696 (apply 'gnus-summary-make-marking-command elem)))
9697
9698(defun gnus-summary-make-marking-command (name mark keystroke)
9699 (let ((map (make-sparse-keymap)))
9700 (define-key gnus-summary-generic-mark-map keystroke map)
9701 (dolist (lway `((next "next" next nil "n")
9702 (next-unread "next unread" next t "N")
9703 (prev "previous" prev nil "p")
9704 (prev-unread "previous unread" prev t "P")
9705 (nomove "" nil nil ,keystroke)))
9706 (let ((func (gnus-summary-make-marking-command-1
9707 mark (car lway) lway name)))
9708 (setq func (eval func))
9709 (define-key map (nth 4 lway) func)))))
9710
9711(defun gnus-summary-make-marking-command-1 (mark way lway name)
9712 `(defun ,(intern
9713 (format "gnus-summary-put-mark-as-%s%s"
9714 name (if (eq way 'nomove)
9715 ""
9716 (concat "-" (symbol-name way)))))
9717 (n)
9718 ,(format
9719 "Mark the current article as %s%s.
9720If N, the prefix, then repeat N times.
9721If N is negative, move in reverse order.
9722The difference between N and the actual number of articles marked is
9723returned."
9724 name (cadr lway))
9725 (interactive "p")
9726 (gnus-summary-generic-mark n ,mark ',(nth 2 lway) ,(nth 3 lway))))
9727
9728(defun gnus-summary-generic-mark (n mark move unread)
9729 "Mark N articles with MARK."
9730 (unless (eq major-mode 'gnus-summary-mode)
9731 (error "This command can only be used in the summary buffer"))
9732 (gnus-summary-show-thread)
9733 (let ((nummove
9734 (cond
9735 ((eq move 'next) 1)
9736 ((eq move 'prev) -1)
9737 (t 0))))
9738 (if (zerop nummove)
9739 (setq n 1)
9740 (when (< n 0)
9741 (setq n (abs n)
9742 nummove (* -1 nummove))))
9743 (while (and (> n 0)
9744 (gnus-summary-mark-article nil mark)
9745 (zerop (gnus-summary-next-subject nummove unread t)))
9746 (setq n (1- n)))
9747 (when (/= 0 n)
9748 (gnus-message 7 "No more %sarticles" (if mark "" "unread ")))
9749 (gnus-summary-recenter)
9750 (gnus-summary-position-point)
9751 (gnus-set-mode-line 'summary)
9752 n))
9753
9754(gnus-summary-make-all-marking-commands)
9755
8986(gnus-ems-redefine) 9756(gnus-ems-redefine)
8987 9757
8988(provide 'gnus-sum) 9758(provide 'gnus-sum)
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 26b91f8072f..35324395bb7 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -1,5 +1,6 @@
1;;; gnus-topic.el --- a folding minor mode for Gnus group buffers 1;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. 2;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3;; Free Software Foundation, Inc.
3 4
4;; Author: Ilja Weis <kult@uni-paderborn.de> 5;; Author: Ilja Weis <kult@uni-paderborn.de>
5;; Lars Magne Ingebrigtsen <larsi@gnus.org> 6;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -28,8 +29,6 @@
28 29
29(eval-when-compile (require 'cl)) 30(eval-when-compile (require 'cl))
30 31
31(eval-when-compile (require 'cl))
32
33(require 'gnus) 32(require 'gnus)
34(require 'gnus-group) 33(require 'gnus-group)
35(require 'gnus-start) 34(require 'gnus-start)
@@ -151,11 +150,20 @@ with some simple extensions.
151 (gnus-group-topic group)))) 150 (gnus-group-topic group))))
152 151
153(defun gnus-topic-goto-topic (topic) 152(defun gnus-topic-goto-topic (topic)
154 "Go to TOPIC."
155 (when topic 153 (when topic
156 (gnus-goto-char (text-property-any (point-min) (point-max) 154 (gnus-goto-char (text-property-any (point-min) (point-max)
157 'gnus-topic (intern topic))))) 155 'gnus-topic (intern topic)))))
158 156
157(defun gnus-topic-jump-to-topic (topic)
158 "Go to TOPIC."
159 (interactive
160 (list (completing-read "Go to topic: "
161 (mapcar 'list (gnus-topic-list))
162 nil t)))
163 (dolist (topic (gnus-current-topics topic))
164 (gnus-topic-fold t))
165 (gnus-topic-goto-topic topic))
166
159(defun gnus-current-topic () 167(defun gnus-current-topic ()
160 "Return the name of the current topic." 168 "Return the name of the current topic."
161 (let ((result 169 (let ((result
@@ -184,8 +192,9 @@ If TOPIC, start with that topic."
184 (beginning-of-line) 192 (beginning-of-line)
185 (get-text-property (point) 'gnus-active))) 193 (get-text-property (point) 'gnus-active)))
186 194
187(defun gnus-topic-find-groups (topic &optional level all lowest) 195(defun gnus-topic-find-groups (topic &optional level all lowest recursive)
188 "Return entries for all visible groups in TOPIC." 196 "Return entries for all visible groups in TOPIC.
197If RECURSIVE is t, return groups in its subtopics too."
189 (let ((groups (cdr (assoc topic gnus-topic-alist))) 198 (let ((groups (cdr (assoc topic gnus-topic-alist)))
190 info clevel unread group params visible-groups entry active) 199 info clevel unread group params visible-groups entry active)
191 (setq lowest (or lowest 1)) 200 (setq lowest (or lowest 1))
@@ -205,16 +214,17 @@ If TOPIC, start with that topic."
205 (if (member group gnus-zombie-list) 214 (if (member group gnus-zombie-list)
206 gnus-level-zombie gnus-level-killed)))) 215 gnus-level-zombie gnus-level-killed))))
207 (and 216 (and
208 unread ; nil means that the group is dead. 217 info ; nil means that the group is dead.
209 (<= clevel level) 218 (<= clevel level)
210 (>= clevel lowest) ; Is inside the level we want. 219 (>= clevel lowest) ; Is inside the level we want.
211 (or all 220 (or all
212 (if (eq unread t) 221 (if (or (eq unread t)
222 (eq unread nil))
213 gnus-group-list-inactive-groups 223 gnus-group-list-inactive-groups
214 (> unread 0)) 224 (> unread 0))
215 (and gnus-list-groups-with-ticked-articles 225 (and gnus-list-groups-with-ticked-articles
216 (cdr (assq 'tick (gnus-info-marks info)))) 226 (cdr (assq 'tick (gnus-info-marks info))))
217 ; Has right readedness. 227 ;; Has right readedness.
218 ;; Check for permanent visibility. 228 ;; Check for permanent visibility.
219 (and gnus-permanently-visible-groups 229 (and gnus-permanently-visible-groups
220 (string-match gnus-permanently-visible-groups group)) 230 (string-match gnus-permanently-visible-groups group))
@@ -222,7 +232,18 @@ If TOPIC, start with that topic."
222 (cdr (assq 'visible params))) 232 (cdr (assq 'visible params)))
223 ;; Add this group to the list of visible groups. 233 ;; Add this group to the list of visible groups.
224 (push (or entry group) visible-groups))) 234 (push (or entry group) visible-groups)))
225 (nreverse visible-groups))) 235 (setq visible-groups (nreverse visible-groups))
236 (when recursive
237 (if (eq recursive t)
238 (setq recursive (cdr (gnus-topic-find-topology topic))))
239 (mapcar (lambda (topic-topology)
240 (setq visible-groups
241 (nconc visible-groups
242 (gnus-topic-find-groups
243 (caar topic-topology)
244 level all lowest topic-topology))))
245 (cdr recursive)))
246 visible-groups))
226 247
227(defun gnus-topic-previous-topic (topic) 248(defun gnus-topic-previous-topic (topic)
228 "Return the previous topic on the same level as TOPIC." 249 "Return the previous topic on the same level as TOPIC."
@@ -363,7 +384,8 @@ If TOPIC, start with that topic."
363 384
364;;; Generating group buffers 385;;; Generating group buffers
365 386
366(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) 387(defun gnus-group-prepare-topics (level &optional all lowest
388 regexp list-topic topic-level)
367 "List all newsgroups with unread articles of level LEVEL or lower. 389 "List all newsgroups with unread articles of level LEVEL or lower.
368Use the `gnus-group-topics' to sort the groups. 390Use the `gnus-group-topics' to sort the groups.
369If ALL is non-nil, list groups that have no unread articles. 391If ALL is non-nil, list groups that have no unread articles.
@@ -418,7 +440,7 @@ articles in the topic and its subtopics."
418 (entries (gnus-topic-find-groups 440 (entries (gnus-topic-find-groups
419 (car type) list-level 441 (car type) list-level
420 (or all 442 (or all
421 (cdr (assq 'visible 443 (cdr (assq 'visible
422 (gnus-topic-hierarchical-parameters 444 (gnus-topic-hierarchical-parameters
423 (car type))))) 445 (car type)))))
424 lowest)) 446 lowest))
@@ -446,7 +468,8 @@ articles in the topic and its subtopics."
446 (if (stringp entry) 468 (if (stringp entry)
447 ;; Dead groups. 469 ;; Dead groups.
448 (gnus-group-insert-group-line 470 (gnus-group-insert-group-line
449 entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed) 471 entry (if (member entry gnus-zombie-list)
472 gnus-level-zombie gnus-level-killed)
450 nil (- (1+ (cdr (setq active (gnus-active entry)))) 473 nil (- (1+ (cdr (setq active (gnus-active entry))))
451 (car active)) 474 (car active))
452 nil) 475 nil)
@@ -494,7 +517,7 @@ articles in the topic and its subtopics."
494 (let ((data (cadr (gnus-topic-find-topology topic)))) 517 (let ((data (cadr (gnus-topic-find-topology topic))))
495 (setcdr data 518 (setcdr data
496 (list (if insert 'visible 'invisible) 519 (list (if insert 'visible 'invisible)
497 (if hide 'hide nil) 520 (caddr data)
498 (cadddr data)))) 521 (cadddr data))))
499 (if total-remove 522 (if total-remove
500 (setq gnus-topic-alist 523 (setq gnus-topic-alist
@@ -507,9 +530,9 @@ articles in the topic and its subtopics."
507 (car gnus-group-list-mode) (cdr gnus-group-list-mode) 530 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
508 nil nil topic level)) 531 nil nil topic level))
509 532
510(defun gnus-topic-fold (&optional insert) 533(defun gnus-topic-fold (&optional insert topic)
511 "Remove/insert the current topic." 534 "Remove/insert the current topic."
512 (let ((topic (gnus-group-topic-name))) 535 (let ((topic (or topic (gnus-group-topic-name))))
513 (when topic 536 (when topic
514 (save-excursion 537 (save-excursion
515 (if (not (gnus-group-active-topic-p)) 538 (if (not (gnus-group-active-topic-p))
@@ -533,15 +556,16 @@ articles in the topic and its subtopics."
533 (gnus-topic-update-unreads name unread) 556 (gnus-topic-update-unreads name unread)
534 (beginning-of-line) 557 (beginning-of-line)
535 ;; Insert the text. 558 ;; Insert the text.
536 (gnus-add-text-properties 559 (if shownp
537 (point) 560 (gnus-add-text-properties
538 (prog1 (1+ (point)) 561 (point)
539 (eval gnus-topic-line-format-spec)) 562 (prog1 (1+ (point))
540 (list 'gnus-topic (intern name) 563 (eval gnus-topic-line-format-spec))
541 'gnus-topic-level level 564 (list 'gnus-topic (intern name)
542 'gnus-topic-unread unread 565 'gnus-topic-level level
543 'gnus-active active-topic 566 'gnus-topic-unread unread
544 'gnus-topic-visible visiblep)))) 567 'gnus-active active-topic
568 'gnus-topic-visible visiblep)))))
545 569
546(defun gnus-topic-update-unreads (topic unreads) 570(defun gnus-topic-update-unreads (topic unreads)
547 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) 571 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
@@ -584,7 +608,8 @@ articles in the topic and its subtopics."
584 (let* ((topic (gnus-group-topic group)) 608 (let* ((topic (gnus-group-topic group))
585 (groups (cdr (assoc topic gnus-topic-alist))) 609 (groups (cdr (assoc topic gnus-topic-alist)))
586 (g (cdr (member group groups))) 610 (g (cdr (member group groups)))
587 (unfound t)) 611 (unfound t)
612 entry)
588 ;; Try to jump to a visible group. 613 ;; Try to jump to a visible group.
589 (while (and g (not (gnus-group-goto-group (car g) t))) 614 (while (and g (not (gnus-group-goto-group (car g) t)))
590 (pop g)) 615 (pop g))
@@ -598,8 +623,20 @@ articles in the topic and its subtopics."
598 (when (and unfound 623 (when (and unfound
599 topic 624 topic
600 (not (gnus-topic-goto-missing-topic topic))) 625 (not (gnus-topic-goto-missing-topic topic)))
601 (gnus-topic-insert-topic-line 626 (let* ((top (gnus-topic-find-topology topic))
602 topic t t (car (gnus-topic-find-topology topic)) nil 0))))) 627 (children (cddr top))
628 (type (cadr top))
629 (unread 0)
630 (entries (gnus-topic-find-groups
631 (car type) (car gnus-group-list-mode)
632 (cdr gnus-group-list-mode))))
633 (while children
634 (incf unread (gnus-topic-unread (caar (pop children)))))
635 (while (setq entry (pop entries))
636 (when (numberp (car entry))
637 (incf unread (car entry))))
638 (gnus-topic-insert-topic-line
639 topic t t (car (gnus-topic-find-topology topic)) nil unread))))))
603 640
604(defun gnus-topic-goto-missing-topic (topic) 641(defun gnus-topic-goto-missing-topic (topic)
605 (if (gnus-topic-goto-topic topic) 642 (if (gnus-topic-goto-topic topic)
@@ -608,15 +645,18 @@ articles in the topic and its subtopics."
608 (let* ((top (gnus-topic-find-topology 645 (let* ((top (gnus-topic-find-topology
609 (gnus-topic-parent-topic topic))) 646 (gnus-topic-parent-topic topic)))
610 (tp (reverse (cddr top)))) 647 (tp (reverse (cddr top))))
611 (while (not (equal (caaar tp) topic)) 648 (if (not top)
612 (setq tp (cdr tp))) 649 (gnus-topic-insert-topic-line
613 (pop tp) 650 topic t t (car (gnus-topic-find-topology topic)) nil 0)
614 (while (and tp 651 (while (not (equal (caaar tp) topic))
615 (not (gnus-topic-goto-topic (caaar tp)))) 652 (setq tp (cdr tp)))
616 (pop tp)) 653 (pop tp)
617 (if tp 654 (while (and tp
618 (gnus-topic-forward-topic 1) 655 (not (gnus-topic-goto-topic (caaar tp))))
619 (gnus-topic-goto-missing-topic (caadr top)))) 656 (pop tp))
657 (if tp
658 (gnus-topic-forward-topic 1)
659 (gnus-topic-goto-missing-topic (caadr top)))))
620 nil)) 660 nil))
621 661
622(defun gnus-topic-update-topic-line (topic-name &optional reads) 662(defun gnus-topic-update-topic-line (topic-name &optional reads)
@@ -908,6 +948,7 @@ articles in the topic and its subtopics."
908 "=" gnus-topic-select-group 948 "=" gnus-topic-select-group
909 "\r" gnus-topic-select-group 949 "\r" gnus-topic-select-group
910 " " gnus-topic-read-group 950 " " gnus-topic-read-group
951 "\C-c\C-x" gnus-topic-expire-articles
911 "\C-k" gnus-topic-kill-group 952 "\C-k" gnus-topic-kill-group
912 "\C-y" gnus-topic-yank-group 953 "\C-y" gnus-topic-yank-group
913 "\M-g" gnus-topic-get-new-news-this-topic 954 "\M-g" gnus-topic-get-new-news-this-topic
@@ -931,6 +972,7 @@ articles in the topic and its subtopics."
931 "c" gnus-topic-copy-group 972 "c" gnus-topic-copy-group
932 "h" gnus-topic-hide-topic 973 "h" gnus-topic-hide-topic
933 "s" gnus-topic-show-topic 974 "s" gnus-topic-show-topic
975 "j" gnus-topic-jump-to-topic
934 "M" gnus-topic-move-matching 976 "M" gnus-topic-move-matching
935 "C" gnus-topic-copy-matching 977 "C" gnus-topic-copy-matching
936 "\C-i" gnus-topic-indent 978 "\C-i" gnus-topic-indent
@@ -962,6 +1004,7 @@ articles in the topic and its subtopics."
962 ["Copy matching" gnus-topic-copy-matching t] 1004 ["Copy matching" gnus-topic-copy-matching t]
963 ["Move matching" gnus-topic-move-matching t]) 1005 ["Move matching" gnus-topic-move-matching t])
964 ("Topics" 1006 ("Topics"
1007 ["Goto" gnus-topic-jump-to-topic t]
965 ["Show" gnus-topic-show-topic t] 1008 ["Show" gnus-topic-show-topic t]
966 ["Hide" gnus-topic-hide-topic t] 1009 ["Hide" gnus-topic-hide-topic t]
967 ["Delete" gnus-topic-delete t] 1010 ["Delete" gnus-topic-delete t]
@@ -969,6 +1012,7 @@ articles in the topic and its subtopics."
969 ["Create" gnus-topic-create-topic t] 1012 ["Create" gnus-topic-create-topic t]
970 ["Mark" gnus-topic-mark-topic t] 1013 ["Mark" gnus-topic-mark-topic t]
971 ["Indent" gnus-topic-indent t] 1014 ["Indent" gnus-topic-indent t]
1015 ["Sort" gnus-topic-sort-topics t]
972 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] 1016 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
973 ["Edit parameters" gnus-topic-edit-parameters t]) 1017 ["Edit parameters" gnus-topic-edit-parameters t])
974 ["List active" gnus-topic-list-active t])))) 1018 ["List active" gnus-topic-list-active t]))))
@@ -982,12 +1026,15 @@ articles in the topic and its subtopics."
982 (if (null arg) (not gnus-topic-mode) 1026 (if (null arg) (not gnus-topic-mode)
983 (> (prefix-numeric-value arg) 0))) 1027 (> (prefix-numeric-value arg) 0)))
984 ;; Infest Gnus with topics. 1028 ;; Infest Gnus with topics.
985 (if (not gnus-topic-mode) 1029 (if (not gnus-topic-mode)
986 (setq gnus-goto-missing-group-function nil) 1030 (setq gnus-goto-missing-group-function nil)
987 (when (gnus-visual-p 'topic-menu 'menu) 1031 (when (gnus-visual-p 'topic-menu 'menu)
988 (gnus-topic-make-menu-bar)) 1032 (gnus-topic-make-menu-bar))
989 (gnus-set-format 'topic t) 1033 (gnus-set-format 'topic t)
990 (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) 1034 (gnus-add-minor-mode 'gnus-topic-mode " Topic"
1035 gnus-topic-mode-map nil (lambda (&rest junk)
1036 (interactive)
1037 (gnus-topic-mode nil t)))
991 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) 1038 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
992 (set (make-local-variable 'gnus-group-prepare-function) 1039 (set (make-local-variable 'gnus-group-prepare-function)
993 'gnus-group-prepare-topics) 1040 'gnus-group-prepare-topics)
@@ -1032,7 +1079,8 @@ If performed over a topic line, toggle folding the topic."
1032 (if (gnus-group-topic-p) 1079 (if (gnus-group-topic-p)
1033 (let ((gnus-group-list-mode 1080 (let ((gnus-group-list-mode
1034 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) 1081 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
1035 (gnus-topic-fold all)) 1082 (gnus-topic-fold all)
1083 (gnus-dribble-touch))
1036 (gnus-group-select-group all))) 1084 (gnus-group-select-group all)))
1037 1085
1038(defun gnus-mouse-pick-topic (e) 1086(defun gnus-mouse-pick-topic (e)
@@ -1041,6 +1089,19 @@ If performed over a topic line, toggle folding the topic."
1041 (mouse-set-point e) 1089 (mouse-set-point e)
1042 (gnus-topic-read-group nil)) 1090 (gnus-topic-read-group nil))
1043 1091
1092(defun gnus-topic-expire-articles (topic)
1093 "Expire articles in this topic or group."
1094 (interactive (list (gnus-group-topic-name)))
1095 (if (not topic)
1096 (call-interactively 'gnus-group-expire-articles)
1097 (save-excursion
1098 (gnus-message 5 "Expiring groups in %s..." topic)
1099 (let ((gnus-group-marked
1100 (mapcar (lambda (entry) (car (nth 2 entry)))
1101 (gnus-topic-find-groups topic gnus-level-killed t))))
1102 (gnus-group-expire-articles nil))
1103 (gnus-message 5 "Expiring groups in %s...done" topic))))
1104
1044(defun gnus-topic-read-group (&optional all no-article group) 1105(defun gnus-topic-read-group (&optional all no-article group)
1045 "Read news in this newsgroup. 1106 "Read news in this newsgroup.
1046If the prefix argument ALL is non-nil, already read articles become 1107If the prefix argument ALL is non-nil, already read articles become
@@ -1086,44 +1147,60 @@ When used interactively, PARENT will be the topic under point."
1086 (gnus-group-list-groups) 1147 (gnus-group-list-groups)
1087 (gnus-topic-goto-topic topic)) 1148 (gnus-topic-goto-topic topic))
1088 1149
1150;; FIXME:
1151;; 1. When the marked groups are overlapped with the process
1152;; region, the behavior of move or remove is not right.
1153;; 2. Can't process on several marked groups with a same name,
1154;; because gnus-group-marked only keeps one copy.
1155
1089(defun gnus-topic-move-group (n topic &optional copyp) 1156(defun gnus-topic-move-group (n topic &optional copyp)
1090 "Move the next N groups to TOPIC. 1157 "Move the next N groups to TOPIC.
1091If COPYP, copy the groups instead." 1158If COPYP, copy the groups instead."
1092 (interactive 1159 (interactive
1093 (list current-prefix-arg 1160 (list current-prefix-arg
1094 (completing-read "Move to topic: " gnus-topic-alist nil t))) 1161 (completing-read "Move to topic: " gnus-topic-alist nil t)))
1095 (let ((groups (gnus-group-process-prefix n)) 1162 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1163 gnus-group-marked t))
1164 (groups (gnus-group-process-prefix n))
1096 (topicl (assoc topic gnus-topic-alist)) 1165 (topicl (assoc topic gnus-topic-alist))
1097 (start-group (progn (forward-line 1) (gnus-group-group-name)))
1098 (start-topic (gnus-group-topic-name)) 1166 (start-topic (gnus-group-topic-name))
1167 (start-group (progn (forward-line 1) (gnus-group-group-name)))
1099 entry) 1168 entry)
1100 (mapcar 1169 (if (and (not groups) (not copyp) start-topic)
1101 (lambda (g) 1170 (gnus-topic-move start-topic topic)
1102 (gnus-group-remove-mark g) 1171 (mapcar
1103 (when (and 1172 (lambda (g)
1104 (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) 1173 (gnus-group-remove-mark g use-marked)
1105 (not copyp)) 1174 (when (and
1106 (setcdr entry (gnus-delete-first g (cdr entry)))) 1175 (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
1107 (nconc topicl (list g))) 1176 (not copyp))
1108 groups) 1177 (setcdr entry (gnus-delete-first g (cdr entry))))
1109 (gnus-topic-enter-dribble) 1178 (nconc topicl (list g)))
1110 (if start-group 1179 groups)
1111 (gnus-group-goto-group start-group) 1180 (gnus-topic-enter-dribble)
1112 (gnus-topic-goto-topic start-topic)) 1181 (if start-group
1113 (gnus-group-list-groups))) 1182 (gnus-group-goto-group start-group)
1183 (gnus-topic-goto-topic start-topic))
1184 (gnus-group-list-groups))))
1114 1185
1115(defun gnus-topic-remove-group (&optional arg) 1186(defun gnus-topic-remove-group (&optional n)
1116 "Remove the current group from the topic." 1187 "Remove the current group from the topic."
1117 (interactive "P") 1188 (interactive "P")
1118 (gnus-group-iterate arg 1189 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1119 (lambda (group) 1190 gnus-group-marked t))
1120 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) 1191 (groups (gnus-group-process-prefix n)))
1121 (buffer-read-only nil)) 1192 (mapcar
1122 (when (and topicl group) 1193 (lambda (group)
1123 (gnus-delete-line) 1194 (gnus-group-remove-mark group use-marked)
1124 (gnus-delete-first group topicl)) 1195 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
1125 (gnus-topic-update-topic) 1196 (buffer-read-only nil))
1126 (gnus-group-position-point))))) 1197 (when (and topicl group)
1198 (gnus-delete-line)
1199 (gnus-delete-first group topicl))
1200 (gnus-topic-update-topic)))
1201 groups)
1202 (gnus-topic-enter-dribble)
1203 (gnus-group-position-point)))
1127 1204
1128(defun gnus-topic-copy-group (n topic) 1205(defun gnus-topic-copy-group (n topic)
1129 "Copy the current group to a topic." 1206 "Copy the current group to a topic."
@@ -1145,7 +1222,12 @@ If COPYP, copy the groups instead."
1145 (gnus-topic-find-topology topic nil nil gnus-topic-topology) 1222 (gnus-topic-find-topology topic nil nil gnus-topic-topology)
1146 (gnus-topic-enter-dribble)) 1223 (gnus-topic-enter-dribble))
1147 (gnus-group-kill-group n discard) 1224 (gnus-group-kill-group n discard)
1148 (gnus-topic-update-topic))) 1225 (if (not (gnus-group-topic-p))
1226 (gnus-topic-update-topic)
1227 ;; Move up one line so that we update the right topic.
1228 (forward-line -1)
1229 (gnus-topic-update-topic)
1230 (forward-line 1))))
1149 1231
1150(defun gnus-topic-yank-group (&optional arg) 1232(defun gnus-topic-yank-group (&optional arg)
1151 "Yank the last topic." 1233 "Yank the last topic."
@@ -1195,43 +1277,64 @@ If COPYP, copy the groups instead."
1195 (setq alist (cdr alist)))))) 1277 (setq alist (cdr alist))))))
1196 (gnus-topic-update-topic))) 1278 (gnus-topic-update-topic)))
1197 1279
1198(defun gnus-topic-hide-topic () 1280(defun gnus-topic-hide-topic (&optional permanent)
1199 "Hide the current topic." 1281 "Hide the current topic.
1200 (interactive) 1282If PERMANENT, make it stay hidden in subsequent sessions as well."
1283 (interactive "P")
1201 (when (gnus-current-topic) 1284 (when (gnus-current-topic)
1202 (gnus-topic-goto-topic (gnus-current-topic)) 1285 (gnus-topic-goto-topic (gnus-current-topic))
1203 (gnus-topic-remove-topic nil nil 'hidden))) 1286 (if permanent
1204 1287 (setcar (cddr
1205(defun gnus-topic-show-topic () 1288 (cadr
1206 "Show the hidden topic." 1289 (gnus-topic-find-topology (gnus-current-topic))))
1207 (interactive) 1290 'hidden))
1291 (gnus-topic-remove-topic nil nil)))
1292
1293(defun gnus-topic-show-topic (&optional permanent)
1294 "Show the hidden topic.
1295If PERMANENT, make it stay shown in subsequent sessions as well."
1296 (interactive "P")
1208 (when (gnus-group-topic-p) 1297 (when (gnus-group-topic-p)
1209 (gnus-topic-remove-topic t nil 'shown))) 1298 (if (not permanent)
1210 1299 (gnus-topic-remove-topic t nil)
1211(defun gnus-topic-mark-topic (topic &optional unmark) 1300 (let ((topic
1212 "Mark all groups in the topic with the process mark." 1301 (gnus-topic-find-topology
1213 (interactive (list (gnus-group-topic-name))) 1302 (completing-read "Show topic: " gnus-topic-alist nil t))))
1303 (setcar (cddr (cadr topic)) nil)
1304 (setcar (cdr (cadr topic)) 'visible)
1305 (gnus-group-list-groups)))))
1306
1307(defun gnus-topic-mark-topic (topic &optional unmark recursive)
1308 "Mark all groups in the TOPIC with the process mark.
1309If RECURSIVE is t, mark its subtopics too."
1310 (interactive (list (gnus-group-topic-name)
1311 nil
1312 (and current-prefix-arg t)))
1214 (if (not topic) 1313 (if (not topic)
1215 (call-interactively 'gnus-group-mark-group) 1314 (call-interactively 'gnus-group-mark-group)
1216 (save-excursion 1315 (save-excursion
1217 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t))) 1316 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
1317 recursive)))
1218 (while groups 1318 (while groups
1219 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) 1319 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1220 (gnus-info-group (nth 2 (pop groups))))))))) 1320 (gnus-info-group (nth 2 (pop groups)))))))))
1221 1321
1222(defun gnus-topic-unmark-topic (topic &optional unmark) 1322(defun gnus-topic-unmark-topic (topic &optional dummy recursive)
1223 "Remove the process mark from all groups in the topic." 1323 "Remove the process mark from all groups in the TOPIC.
1224 (interactive (list (gnus-group-topic-name))) 1324If RECURSIVE is t, unmark its subtopics too."
1325 (interactive (list (gnus-group-topic-name)
1326 nil
1327 (and current-prefix-arg t)))
1225 (if (not topic) 1328 (if (not topic)
1226 (call-interactively 'gnus-group-unmark-group) 1329 (call-interactively 'gnus-group-unmark-group)
1227 (gnus-topic-mark-topic topic t))) 1330 (gnus-topic-mark-topic topic t recursive)))
1228 1331
1229(defun gnus-topic-get-new-news-this-topic (&optional n) 1332(defun gnus-topic-get-new-news-this-topic (&optional n)
1230 "Check for new news in the current topic." 1333 "Check for new news in the current topic."
1231 (interactive "P") 1334 (interactive "P")
1232 (if (not (gnus-group-topic-p)) 1335 (if (not (gnus-group-topic-p))
1233 (gnus-group-get-new-news-this-group n) 1336 (gnus-group-get-new-news-this-group n)
1234 (gnus-topic-mark-topic (gnus-group-topic-name)) 1337 (gnus-topic-mark-topic (gnus-group-topic-name) nil (and n t))
1235 (gnus-group-get-new-news-this-group))) 1338 (gnus-group-get-new-news-this-group)))
1236 1339
1237(defun gnus-topic-move-matching (regexp topic &optional copyp) 1340(defun gnus-topic-move-matching (regexp topic &optional copyp)
@@ -1450,6 +1553,68 @@ If REVERSE, sort in reverse order."
1450 (interactive "P") 1553 (interactive "P")
1451 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) 1554 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
1452 1555
1556(defun gnus-topic-sort-topics-1 (top reverse)
1557 (if (cdr top)
1558 (let ((subtop
1559 (mapcar `(lambda (top)
1560 (gnus-topic-sort-topics-1 top ,reverse))
1561 (sort (cdr top)
1562 '(lambda (t1 t2)
1563 (string-lessp (caar t1) (caar t2)))))))
1564 (setcdr top (if reverse (reverse subtop) subtop))))
1565 top)
1566
1567(defun gnus-topic-sort-topics (&optional topic reverse)
1568 "Sort topics in TOPIC alphabeticaly by topic name.
1569If REVERSE, reverse the sorting order."
1570 (interactive
1571 (list (completing-read "Sort topics in : " gnus-topic-alist nil t
1572 (gnus-current-topic))
1573 current-prefix-arg))
1574 (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
1575 gnus-topic-topology)))
1576 (gnus-topic-sort-topics-1 topic-topology reverse)
1577 (gnus-topic-enter-dribble)
1578 (gnus-group-list-groups)
1579 (gnus-topic-goto-topic topic)))
1580
1581(defun gnus-topic-move (current to)
1582 "Move the CURRENT topic to TO."
1583 (interactive
1584 (list
1585 (gnus-group-topic-name)
1586 (completing-read "Move to topic: " gnus-topic-alist nil t)))
1587 (unless (and current to)
1588 (error "Can't find topic"))
1589 (let ((current-top (cdr (gnus-topic-find-topology current)))
1590 (to-top (cdr (gnus-topic-find-topology to))))
1591 (unless current-top
1592 (error "Can't find topic `%s'" current))
1593 (unless to-top
1594 (error "Can't find topic `%s'" to))
1595 (if (gnus-topic-find-topology to current-top 0);; Don't care the level
1596 (error "Can't move `%s' to its sub-level" current))
1597 (gnus-topic-find-topology current nil nil 'delete)
1598 (while (cdr to-top)
1599 (setq to-top (cdr to-top)))
1600 (setcdr to-top (list current-top))
1601 (gnus-topic-enter-dribble)
1602 (gnus-group-list-groups)
1603 (gnus-topic-goto-topic current)))
1604
1605(defun gnus-subscribe-topics (newsgroup)
1606 (catch 'end
1607 (let (match gnus-group-change-level-function)
1608 (dolist (topic (gnus-topic-list))
1609 (when (and (setq match (cdr (assq 'subscribe
1610 (gnus-topic-parameters topic))))
1611 (string-match match newsgroup))
1612 ;; Just subscribe the group.
1613 (gnus-subscribe-alphabetically newsgroup)
1614 ;; Add the group to the topic.
1615 (nconc (assoc topic gnus-topic-alist) (list newsgroup))
1616 (throw 'end t))))))
1617
1453(provide 'gnus-topic) 1618(provide 'gnus-topic)
1454 1619
1455;;; gnus-topic.el ends here 1620;;; gnus-topic.el ends here
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index 8885fbd8719..72e4d031e1c 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -1,5 +1,6 @@
1;;; gnus-util.el --- utility functions for Gnus 1;;; gnus-util.el --- utility functions for Gnus
2;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. 2;; Copyright (C) 1996, 1997, 1998, 1999, 2000
3;; Free Software Foundation, Inc.
3 4
4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 6;; Keywords: news
@@ -33,12 +34,10 @@
33(require 'custom) 34(require 'custom)
34(eval-when-compile (require 'cl)) 35(eval-when-compile (require 'cl))
35(require 'nnheader) 36(require 'nnheader)
36(require 'timezone)
37(require 'message) 37(require 'message)
38(eval-when-compile (require 'rmail)) 38(require 'time-date)
39 39
40(eval-and-compile 40(eval-and-compile
41 (autoload 'nnmail-date-to-time "nnmail")
42 (autoload 'rmail-insert-rmail-file-header "rmail") 41 (autoload 'rmail-insert-rmail-file-header "rmail")
43 (autoload 'rmail-count-new-messages "rmail") 42 (autoload 'rmail-count-new-messages "rmail")
44 (autoload 'rmail-show-message "rmail")) 43 (autoload 'rmail-show-message "rmail"))
@@ -76,9 +75,6 @@
76 (set symbol nil)) 75 (set symbol nil))
77 symbol)) 76 symbol))
78 77
79(defun gnus-truncate-string (str width)
80 (substring str 0 width))
81
82;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way 78;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
83;; to limit the length of a string. This function is necessary since 79;; to limit the length of a string. This function is necessary since
84;; `(substr "abc" 0 30)' pukes with "Args out of range". 80;; `(substr "abc" 0 30)' pukes with "Args out of range".
@@ -107,25 +103,15 @@
107 (when (gnus-buffer-exists-p buf) 103 (when (gnus-buffer-exists-p buf)
108 (kill-buffer buf)))) 104 (kill-buffer buf))))
109 105
110(if (fboundp 'point-at-bol) 106(defalias 'gnus-point-at-bol
111 (fset 'gnus-point-at-bol 'point-at-bol) 107 (if (fboundp 'point-at-bol)
112 (defun gnus-point-at-bol () 108 'point-at-bol
113 "Return point at the beginning of the line." 109 'line-beginning-position))
114 (let ((p (point))) 110
115 (beginning-of-line) 111(defalias 'gnus-point-at-eol
116 (prog1 112 (if (fboundp 'point-at-eol)
117 (point) 113 'point-at-eol
118 (goto-char p))))) 114 'line-end-position))
119
120(if (fboundp 'point-at-eol)
121 (fset 'gnus-point-at-eol 'point-at-eol)
122 (defun gnus-point-at-eol ()
123 "Return point at the end of the line."
124 (let ((p (point)))
125 (end-of-line)
126 (prog1
127 (point)
128 (goto-char p)))))
129 115
130(defun gnus-delete-first (elt list) 116(defun gnus-delete-first (elt list)
131 "Delete by side effect the first occurrence of ELT as a member of LIST." 117 "Delete by side effect the first occurrence of ELT as a member of LIST."
@@ -179,8 +165,8 @@
179 (and (string-match "(.*" from) 165 (and (string-match "(.*" from)
180 (setq name (substring from (1+ (match-beginning 0)) 166 (setq name (substring from (1+ (match-beginning 0))
181 (match-end 0))))) 167 (match-end 0)))))
182 ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. 168 (list (if (string= name "") nil name) (or address from))))
183 (list (or name from) (or address from)))) 169
184 170
185(defun gnus-fetch-field (field) 171(defun gnus-fetch-field (field)
186 "Return the value of the header FIELD of current article." 172 "Return the value of the header FIELD of current article."
@@ -232,43 +218,6 @@
232 218
233;;; Time functions. 219;;; Time functions.
234 220
235(defun gnus-days-between (date1 date2)
236 ;; Return the number of days between date1 and date2.
237 (- (gnus-day-number date1) (gnus-day-number date2)))
238
239(defun gnus-day-number (date)
240 (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
241 (timezone-parse-date date))))
242 (timezone-absolute-from-gregorian
243 (nth 1 dat) (nth 2 dat) (car dat))))
244
245(defun gnus-time-to-day (time)
246 "Convert TIME to day number."
247 (let ((tim (decode-time time)))
248 (timezone-absolute-from-gregorian
249 (nth 4 tim) (nth 3 tim) (nth 5 tim))))
250
251(defun gnus-encode-date (date)
252 "Convert DATE to internal time."
253 (let* ((parse (timezone-parse-date date))
254 (date (mapcar (lambda (d) (and d (string-to-int d))) parse))
255 (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
256 (encode-time (caddr time) (cadr time) (car time)
257 (caddr date) (cadr date) (car date)
258 (* 60 (timezone-zone-to-minute (nth 4 date))))))
259
260(defun gnus-time-minus (t1 t2)
261 "Subtract two internal times."
262 (let ((borrow (< (cadr t1) (cadr t2))))
263 (list (- (car t1) (car t2) (if borrow 1 0))
264 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
265
266(defun gnus-time-less (t1 t2)
267 "Say whether time T1 is less than time T2."
268 (or (< (car t1) (car t2))
269 (and (= (car t1) (car t2))
270 (< (nth 1 t1) (nth 1 t2)))))
271
272(defun gnus-file-newer-than (file date) 221(defun gnus-file-newer-than (file date)
273 (let ((fdate (nth 5 (file-attributes file)))) 222 (let ((fdate (nth 5 (file-attributes file))))
274 (or (> (car fdate) (car date)) 223 (or (> (car fdate) (car date))
@@ -343,20 +292,9 @@
343 292
344(defun gnus-dd-mmm (messy-date) 293(defun gnus-dd-mmm (messy-date)
345 "Return a string like DD-MMM from a big messy string." 294 "Return a string like DD-MMM from a big messy string."
346 (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) 295 (condition-case ()
347 (if (or (not datevec) 296 (format-time-string "%d-%b" (safe-date-to-time messy-date))
348 (string-equal "0" (aref datevec 1))) 297 (error " - ")))
349 "??-???"
350 (format "%2s-%s"
351 (condition-case ()
352 ;; Make sure leading zeroes are stripped.
353 (number-to-string (string-to-number (aref datevec 2)))
354 (error "??"))
355 (capitalize
356 (or (car
357 (nth (1- (string-to-number (aref datevec 1)))
358 timezone-months-assoc))
359 "???"))))))
360 298
361(defmacro gnus-date-get-time (date) 299(defmacro gnus-date-get-time (date)
362 "Convert DATE string to Emacs time. 300 "Convert DATE string to Emacs time.
@@ -367,17 +305,17 @@ Cache the result as a text property stored in DATE."
367 '(0 0) 305 '(0 0)
368 (or (get-text-property 0 'gnus-time d) 306 (or (get-text-property 0 'gnus-time d)
369 ;; or compute the value... 307 ;; or compute the value...
370 (let ((time (nnmail-date-to-time d))) 308 (let ((time (safe-date-to-time d)))
371 ;; and store it back in the string. 309 ;; and store it back in the string.
372 (put-text-property 0 1 'gnus-time time d) 310 (put-text-property 0 1 'gnus-time time d)
373 time))))) 311 time)))))
374 312
375(defsubst gnus-time-iso8601 (time) 313(defsubst gnus-time-iso8601 (time)
376 "Return a string of TIME in YYMMDDTHHMMSS format." 314 "Return a string of TIME in YYYYMMDDTHHMMSS format."
377 (format-time-string "%Y%m%dT%H%M%S" time)) 315 (format-time-string "%Y%m%dT%H%M%S" time))
378 316
379(defun gnus-date-iso8601 (date) 317(defun gnus-date-iso8601 (date)
380 "Convert the DATE to YYMMDDTHHMMSS." 318 "Convert the DATE to YYYYMMDDTHHMMSS."
381 (condition-case () 319 (condition-case ()
382 (gnus-time-iso8601 (gnus-date-get-time date)) 320 (gnus-time-iso8601 (gnus-date-get-time date))
383 (error ""))) 321 (error "")))
@@ -451,12 +389,14 @@ jabbering all the time."
451 ids)) 389 ids))
452 (nreverse ids))) 390 (nreverse ids)))
453 391
454(defun gnus-parent-id (references &optional n) 392(defsubst gnus-parent-id (references &optional n)
455 "Return the last Message-ID in REFERENCES. 393 "Return the last Message-ID in REFERENCES.
456If N, return the Nth ancestor instead." 394If N, return the Nth ancestor instead."
457 (when references 395 (when references
458 (let ((ids (inline (gnus-split-references references)))) 396 (let ((ids (inline (gnus-split-references references))))
459 (car (last ids (or n 1)))))) 397 (while (nthcdr (or n 1) ids)
398 (setq ids (cdr ids)))
399 (car ids))))
460 400
461(defsubst gnus-buffer-live-p (buffer) 401(defsubst gnus-buffer-live-p (buffer)
462 "Say whether BUFFER is alive or not." 402 "Say whether BUFFER is alive or not."
@@ -496,20 +436,8 @@ If N, return the Nth ancestor instead."
496 (cons (and (numberp event) event) event))) 436 (cons (and (numberp event) event) event)))
497 437
498(defun gnus-sortable-date (date) 438(defun gnus-sortable-date (date)
499 "Make sortable string by string-lessp from DATE. 439 "Make string suitable for sorting from DATE."
500Timezone package is used." 440 (gnus-time-iso8601 (date-to-time date)))
501 (condition-case ()
502 (progn
503 (setq date (inline (timezone-fix-time
504 date nil
505 (aref (inline (timezone-parse-date date)) 4))))
506 (inline
507 (timezone-make-sortable-date
508 (aref date 0) (aref date 1) (aref date 2)
509 (inline
510 (timezone-make-time-string
511 (aref date 3) (aref date 4) (aref date 5))))))
512 (error "")))
513 441
514(defun gnus-copy-file (file &optional to) 442(defun gnus-copy-file (file &optional to)
515 "Copy FILE to TO." 443 "Copy FILE to TO."
@@ -541,7 +469,7 @@ Timezone package is used."
541 (erase-buffer)) 469 (erase-buffer))
542 (set-buffer (gnus-get-buffer-create gnus-work-buffer)) 470 (set-buffer (gnus-get-buffer-create gnus-work-buffer))
543 (kill-all-local-variables) 471 (kill-all-local-variables)
544 (buffer-disable-undo (current-buffer)))) 472 (mm-enable-multibyte)))
545 473
546(defmacro gnus-group-real-name (group) 474(defmacro gnus-group-real-name (group)
547 "Find the real name of a foreign newsgroup." 475 "Find the real name of a foreign newsgroup."
@@ -553,21 +481,41 @@ Timezone package is used."
553(defun gnus-make-sort-function (funs) 481(defun gnus-make-sort-function (funs)
554 "Return a composite sort condition based on the functions in FUNC." 482 "Return a composite sort condition based on the functions in FUNC."
555 (cond 483 (cond
556 ((not (listp funs)) funs) 484 ;; Just a simple function.
485 ((gnus-functionp funs) funs)
486 ;; No functions at all.
557 ((null funs) funs) 487 ((null funs) funs)
558 ((cdr funs) 488 ;; A list of functions.
489 ((or (cdr funs)
490 (listp (car funs)))
559 `(lambda (t1 t2) 491 `(lambda (t1 t2)
560 ,(gnus-make-sort-function-1 (reverse funs)))) 492 ,(gnus-make-sort-function-1 (reverse funs))))
493 ;; A list containing just one function.
561 (t 494 (t
562 (car funs)))) 495 (car funs))))
563 496
564(defun gnus-make-sort-function-1 (funs) 497(defun gnus-make-sort-function-1 (funs)
565 "Return a composite sort condition based on the functions in FUNC." 498 "Return a composite sort condition based on the functions in FUNC."
566 (if (cdr funs) 499 (let ((function (car funs))
567 `(or (,(car funs) t1 t2) 500 (first 't1)
568 (and (not (,(car funs) t2 t1)) 501 (last 't2))
569 ,(gnus-make-sort-function-1 (cdr funs)))) 502 (when (consp function)
570 `(,(car funs) t1 t2))) 503 (cond
504 ;; Reversed spec.
505 ((eq (car function) 'not)
506 (setq function (cadr function)
507 first 't2
508 last 't1))
509 ((gnus-functionp function)
510 ;; Do nothing.
511 )
512 (t
513 (error "Invalid sort spec: %s" function))))
514 (if (cdr funs)
515 `(or (,function ,first ,last)
516 (and (not (,function ,last ,first))
517 ,(gnus-make-sort-function-1 (cdr funs))))
518 `(,function ,first ,last))))
571 519
572(defun gnus-turn-off-edit-menu (type) 520(defun gnus-turn-off-edit-menu (type)
573 "Turn off edit menu in `gnus-TYPE-mode-map'." 521 "Turn off edit menu in `gnus-TYPE-mode-map'."
@@ -591,17 +539,19 @@ Bind `print-quoted' and `print-readably' to t while printing."
591 539
592(defun gnus-make-directory (directory) 540(defun gnus-make-directory (directory)
593 "Make DIRECTORY (and all its parents) if it doesn't exist." 541 "Make DIRECTORY (and all its parents) if it doesn't exist."
594 (when (and directory 542 (let ((file-name-coding-system nnmail-pathname-coding-system))
595 (not (file-exists-p directory))) 543 (when (and directory
596 (make-directory directory t)) 544 (not (file-exists-p directory)))
545 (make-directory directory t)))
597 t) 546 t)
598 547
599(defun gnus-write-buffer (file) 548(defun gnus-write-buffer (file)
600 "Write the current buffer's contents to FILE." 549 "Write the current buffer's contents to FILE."
601 ;; Make sure the directory exists. 550 ;; Make sure the directory exists.
602 (gnus-make-directory (file-name-directory file)) 551 (gnus-make-directory (file-name-directory file))
603 ;; Write the buffer. 552 (let ((file-name-coding-system nnmail-pathname-coding-system))
604 (write-region (point-min) (point-max) file nil 'quietly)) 553 ;; Write the buffer.
554 (write-region (point-min) (point-max) file nil 'quietly)))
605 555
606(defun gnus-delete-file (file) 556(defun gnus-delete-file (file)
607 "Delete FILE if it exists." 557 "Delete FILE if it exists."
@@ -614,13 +564,13 @@ Bind `print-quoted' and `print-readably' to t while printing."
614 (setq string (replace-match "" t t string))) 564 (setq string (replace-match "" t t string)))
615 string) 565 string)
616 566
617(defun gnus-put-text-property-excluding-newlines (beg end prop val) 567(defsubst gnus-put-text-property-excluding-newlines (beg end prop val)
618 "The same as `put-text-property', but don't put this prop on any newlines in the region." 568 "The same as `put-text-property', but don't put this prop on any newlines in the region."
619 (save-match-data 569 (save-match-data
620 (save-excursion 570 (save-excursion
621 (save-restriction 571 (save-restriction
622 (goto-char beg) 572 (goto-char beg)
623 (while (re-search-forward "[ \t]*\n" end 'move) 573 (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
624 (gnus-put-text-property beg (match-beginning 0) prop val) 574 (gnus-put-text-property beg (match-beginning 0) prop val)
625 (setq beg (point))) 575 (setq beg (point)))
626 (gnus-put-text-property beg (point) prop val))))) 576 (gnus-put-text-property beg (point) prop val)))))
@@ -733,7 +683,8 @@ with potentially long computations."
733 (save-excursion 683 (save-excursion
734 (set-buffer file-buffer) 684 (set-buffer file-buffer)
735 (rmail-insert-rmail-file-header) 685 (rmail-insert-rmail-file-header)
736 (let ((require-final-newline nil)) 686 (let ((require-final-newline nil)
687 (coding-system-for-write mm-text-coding-system))
737 (gnus-write-buffer filename))) 688 (gnus-write-buffer filename)))
738 (kill-buffer file-buffer)) 689 (kill-buffer file-buffer))
739 (error "Output file does not exist"))) 690 (error "Output file does not exist")))
@@ -744,7 +695,7 @@ with potentially long computations."
744 ;; Decide whether to append to a file or to an Emacs buffer. 695 ;; Decide whether to append to a file or to an Emacs buffer.
745 (let ((outbuf (get-file-buffer filename))) 696 (let ((outbuf (get-file-buffer filename)))
746 (if (not outbuf) 697 (if (not outbuf)
747 (append-to-file (point-min) (point-max) filename) 698 (mm-append-to-file (point-min) (point-max) filename)
748 ;; File has been visited, in buffer OUTBUF. 699 ;; File has been visited, in buffer OUTBUF.
749 (set-buffer outbuf) 700 (set-buffer outbuf)
750 (let ((buffer-read-only nil) 701 (let ((buffer-read-only nil)
@@ -784,7 +735,8 @@ with potentially long computations."
784 (let ((file-buffer (create-file-buffer filename))) 735 (let ((file-buffer (create-file-buffer filename)))
785 (save-excursion 736 (save-excursion
786 (set-buffer file-buffer) 737 (set-buffer file-buffer)
787 (let ((require-final-newline nil)) 738 (let ((require-final-newline nil)
739 (coding-system-for-write mm-text-coding-system))
788 (gnus-write-buffer filename))) 740 (gnus-write-buffer filename)))
789 (kill-buffer file-buffer)) 741 (kill-buffer file-buffer))
790 (error "Output file does not exist"))) 742 (error "Output file does not exist")))
@@ -812,7 +764,7 @@ with potentially long computations."
812 (insert "\n")) 764 (insert "\n"))
813 (insert "\n")) 765 (insert "\n"))
814 (goto-char (point-max)) 766 (goto-char (point-max))
815 (append-to-file (point-min) (point-max) filename))) 767 (mm-append-to-file (point-min) (point-max) filename)))
816 ;; File has been visited, in buffer OUTBUF. 768 ;; File has been visited, in buffer OUTBUF.
817 (set-buffer outbuf) 769 (set-buffer outbuf)
818 (let ((buffer-read-only nil)) 770 (let ((buffer-read-only nil))
@@ -853,84 +805,84 @@ ARG is passed to the first function."
853;;; .netrc and .authinforc parsing 805;;; .netrc and .authinforc parsing
854;;; 806;;;
855 807
856(defvar gnus-netrc-syntax-table
857 (let ((table (copy-syntax-table text-mode-syntax-table)))
858 (modify-syntax-entry ?@ "w" table)
859 (modify-syntax-entry ?- "w" table)
860 (modify-syntax-entry ?_ "w" table)
861 (modify-syntax-entry ?! "w" table)
862 (modify-syntax-entry ?. "w" table)
863 (modify-syntax-entry ?, "w" table)
864 (modify-syntax-entry ?: "w" table)
865 (modify-syntax-entry ?\; "w" table)
866 (modify-syntax-entry ?% "w" table)
867 (modify-syntax-entry ?) "w" table)
868 (modify-syntax-entry ?( "w" table)
869 table)
870 "Syntax table when parsing .netrc files.")
871
872(defun gnus-parse-netrc (file) 808(defun gnus-parse-netrc (file)
873 "Parse FILE and return an list of all entries in the file." 809 "Parse FILE and return an list of all entries in the file."
874 (if (not (file-exists-p file)) 810 (when (file-exists-p file)
875 () 811 (with-temp-buffer
876 (save-excursion
877 (let ((tokens '("machine" "default" "login" 812 (let ((tokens '("machine" "default" "login"
878 "password" "account" "macdef" "force")) 813 "password" "account" "macdef" "force"
814 "port"))
879 alist elem result pair) 815 alist elem result pair)
880 (nnheader-set-temp-buffer " *netrc*") 816 (insert-file-contents file)
881 (unwind-protect 817 (goto-char (point-min))
882 (progn 818 ;; Go through the file, line by line.
883 (set-syntax-table gnus-netrc-syntax-table) 819 (while (not (eobp))
884 (insert-file-contents file) 820 (narrow-to-region (point) (gnus-point-at-eol))
885 (goto-char (point-min)) 821 ;; For each line, get the tokens and values.
886 ;; Go through the file, line by line. 822 (while (not (eobp))
887 (while (not (eobp)) 823 (skip-chars-forward "\t ")
888 (narrow-to-region (point) (gnus-point-at-eol)) 824 ;; Skip lines that begin with a "#".
889 ;; For each line, get the tokens and values. 825 (if (eq (char-after) ?#)
890 (while (not (eobp)) 826 (goto-char (point-max))
891 (skip-chars-forward "\t ") 827 (unless (eobp)
892 (unless (eobp) 828 (setq elem
893 (setq elem (buffer-substring 829 (if (= (following-char) ?\")
894 (point) (progn (forward-sexp 1) (point)))) 830 (read (current-buffer))
895 (cond 831 (buffer-substring
896 ((equal elem "macdef") 832 (point) (progn (skip-chars-forward "^\t ")
897 ;; We skip past the macro definition. 833 (point)))))
898 (widen) 834 (cond
899 (while (and (zerop (forward-line 1)) 835 ((equal elem "macdef")
900 (looking-at "$"))) 836 ;; We skip past the macro definition.
901 (narrow-to-region (point) (point))) 837 (widen)
902 ((member elem tokens) 838 (while (and (zerop (forward-line 1))
903 ;; Tokens that don't have a following value are ignored, 839 (looking-at "$")))
904 ;; except "default". 840 (narrow-to-region (point) (point)))
905 (when (and pair (or (cdr pair) 841 ((member elem tokens)
906 (equal (car pair) "default"))) 842 ;; Tokens that don't have a following value are ignored,
907 (push pair alist)) 843 ;; except "default".
908 (setq pair (list elem))) 844 (when (and pair (or (cdr pair)
909 (t 845 (equal (car pair) "default")))
910 ;; Values that haven't got a preceding token are ignored. 846 (push pair alist))
911 (when pair 847 (setq pair (list elem)))
912 (setcdr pair elem) 848 (t
913 (push pair alist) 849 ;; Values that haven't got a preceding token are ignored.
914 (setq pair nil)))))) 850 (when pair
915 (if alist 851 (setcdr pair elem)
916 (push (nreverse alist) result)) 852 (push pair alist)
917 (setq alist nil 853 (setq pair nil)))))))
918 pair nil) 854 (when alist
919 (widen) 855 (push (nreverse alist) result))
920 (forward-line 1)) 856 (setq alist nil
921 (nreverse result)) 857 pair nil)
922 (kill-buffer " *netrc*")))))) 858 (widen)
923 859 (forward-line 1))
924(defun gnus-netrc-machine (list machine) 860 (nreverse result)))))
925 "Return the netrc values from LIST for MACHINE or for the default entry." 861
926 (let ((rest list)) 862(defun gnus-netrc-machine (list machine &optional port defaultport)
927 (while (and list 863 "Return the netrc values from LIST for MACHINE or for the default entry.
928 (not (equal (cdr (assoc "machine" (car list))) machine))) 864If PORT specified, only return entries with matching port tokens.
865Entries without port tokens default to DEFAULTPORT."
866 (let ((rest list)
867 result)
868 (while list
869 (when (equal (cdr (assoc "machine" (car list))) machine)
870 (push (car list) result))
929 (pop list)) 871 (pop list))
930 (car (or list 872 (unless result
931 (progn (while (and rest (not (assoc "default" (car rest)))) 873 ;; No machine name matches, so we look for default entries.
932 (pop rest)) 874 (while rest
933 rest))))) 875 (when (assoc "default" (car rest))
876 (push (car rest) result))
877 (pop rest)))
878 (when result
879 (setq result (nreverse result))
880 (while (and result
881 (not (equal (or port defaultport "nntp")
882 (or (gnus-netrc-get (car result) "port")
883 defaultport "nntp"))))
884 (pop result))
885 (car result))))
934 886
935(defun gnus-netrc-get (alist type) 887(defun gnus-netrc-get (alist type)
936 "Return the value of token TYPE from ALIST." 888 "Return the value of token TYPE from ALIST."
@@ -938,7 +890,7 @@ ARG is passed to the first function."
938 890
939;;; Various 891;;; Various
940 892
941(defvar gnus-group-buffer) ; Compiler directive 893(defvar gnus-group-buffer) ; Compiler directive
942(defun gnus-alive-p () 894(defun gnus-alive-p ()
943 "Say whether Gnus is running or not." 895 "Say whether Gnus is running or not."
944 (and (boundp 'gnus-group-buffer) 896 (and (boundp 'gnus-group-buffer)
@@ -971,11 +923,12 @@ ARG is passed to the first function."
971 (setq alist (delq entry alist))) 923 (setq alist (delq entry alist)))
972 alist)) 924 alist))
973 925
974(defmacro gnus-pull (key alist) 926(defmacro gnus-pull (key alist &optional assoc-p)
975 "Modify ALIST to be without KEY." 927 "Modify ALIST to be without KEY."
976 (unless (symbolp alist) 928 (unless (symbolp alist)
977 (error "Not a symbol: %s" alist)) 929 (error "Not a symbol: %s" alist))
978 `(setq ,alist (delq (assq ,key ,alist) ,alist))) 930 (let ((fun (if assoc-p 'assoc 'assq)))
931 `(setq ,alist (delq (,fun ,key ,alist) ,alist))))
979 932
980(defun gnus-globalify-regexp (re) 933(defun gnus-globalify-regexp (re)
981 "Returns a regexp that matches a whole line, iff RE matches a part of it." 934 "Returns a regexp that matches a whole line, iff RE matches a part of it."
@@ -983,6 +936,52 @@ ARG is passed to the first function."
983 re 936 re
984 (unless (string-match "\\$$" re) ".*$"))) 937 (unless (string-match "\\$$" re) ".*$")))
985 938
939(defun gnus-set-window-start (&optional point)
940 "Set the window start to POINT, or (point) if nil."
941 (let ((win (get-buffer-window (current-buffer) t)))
942 (when win
943 (set-window-start win (or point (point))))))
944
945(defun gnus-annotation-in-region-p (b e)
946 (if (= b e)
947 (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
948 (text-property-any b e 'gnus-undeletable t)))
949
950(defun gnus-or (&rest elems)
951 "Return non-nil if any of the elements are non-nil."
952 (catch 'found
953 (while elems
954 (when (pop elems)
955 (throw 'found t)))))
956
957(defun gnus-and (&rest elems)
958 "Return non-nil if all of the elements are non-nil."
959 (catch 'found
960 (while elems
961 (unless (pop elems)
962 (throw 'found nil)))
963 t))
964
965(defun gnus-write-active-file (file hashtb &optional full-names)
966 (let ((coding-system-for-write nnmail-active-file-coding-system))
967 (with-temp-file file
968 (mapatoms
969 (lambda (sym)
970 (when (and sym
971 (boundp sym)
972 (symbol-value sym))
973 (insert (format "%S %d %d y\n"
974 (if full-names
975 sym
976 (intern (gnus-group-real-name (symbol-name sym))))
977 (or (cdr (symbol-value sym))
978 (car (symbol-value sym)))
979 (car (symbol-value sym))))))
980 hashtb)
981 (goto-char (point-max))
982 (while (search-backward "\\." nil t)
983 (delete-char 1)))))
984
986(provide 'gnus-util) 985(provide 'gnus-util)
987 986
988;;; gnus-util.el ends here 987;;; gnus-util.el ends here
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 395a2085e00..848d7e47a7a 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -1,5 +1,8 @@
1;;; nnheader.el --- header access macros for Gnus and its backends 1;;; nnheader.el --- header access macros for Gnus and its backends
2;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc. 2
3;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
4;; 1997, 1998, 2000
5;; Free Software Foundation, Inc.
3 6
4;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 7;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5;; Lars Magne Ingebrigtsen <larsi@gnus.org> 8;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -24,24 +27,12 @@
24 27
25;;; Commentary: 28;;; Commentary:
26 29
27;; These macros may look very much like the ones in GNUS 4.1. They
28;; are, in a way, but you should note that the indices they use have
29;; been changed from the internal GNUS format to the NOV format. The
30;; makes it possible to read headers from XOVER much faster.
31;;
32;; The format of a header is now:
33;; [number subject from date id references chars lines xref]
34;;
35;; (That last entry is defined as "misc" in the NOV format, but Gnus
36;; uses it for xrefs.)
37
38;;; Code: 30;;; Code:
39 31
40(eval-when-compile (require 'cl)) 32(eval-when-compile (require 'cl))
41 33
42(eval-when-compile (require 'cl))
43
44(require 'mail-utils) 34(require 'mail-utils)
35(require 'mm-util)
45 36
46(defvar nnheader-max-head-length 4096 37(defvar nnheader-max-head-length 4096
47 "*Max length of the head of articles.") 38 "*Max length of the head of articles.")
@@ -51,23 +42,32 @@
51 42
52(defvar nnheader-file-name-translation-alist nil 43(defvar nnheader-file-name-translation-alist nil
53 "*Alist that says how to translate characters in file names. 44 "*Alist that says how to translate characters in file names.
54For instance, if \":\" is illegal as a file character in file names 45For instance, if \":\" is invalid as a file character in file names
55on your system, you could say something like: 46on your system, you could say something like:
56 47
57\(setq nnheader-file-name-translation-alist '((?: . ?_)))") 48\(setq nnheader-file-name-translation-alist '((?: . ?_)))")
58 49
59(eval-and-compile 50(eval-and-compile
60 (autoload 'nnmail-message-id "nnmail") 51 (autoload 'nnmail-message-id "nnmail")
61 (autoload 'mail-position-on-field "sendmail") 52 (autoload 'mail-position-on-field "sendmail")
62 (autoload 'message-remove-header "message") 53 (autoload 'message-remove-header "message")
63 (autoload 'cancel-function-timers "timers") 54 (autoload 'gnus-point-at-eol "gnus-util")
64 (autoload 'gnus-point-at-eol "gnus-util") 55 (autoload 'gnus-delete-line "gnus-util")
65 (autoload 'gnus-delete-line "gnus-util") 56 (autoload 'gnus-buffer-live-p "gnus-util"))
66 (autoload 'gnus-buffer-live-p "gnus-util")
67 (autoload 'gnus-encode-coding-string "gnus-ems"))
68 57
69;;; Header access macros. 58;;; Header access macros.
70 59
60;; These macros may look very much like the ones in GNUS 4.1. They
61;; are, in a way, but you should note that the indices they use have
62;; been changed from the internal GNUS format to the NOV format. The
63;; makes it possible to read headers from XOVER much faster.
64;;
65;; The format of a header is now:
66;; [number subject from date id references chars lines xref extra]
67;;
68;; (That next-to-last entry is defined as "misc" in the NOV format,
69;; but Gnus uses it for xrefs.)
70
71(defmacro mail-header-number (header) 71(defmacro mail-header-number (header)
72 "Return article number in HEADER." 72 "Return article number in HEADER."
73 `(aref ,header 0)) 73 `(aref ,header 0))
@@ -139,17 +139,26 @@ on your system, you could say something like:
139 `(aref ,header 8)) 139 `(aref ,header 8))
140 140
141(defmacro mail-header-set-xref (header xref) 141(defmacro mail-header-set-xref (header xref)
142 "Set article xref of HEADER to xref." 142 "Set article XREF of HEADER to xref."
143 `(aset ,header 8 ,xref)) 143 `(aset ,header 8 ,xref))
144 144
145(defun make-mail-header (&optional init) 145(defmacro mail-header-extra (header)
146 "Return the extra headers in HEADER."
147 `(aref ,header 9))
148
149(defmacro mail-header-set-extra (header extra)
150 "Set the extra headers in HEADER to EXTRA."
151 `(aset ,header 9 ',extra))
152
153(defsubst make-mail-header (&optional init)
146 "Create a new mail header structure initialized with INIT." 154 "Create a new mail header structure initialized with INIT."
147 (make-vector 9 init)) 155 (make-vector 10 init))
148 156
149(defun make-full-mail-header (&optional number subject from date id 157(defsubst make-full-mail-header (&optional number subject from date id
150 references chars lines xref) 158 references chars lines xref
159 extra)
151 "Create a new mail header structure initialized with the parameters given." 160 "Create a new mail header structure initialized with the parameters given."
152 (vector number subject from date id references chars lines xref)) 161 (vector number subject from date id references chars lines xref extra))
153 162
154;; fake message-ids: generation and detection 163;; fake message-ids: generation and detection
155 164
@@ -235,11 +244,12 @@ on your system, you could say something like:
235 ;; promising. 244 ;; promising.
236 (if (and (search-forward "\nin-reply-to: " nil t) 245 (if (and (search-forward "\nin-reply-to: " nil t)
237 (setq in-reply-to (nnheader-header-value)) 246 (setq in-reply-to (nnheader-header-value))
238 (string-match "<[^>]+>" in-reply-to)) 247 (string-match "<[^\n>]+>" in-reply-to))
239 (let (ref2) 248 (let (ref2)
240 (setq ref (substring in-reply-to (match-beginning 0) 249 (setq ref (substring in-reply-to (match-beginning 0)
241 (match-end 0))) 250 (match-end 0)))
242 (while (string-match "<[^>]+>" in-reply-to (match-end 0)) 251 (while (string-match "<[^\n>]+>"
252 in-reply-to (match-end 0))
243 (setq ref2 (substring in-reply-to (match-beginning 0) 253 (setq ref2 (substring in-reply-to (match-beginning 0)
244 (match-end 0))) 254 (match-end 0)))
245 (when (> (length ref2) (length ref)) 255 (when (> (length ref2) (length ref))
@@ -259,7 +269,20 @@ on your system, you could say something like:
259 (progn 269 (progn
260 (goto-char p) 270 (goto-char p)
261 (and (search-forward "\nxref: " nil t) 271 (and (search-forward "\nxref: " nil t)
262 (nnheader-header-value))))) 272 (nnheader-header-value)))
273
274 ;; Extra.
275 (when nnmail-extra-headers
276 (let ((extra nnmail-extra-headers)
277 out)
278 (while extra
279 (goto-char p)
280 (when (search-forward
281 (concat "\n" (symbol-name (car extra)) ": ") nil t)
282 (push (cons (car extra) (nnheader-header-value))
283 out))
284 (pop extra))
285 out))))
263 (when naked 286 (when naked
264 (goto-char (point-min)) 287 (goto-char (point-min))
265 (delete-char 1))))) 288 (delete-char 1)))))
@@ -272,13 +295,29 @@ on your system, you could say something like:
272 295
273(defmacro nnheader-nov-read-integer () 296(defmacro nnheader-nov-read-integer ()
274 '(prog1 297 '(prog1
275 (if (= (following-char) ?\t) 298 (if (eq (char-after) ?\t)
276 0 299 0
277 (let ((num (ignore-errors (read (current-buffer))))) 300 (let ((num (condition-case nil
301 (read (current-buffer))
302 (error nil))))
278 (if (numberp num) num 0))) 303 (if (numberp num) num 0)))
279 (or (eobp) (forward-char 1)))) 304 (or (eobp) (forward-char 1))))
280 305
281;; (defvar nnheader-none-counter 0) 306(defmacro nnheader-nov-parse-extra ()
307 '(let (out string)
308 (while (not (memq (char-after) '(?\n nil)))
309 (setq string (nnheader-nov-field))
310 (when (string-match "^\\([^ :]+\\): " string)
311 (push (cons (intern (match-string 1 string))
312 (substring string (match-end 0)))
313 out)))
314 out))
315
316(defmacro nnheader-nov-read-message-id ()
317 '(let ((id (nnheader-nov-field)))
318 (if (string-match "^<[^>]+>$" id)
319 id
320 (nnheader-generate-fake-message-id))))
282 321
283(defun nnheader-parse-nov () 322(defun nnheader-parse-nov ()
284 (let ((eol (gnus-point-at-eol))) 323 (let ((eol (gnus-point-at-eol)))
@@ -287,34 +326,60 @@ on your system, you could say something like:
287 (nnheader-nov-field) ; subject 326 (nnheader-nov-field) ; subject
288 (nnheader-nov-field) ; from 327 (nnheader-nov-field) ; from
289 (nnheader-nov-field) ; date 328 (nnheader-nov-field) ; date
290 (or (nnheader-nov-field) 329 (nnheader-nov-read-message-id) ; id
291 (nnheader-generate-fake-message-id)) ; id
292 (nnheader-nov-field) ; refs 330 (nnheader-nov-field) ; refs
293 (nnheader-nov-read-integer) ; chars 331 (nnheader-nov-read-integer) ; chars
294 (nnheader-nov-read-integer) ; lines 332 (nnheader-nov-read-integer) ; lines
295 (if (= (following-char) ?\n) 333 (if (eq (char-after) ?\n)
296 nil 334 nil
297 (nnheader-nov-field)) ; misc 335 (if (looking-at "Xref: ")
298 ))) 336 (goto-char (match-end 0)))
337 (nnheader-nov-field)) ; Xref
338 (nnheader-nov-parse-extra)))) ; extra
299 339
300(defun nnheader-insert-nov (header) 340(defun nnheader-insert-nov (header)
301 (princ (mail-header-number header) (current-buffer)) 341 (princ (mail-header-number header) (current-buffer))
342 (let ((p (point)))
343 (insert
344 "\t"
345 (or (mail-header-subject header) "(none)") "\t"
346 (or (mail-header-from header) "(nobody)") "\t"
347 (or (mail-header-date header) "") "\t"
348 (or (mail-header-id header)
349 (nnmail-message-id))
350 "\t"
351 (or (mail-header-references header) "") "\t")
352 (princ (or (mail-header-chars header) 0) (current-buffer))
353 (insert "\t")
354 (princ (or (mail-header-lines header) 0) (current-buffer))
355 (insert "\t")
356 (when (mail-header-xref header)
357 (insert "Xref: " (mail-header-xref header)))
358 (when (or (mail-header-xref header)
359 (mail-header-extra header))
360 (insert "\t"))
361 (when (mail-header-extra header)
362 (let ((extra (mail-header-extra header)))
363 (while extra
364 (insert (symbol-name (caar extra))
365 ": " (cdar extra) "\t")
366 (pop extra))))
367 (insert "\n")
368 (backward-char 1)
369 (while (search-backward "\n" p t)
370 (delete-char 1))
371 (forward-line 1)))
372
373(defun nnheader-insert-header (header)
302 (insert 374 (insert
303 "\t" 375 "Subject: " (or (mail-header-subject header) "(none)") "\n"
304 (or (mail-header-subject header) "(none)") "\t" 376 "From: " (or (mail-header-from header) "(nobody)") "\n"
305 (or (mail-header-from header) "(nobody)") "\t" 377 "Date: " (or (mail-header-date header) "") "\n"
306 (or (mail-header-date header) "") "\t" 378 "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
307 (or (mail-header-id header) 379 "References: " (or (mail-header-references header) "") "\n"
308 (nnmail-message-id)) 380 "Lines: ")
309 "\t"
310 (or (mail-header-references header) "") "\t")
311 (princ (or (mail-header-chars header) 0) (current-buffer))
312 (insert "\t")
313 (princ (or (mail-header-lines header) 0) (current-buffer)) 381 (princ (or (mail-header-lines header) 0) (current-buffer))
314 (insert "\t") 382 (insert "\n\n"))
315 (when (mail-header-xref header)
316 (insert "Xref: " (mail-header-xref header) "\t"))
317 (insert "\n"))
318 383
319(defun nnheader-insert-article-line (article) 384(defun nnheader-insert-article-line (article)
320 (goto-char (point-min)) 385 (goto-char (point-min))
@@ -401,6 +466,7 @@ the line could be found."
401 (save-excursion 466 (save-excursion
402 (unless (gnus-buffer-live-p nntp-server-buffer) 467 (unless (gnus-buffer-live-p nntp-server-buffer)
403 (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) 468 (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
469 (mm-enable-multibyte)
404 (set-buffer nntp-server-buffer) 470 (set-buffer nntp-server-buffer)
405 (erase-buffer) 471 (erase-buffer)
406 (kill-all-local-variables) 472 (kill-all-local-variables)
@@ -447,7 +513,7 @@ the line could be found."
447 nil 513 nil
448 (narrow-to-region (point-min) (1- (point))) 514 (narrow-to-region (point-min) (1- (point)))
449 (goto-char (point-min)) 515 (goto-char (point-min))
450 (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n") 516 (while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
451 (goto-char (match-end 0))) 517 (goto-char (match-end 0)))
452 (prog1 518 (prog1
453 (eobp) 519 (eobp)
@@ -456,7 +522,8 @@ the line could be found."
456(defun nnheader-insert-references (references message-id) 522(defun nnheader-insert-references (references message-id)
457 "Insert a References header based on REFERENCES and MESSAGE-ID." 523 "Insert a References header based on REFERENCES and MESSAGE-ID."
458 (if (and (not references) (not message-id)) 524 (if (and (not references) (not message-id))
459 () ; This is illegal, but not all articles have Message-IDs. 525 ;; This is invalid, but not all articles have Message-IDs.
526 ()
460 (mail-position-on-field "References") 527 (mail-position-on-field "References")
461 (let ((begin (save-excursion (beginning-of-line) (point))) 528 (let ((begin (save-excursion (beginning-of-line) (point)))
462 (fill-column 78) 529 (fill-column 78)
@@ -495,58 +562,12 @@ the line could be found."
495(defun nnheader-set-temp-buffer (name &optional noerase) 562(defun nnheader-set-temp-buffer (name &optional noerase)
496 "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." 563 "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
497 (set-buffer (get-buffer-create name)) 564 (set-buffer (get-buffer-create name))
498 (buffer-disable-undo (current-buffer)) 565 (buffer-disable-undo)
499 (unless noerase 566 (unless noerase
500 (erase-buffer)) 567 (erase-buffer))
501 (current-buffer)) 568 (current-buffer))
502 569
503(defmacro nnheader-temp-write (file &rest forms) 570(eval-when-compile (defvar jka-compr-compression-info-list))
504 "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
505Return the value of FORMS.
506If FILE is nil, just evaluate FORMS and don't save anything.
507If FILE is t, return the buffer contents as a string."
508 (let ((temp-file (make-symbol "temp-file"))
509 (temp-buffer (make-symbol "temp-buffer"))
510 (temp-results (make-symbol "temp-results")))
511 `(save-excursion
512 (let* ((,temp-file ,file)
513 (default-major-mode 'fundamental-mode)
514 (,temp-buffer
515 (set-buffer
516 (get-buffer-create
517 (generate-new-buffer-name " *nnheader temp*"))))
518 ,temp-results)
519 (unwind-protect
520 (progn
521 (setq ,temp-results (progn ,@forms))
522 (cond
523 ;; Don't save anything.
524 ((null ,temp-file)
525 ,temp-results)
526 ;; Return the buffer contents.
527 ((eq ,temp-file t)
528 (set-buffer ,temp-buffer)
529 (buffer-string))
530 ;; Save a file.
531 (t
532 (set-buffer ,temp-buffer)
533 ;; Make sure the directory where this file is
534 ;; to be saved exists.
535 (when (not (file-directory-p
536 (file-name-directory ,temp-file)))
537 (make-directory (file-name-directory ,temp-file) t))
538 ;; Save the file.
539 (write-region (point-min) (point-max)
540 ,temp-file nil 'nomesg)
541 ,temp-results)))
542 ;; Kill the buffer.
543 (when (buffer-name ,temp-buffer)
544 (kill-buffer ,temp-buffer)))))))
545
546(put 'nnheader-temp-write 'lisp-indent-function 1)
547(put 'nnheader-temp-write 'edebug-form-spec '(form body))
548
549(defvar jka-compr-compression-info-list)
550(defvar nnheader-numerical-files 571(defvar nnheader-numerical-files
551 (if (boundp 'jka-compr-compression-info-list) 572 (if (boundp 'jka-compr-compression-info-list)
552 (concat "\\([0-9]+\\)\\(" 573 (concat "\\([0-9]+\\)\\("
@@ -563,7 +584,7 @@ If FILE is t, return the buffer contents as a string."
563 "Regexp that matches numerical full file paths.") 584 "Regexp that matches numerical full file paths.")
564 585
565(defsubst nnheader-file-to-number (file) 586(defsubst nnheader-file-to-number (file)
566 "Take a file name and return the article number." 587 "Take a FILE name and return the article number."
567 (if (string= nnheader-numerical-short-files "^[0-9]+$") 588 (if (string= nnheader-numerical-short-files "^[0-9]+$")
568 (string-to-int file) 589 (string-to-int file)
569 (string-match nnheader-numerical-short-files file) 590 (string-match nnheader-numerical-short-files file)
@@ -581,7 +602,7 @@ If FILE is t, return the buffer contents as a string."
581 second))) 602 second)))
582 603
583(defun nnheader-directory-articles (dir) 604(defun nnheader-directory-articles (dir)
584 "Return a list of all article files in a directory." 605 "Return a list of all article files in directory DIR."
585 (mapcar 'nnheader-file-to-number 606 (mapcar 'nnheader-file-to-number
586 (nnheader-directory-files-safe 607 (nnheader-directory-files-safe
587 dir nil nnheader-numerical-short-files t))) 608 dir nil nnheader-numerical-short-files t)))
@@ -607,7 +628,9 @@ If FULL, translate everything."
607 (if full 628 (if full
608 ;; Do complete translation. 629 ;; Do complete translation.
609 (setq leaf (copy-sequence file) 630 (setq leaf (copy-sequence file)
610 path "") 631 path ""
632 i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1)))
633 2 0))
611 ;; We translate -- but only the file name. We leave the directory 634 ;; We translate -- but only the file name. We leave the directory
612 ;; alone. 635 ;; alone.
613 (if (string-match "/[^/]+\\'" file) 636 (if (string-match "/[^/]+\\'" file)
@@ -638,7 +661,7 @@ The first string in ARGS can be a format string."
638 "Get the most recent report from BACKEND." 661 "Get the most recent report from BACKEND."
639 (condition-case () 662 (condition-case ()
640 (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" 663 (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
641 backend)))) 664 backend))))
642 (error (nnheader-message 5 "")))) 665 (error (nnheader-message 5 ""))))
643 666
644(defun nnheader-insert (format &rest args) 667(defun nnheader-insert (format &rest args)
@@ -653,15 +676,33 @@ without formatting."
653 (apply 'insert format args)) 676 (apply 'insert format args))
654 t)) 677 t))
655 678
656(defun nnheader-replace-chars-in-string (string from to) 679(if (fboundp 'subst-char-in-string)
680 (defsubst nnheader-replace-chars-in-string (string from to)
681 (subst-char-in-string from to string))
682 (defun nnheader-replace-chars-in-string (string from to)
683 "Replace characters in STRING from FROM to TO."
684 (let ((string (substring string 0)) ;Copy string.
685 (len (length string))
686 (idx 0))
687 ;; Replace all occurrences of FROM with TO.
688 (while (< idx len)
689 (when (= (aref string idx) from)
690 (aset string idx to))
691 (setq idx (1+ idx)))
692 string)))
693
694(defun nnheader-replace-duplicate-chars-in-string (string from to)
657 "Replace characters in STRING from FROM to TO." 695 "Replace characters in STRING from FROM to TO."
658 (let ((string (substring string 0)) ;Copy string. 696 (let ((string (substring string 0)) ;Copy string.
659 (len (length string)) 697 (len (length string))
660 (idx 0)) 698 (idx 0) prev i)
661 ;; Replace all occurrences of FROM with TO. 699 ;; Replace all occurrences of FROM with TO.
662 (while (< idx len) 700 (while (< idx len)
663 (when (= (aref string idx) from) 701 (setq i (aref string idx))
702 (when (and (eq prev from) (= i from))
703 (aset string (1- idx) to)
664 (aset string idx to)) 704 (aset string idx to))
705 (setq prev i)
665 (setq idx (1+ idx))) 706 (setq idx (1+ idx)))
666 string)) 707 string))
667 708
@@ -690,12 +731,7 @@ without formatting."
690 (or (not (numberp gnus-verbose-backends)) 731 (or (not (numberp gnus-verbose-backends))
691 (<= level gnus-verbose-backends))) 732 (<= level gnus-verbose-backends)))
692 733
693(defvar nnheader-pathname-coding-system 'iso-8859-1 734(defvar nnheader-pathname-coding-system 'binary
694 "*Coding system for pathname.")
695
696;; 1997/8/10 by MORIOKA Tomohiko
697(defvar nnheader-pathname-coding-system
698 'iso-8859-1
699 "*Coding system for pathname.") 735 "*Coding system for pathname.")
700 736
701(defun nnheader-group-pathname (group dir &optional file) 737(defun nnheader-group-pathname (group dir &optional file)
@@ -703,14 +739,14 @@ without formatting."
703 (concat 739 (concat
704 (let ((dir (file-name-as-directory (expand-file-name dir)))) 740 (let ((dir (file-name-as-directory (expand-file-name dir))))
705 ;; If this directory exists, we use it directly. 741 ;; If this directory exists, we use it directly.
706 (if (file-directory-p (concat dir group)) 742 (file-name-as-directory
707 (concat dir group "/") 743 (if (file-directory-p (concat dir group))
708 ;; If not, we translate dots into slashes. 744 (expand-file-name group dir)
709 (concat dir 745 ;; If not, we translate dots into slashes.
710 (gnus-encode-coding-string 746 (expand-file-name (mm-encode-coding-string
711 (nnheader-replace-chars-in-string group ?. ?/) 747 (nnheader-replace-chars-in-string group ?. ?/)
712 nnheader-pathname-coding-system) 748 nnheader-pathname-coding-system)
713 "/"))) 749 dir))))
714 (cond ((null file) "") 750 (cond ((null file) "")
715 ((numberp file) (int-to-string file)) 751 ((numberp file) (int-to-string file))
716 (t file)))) 752 (t file))))
@@ -721,7 +757,7 @@ without formatting."
721 (and (listp form) (eq (car form) 'lambda)))) 757 (and (listp form) (eq (car form) 'lambda))))
722 758
723(defun nnheader-concat (dir &rest files) 759(defun nnheader-concat (dir &rest files)
724 "Concat DIR as directory to FILE." 760 "Concat DIR as directory to FILES."
725 (apply 'concat (file-name-as-directory dir) files)) 761 (apply 'concat (file-name-as-directory dir) files))
726 762
727(defun nnheader-ms-strip-cr () 763(defun nnheader-ms-strip-cr ()
@@ -770,45 +806,26 @@ If FILE, find the \".../etc/PACKAGE\" file instead."
770(defvar nnheader-file-coding-system 'raw-text 806(defvar nnheader-file-coding-system 'raw-text
771 "Coding system used in file backends of Gnus.") 807 "Coding system used in file backends of Gnus.")
772 808
773;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
774(defvar nnheader-file-coding-system nil
775 "Coding system used in file backends of Gnus.")
776
777(defun nnheader-insert-file-contents (filename &optional visit beg end replace) 809(defun nnheader-insert-file-contents (filename &optional visit beg end replace)
778 "Like `insert-file-contents', q.v., but only reads in the file. 810 "Like `insert-file-contents', q.v., but only reads in the file.
779A buffer may be modified in several ways after reading into the buffer due 811A buffer may be modified in several ways after reading into the buffer due
780to advanced Emacs features, such as file-name-handlers, format decoding, 812to advanced Emacs features, such as file-name-handlers, format decoding,
781find-file-hooks, etc. 813find-file-hooks, etc.
782 This function ensures that none of these modifications will take place." 814 This function ensures that none of these modifications will take place."
783 (let ((format-alist nil) 815 (let ((coding-system-for-read nnheader-file-coding-system))
784 (auto-mode-alist (nnheader-auto-mode-alist)) 816 (mm-insert-file-contents filename visit beg end replace)))
785 (default-major-mode 'fundamental-mode)
786 (enable-local-variables nil)
787 (after-insert-file-functions nil)
788 (find-file-hooks nil)
789 (coding-system-for-read nnheader-file-coding-system))
790 (insert-file-contents filename visit beg end replace)))
791 817
792(defun nnheader-find-file-noselect (&rest args) 818(defun nnheader-find-file-noselect (&rest args)
793 (let ((format-alist nil) 819 (let ((format-alist nil)
794 (auto-mode-alist (nnheader-auto-mode-alist)) 820 (auto-mode-alist (mm-auto-mode-alist))
795 (default-major-mode 'fundamental-mode) 821 (default-major-mode 'fundamental-mode)
796 (enable-local-variables nil) 822 (enable-local-variables nil)
797 (after-insert-file-functions nil) 823 (after-insert-file-functions nil)
824 (enable-local-eval nil)
798 (find-file-hooks nil) 825 (find-file-hooks nil)
799 (coding-system-for-read nnheader-file-coding-system)) 826 (coding-system-for-read nnheader-file-coding-system))
800 (apply 'find-file-noselect args))) 827 (apply 'find-file-noselect args)))
801 828
802(defun nnheader-auto-mode-alist ()
803 "Return an `auto-mode-alist' with only the .gz (etc) thingies."
804 (let ((alist auto-mode-alist)
805 out)
806 (while alist
807 (when (listp (cdar alist))
808 (push (car alist) out))
809 (pop alist))
810 (nreverse out)))
811
812(defun nnheader-directory-regular-files (dir) 829(defun nnheader-directory-regular-files (dir)
813 "Return a list of all regular files in DIR." 830 "Return a list of all regular files in DIR."
814 (let ((files (directory-files dir t)) 831 (let ((files (directory-files dir t))
@@ -833,8 +850,6 @@ find-file-hooks, etc.
833 `(let ((new (generate-new-buffer " *nnheader replace*")) 850 `(let ((new (generate-new-buffer " *nnheader replace*"))
834 (cur (current-buffer)) 851 (cur (current-buffer))
835 (start (point-min))) 852 (start (point-min)))
836 (set-buffer new)
837 (buffer-disable-undo (current-buffer))
838 (set-buffer cur) 853 (set-buffer cur)
839 (goto-char (point-min)) 854 (goto-char (point-min))
840 (while (,(if regexp 're-search-forward 'search-forward) 855 (while (,(if regexp 're-search-forward 'search-forward)
@@ -852,22 +867,22 @@ find-file-hooks, etc.
852 (set-buffer cur))) 867 (set-buffer cur)))
853 868
854(defun nnheader-replace-string (from to) 869(defun nnheader-replace-string (from to)
855 "Do a fast replacement of FROM to TO from point to point-max." 870 "Do a fast replacement of FROM to TO from point to `point-max'."
856 (nnheader-skeleton-replace from to)) 871 (nnheader-skeleton-replace from to))
857 872
858(defun nnheader-replace-regexp (from to) 873(defun nnheader-replace-regexp (from to)
859 "Do a fast regexp replacement of FROM to TO from point to point-max." 874 "Do a fast regexp replacement of FROM to TO from point to `point-max'."
860 (nnheader-skeleton-replace from to t)) 875 (nnheader-skeleton-replace from to t))
861 876
862(defun nnheader-strip-cr () 877(defun nnheader-strip-cr ()
863 "Strip all \r's from the current buffer." 878 "Strip all \r's from the current buffer."
864 (nnheader-skeleton-replace "\r")) 879 (nnheader-skeleton-replace "\r"))
865 880
866(fset 'nnheader-run-at-time 'run-at-time) 881(defalias 'nnheader-run-at-time 'run-at-time)
867(fset 'nnheader-cancel-timer 'cancel-timer) 882(defalias 'nnheader-cancel-timer 'cancel-timer)
868(fset 'nnheader-cancel-function-timers 'cancel-function-timers) 883(defalias 'nnheader-cancel-function-timers 'cancel-function-timers)
869 884
870(when (string-match "XEmacs\\|Lucid" emacs-version) 885(when (string-match "XEmacs" emacs-version)
871 (require 'nnheaderxm)) 886 (require 'nnheaderxm))
872 887
873(run-hooks 'nnheader-load-hook) 888(run-hooks 'nnheader-load-hook)
diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el
index c47a10d3911..d93800a5b97 100644
--- a/lisp/gnus/nnkiboze.el
+++ b/lisp/gnus/nnkiboze.el
@@ -1,5 +1,7 @@
1;;; nnkiboze.el --- select virtual news access for Gnus 1;;; nnkiboze.el --- select virtual news access for Gnus
2;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. 2
3;; Copyright (C) 1995, 1996, 1997, 1998, 1999,.2000
4;; Free Software Foundation, Inc.
3 5
4;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5;; Keywords: news 7;; Keywords: news
@@ -34,6 +36,7 @@
34(require 'gnus) 36(require 'gnus)
35(require 'gnus-score) 37(require 'gnus-score)
36(require 'nnoo) 38(require 'nnoo)
39(require 'mm-util)
37(eval-when-compile (require 'cl)) 40(eval-when-compile (require 'cl))
38 41
39(nnoo-declare nnkiboze) 42(nnoo-declare nnkiboze)
@@ -55,6 +58,9 @@
55(defvoo nnkiboze-regexp nil 58(defvoo nnkiboze-regexp nil
56 "Regexp for matching component groups.") 59 "Regexp for matching component groups.")
57 60
61(defvoo nnkiboze-file-coding-system mm-text-coding-system
62 "Coding system for nnkiboze files.")
63
58 64
59 65
60(defconst nnkiboze-version "nnkiboze 1.0") 66(defconst nnkiboze-version "nnkiboze 1.0")
@@ -80,7 +86,8 @@
80 (save-excursion 86 (save-excursion
81 (set-buffer nntp-server-buffer) 87 (set-buffer nntp-server-buffer)
82 (erase-buffer) 88 (erase-buffer)
83 (nnheader-insert-file-contents nov) 89 (let ((nnheader-file-coding-system nnkiboze-file-coding-system))
90 (nnheader-insert-file-contents nov))
84 (nnheader-nov-delete-outside-range 91 (nnheader-nov-delete-outside-range
85 (car articles) (car (last articles))) 92 (car articles) (car (last articles)))
86 'nov)))))) 93 'nov))))))
@@ -119,7 +126,8 @@
119 (nnkiboze-request-scan group)) 126 (nnkiboze-request-scan group))
120 (if (not (file-exists-p nov-file)) 127 (if (not (file-exists-p nov-file))
121 (nnheader-report 'nnkiboze "Can't select group %s" group) 128 (nnheader-report 'nnkiboze "Can't select group %s" group)
122 (nnheader-insert-file-contents nov-file) 129 (let ((nnheader-file-coding-system nnkiboze-file-coding-system))
130 (nnheader-insert-file-contents nov-file))
123 (if (zerop (buffer-size)) 131 (if (zerop (buffer-size))
124 (nnheader-insert "211 0 0 0 %s\n" group) 132 (nnheader-insert "211 0 0 0 %s\n" group)
125 (goto-char (point-min)) 133 (goto-char (point-min))
@@ -136,15 +144,17 @@
136 ;; Remove NOV lines of articles that are marked as read. 144 ;; Remove NOV lines of articles that are marked as read.
137 (when (and (file-exists-p (nnkiboze-nov-file-name)) 145 (when (and (file-exists-p (nnkiboze-nov-file-name))
138 nnkiboze-remove-read-articles) 146 nnkiboze-remove-read-articles)
139 (nnheader-temp-write (nnkiboze-nov-file-name) 147 (let ((coding-system-for-write nnkiboze-file-coding-system))
140 (let ((cur (current-buffer))) 148 (with-temp-file (nnkiboze-nov-file-name)
141 (nnheader-insert-file-contents (nnkiboze-nov-file-name)) 149 (let ((cur (current-buffer))
142 (goto-char (point-min)) 150 (nnheader-file-coding-system nnkiboze-file-coding-system))
143 (while (not (eobp)) 151 (nnheader-insert-file-contents (nnkiboze-nov-file-name))
144 (if (not (gnus-article-read-p (read cur))) 152 (goto-char (point-min))
145 (forward-line 1) 153 (while (not (eobp))
146 (gnus-delete-line)))))) 154 (if (not (gnus-article-read-p (read cur)))
147 (setq nnkiboze-current-group nil)) 155 (forward-line 1)
156 (gnus-delete-line))))))
157 (setq nnkiboze-current-group nil)))
148 158
149(deffoo nnkiboze-open-server (server &optional defs) 159(deffoo nnkiboze-open-server (server &optional defs)
150 (unless (assq 'nnkiboze-regexp defs) 160 (unless (assq 'nnkiboze-regexp defs)
@@ -155,15 +165,15 @@
155(deffoo nnkiboze-request-delete-group (group &optional force server) 165(deffoo nnkiboze-request-delete-group (group &optional force server)
156 (nnkiboze-possibly-change-group group) 166 (nnkiboze-possibly-change-group group)
157 (when force 167 (when force
158 (let ((files (nconc 168 (let ((files (nconc
159 (nnkiboze-score-file group) 169 (nnkiboze-score-file group)
160 (list (nnkiboze-nov-file-name) 170 (list (nnkiboze-nov-file-name)
161 (nnkiboze-nov-file-name ".newsrc"))))) 171 (nnkiboze-nov-file-name ".newsrc")))))
162 (while files 172 (while files
163 (and (file-exists-p (car files)) 173 (and (file-exists-p (car files))
164 (file-writable-p (car files)) 174 (file-writable-p (car files))
165 (delete-file (car files))) 175 (delete-file (car files)))
166 (setq files (cdr files))))) 176 (setq files (cdr files)))))
167 (setq nnkiboze-current-group nil) 177 (setq nnkiboze-current-group nil)
168 t) 178 t)
169 179
@@ -184,6 +194,7 @@
184Finds out what articles are to be part of the nnkiboze groups." 194Finds out what articles are to be part of the nnkiboze groups."
185 (interactive) 195 (interactive)
186 (let ((nnmail-spool-file nil) 196 (let ((nnmail-spool-file nil)
197 (mail-sources nil)
187 (gnus-use-dribble-file nil) 198 (gnus-use-dribble-file nil)
188 (gnus-read-active-file t) 199 (gnus-read-active-file t)
189 (gnus-expert-user t)) 200 (gnus-expert-user t))
@@ -209,7 +220,7 @@ Finds out what articles are to be part of the nnkiboze groups."
209 220
210(defun nnkiboze-generate-group (group) 221(defun nnkiboze-generate-group (group)
211 (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) 222 (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
212 (newsrc-file (concat nnkiboze-directory 223 (newsrc-file (concat nnkiboze-directory
213 (nnheader-translate-file-chars 224 (nnheader-translate-file-chars
214 (concat group ".newsrc")))) 225 (concat group ".newsrc"))))
215 (nov-file (concat nnkiboze-directory 226 (nov-file (concat nnkiboze-directory
@@ -230,95 +241,96 @@ Finds out what articles are to be part of the nnkiboze groups."
230 ;; Load the kiboze newsrc file for this group. 241 ;; Load the kiboze newsrc file for this group.
231 (when (file-exists-p newsrc-file) 242 (when (file-exists-p newsrc-file)
232 (load newsrc-file)) 243 (load newsrc-file))
233 (nnheader-temp-write nov-file 244 (let ((coding-system-for-write nnkiboze-file-coding-system))
234 (when (file-exists-p nov-file) 245 (with-temp-file nov-file
235 (insert-file-contents nov-file)) 246 (when (file-exists-p nov-file)
236 (setq nov-buffer (current-buffer)) 247 (insert-file-contents nov-file))
237 ;; Go through the active hashtb and add new all groups that match the 248 (setq nov-buffer (current-buffer))
238 ;; kiboze regexp. 249 ;; Go through the active hashtb and add new all groups that match the
239 (mapatoms 250 ;; kiboze regexp.
240 (lambda (group) 251 (mapatoms
241 (and (string-match nnkiboze-regexp 252 (lambda (group)
242 (setq gname (symbol-name group))) ; Match 253 (and (string-match nnkiboze-regexp
243 (not (assoc gname nnkiboze-newsrc)) ; It isn't registered 254 (setq gname (symbol-name group))) ; Match
244 (numberp (car (symbol-value group))) ; It is active 255 (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
245 (or (> nnkiboze-level 7) 256 (numberp (car (symbol-value group))) ; It is active
246 (and (setq glevel (nth 1 (nth 2 (gnus-gethash 257 (or (> nnkiboze-level 7)
247 gname gnus-newsrc-hashtb)))) 258 (and (setq glevel (nth 1 (nth 2 (gnus-gethash
248 (>= nnkiboze-level glevel))) 259 gname gnus-newsrc-hashtb))))
249 (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes 260 (>= nnkiboze-level glevel)))
250 (push (cons gname (1- (car (symbol-value group)))) 261 (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes
251 nnkiboze-newsrc))) 262 (push (cons gname (1- (car (symbol-value group))))
252 gnus-active-hashtb) 263 nnkiboze-newsrc)))
253 ;; `newsrc' is set to the list of groups that possibly are 264 gnus-active-hashtb)
254 ;; component groups to this kiboze group. This list has elements 265 ;; `newsrc' is set to the list of groups that possibly are
255 ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest 266 ;; component groups to this kiboze group. This list has elements
256 ;; number that has been kibozed in GROUP in this kiboze group. 267 ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest
257 (setq newsrc nnkiboze-newsrc) 268 ;; number that has been kibozed in GROUP in this kiboze group.
258 (while newsrc 269 (setq newsrc nnkiboze-newsrc)
259 (if (not (setq active (gnus-gethash 270 (while newsrc
260 (caar newsrc) gnus-active-hashtb))) 271 (if (not (setq active (gnus-gethash
261 ;; This group isn't active after all, so we remove it from 272 (caar newsrc) gnus-active-hashtb)))
262 ;; the list of component groups. 273 ;; This group isn't active after all, so we remove it from
263 (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) 274 ;; the list of component groups.
264 (setq lowest (cdar newsrc)) 275 (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
265 ;; Ok, we have a valid component group, so we jump to it. 276 (setq lowest (cdar newsrc))
266 (switch-to-buffer gnus-group-buffer) 277 ;; Ok, we have a valid component group, so we jump to it.
267 (gnus-group-jump-to-group (caar newsrc)) 278 (switch-to-buffer gnus-group-buffer)
268 (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) 279 (gnus-group-jump-to-group (caar newsrc))
269 (setq ginfo (gnus-get-info (gnus-group-group-name)) 280 (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc))
270 orig-info (gnus-copy-sequence ginfo) 281 (setq ginfo (gnus-get-info (gnus-group-group-name))
271 num-unread (car (gnus-gethash (caar newsrc) 282 orig-info (gnus-copy-sequence ginfo)
272 gnus-newsrc-hashtb))) 283 num-unread (car (gnus-gethash (caar newsrc)
273 (unwind-protect 284 gnus-newsrc-hashtb)))
274 (progn 285 (unwind-protect
275 ;; We set all list of article marks to nil. Since we operate 286 (progn
276 ;; on copies of the real lists, we can destroy anything we 287 ;; We set all list of article marks to nil. Since we operate
277 ;; want here. 288 ;; on copies of the real lists, we can destroy anything we
278 (when (nth 3 ginfo) 289 ;; want here.
279 (setcar (nthcdr 3 ginfo) nil)) 290 (when (nth 3 ginfo)
280 ;; We set the list of read articles to be what we expect for 291 (setcar (nthcdr 3 ginfo) nil))
281 ;; this kiboze group -- either nil or `(1 . LOWEST)'. 292 ;; We set the list of read articles to be what we expect for
282 (when ginfo 293 ;; this kiboze group -- either nil or `(1 . LOWEST)'.
283 (setcar (nthcdr 2 ginfo) 294 (when ginfo
284 (and (not (= lowest 1)) (cons 1 lowest)))) 295 (setcar (nthcdr 2 ginfo)
285 (when (and (or (not ginfo) 296 (and (not (= lowest 1)) (cons 1 lowest))))
286 (> (length (gnus-list-of-unread-articles 297 (when (and (or (not ginfo)
287 (car ginfo))) 298 (> (length (gnus-list-of-unread-articles
288 0)) 299 (car ginfo)))
289 (progn 300 0))
290 (ignore-errors 301 (progn
291 (gnus-group-select-group nil)) 302 (ignore-errors
292 (eq major-mode 'gnus-summary-mode))) 303 (gnus-group-select-group nil))
293 ;; We are now in the group where we want to be. 304 (eq major-mode 'gnus-summary-mode)))
294 (setq method (gnus-find-method-for-group 305 ;; We are now in the group where we want to be.
295 gnus-newsgroup-name)) 306 (setq method (gnus-find-method-for-group
296 (when (eq method gnus-select-method) 307 gnus-newsgroup-name))
297 (setq method nil)) 308 (when (eq method gnus-select-method)
298 ;; We go through the list of scored articles. 309 (setq method nil))
299 (while gnus-newsgroup-scored 310 ;; We go through the list of scored articles.
300 (when (> (caar gnus-newsgroup-scored) lowest) 311 (while gnus-newsgroup-scored
301 ;; If it has a good score, then we enter this article 312 (when (> (caar gnus-newsgroup-scored) lowest)
302 ;; into the kiboze group. 313 ;; If it has a good score, then we enter this article
303 (nnkiboze-enter-nov 314 ;; into the kiboze group.
304 nov-buffer 315 (nnkiboze-enter-nov
305 (gnus-summary-article-header 316 nov-buffer
306 (caar gnus-newsgroup-scored)) 317 (gnus-summary-article-header
307 gnus-newsgroup-name)) 318 (caar gnus-newsgroup-scored))
308 (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) 319 gnus-newsgroup-name))
309 ;; That's it. We exit this group. 320 (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
310 (when (eq major-mode 'gnus-summary-mode) 321 ;; That's it. We exit this group.
311 (kill-buffer (current-buffer))))) 322 (when (eq major-mode 'gnus-summary-mode)
312 ;; Restore the proper info. 323 (kill-buffer (current-buffer)))))
313 (when ginfo 324 ;; Restore the proper info.
314 (setcdr ginfo (cdr orig-info))) 325 (when ginfo
315 (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) 326 (setcdr ginfo (cdr orig-info)))
316 num-unread))) 327 (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb)
317 (setcdr (car newsrc) (car active)) 328 num-unread)))
318 (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) 329 (setcdr (car newsrc) (car active))
319 (setq newsrc (cdr newsrc)))) 330 (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc))
331 (setq newsrc (cdr newsrc)))))
320 ;; We save the kiboze newsrc for this group. 332 ;; We save the kiboze newsrc for this group.
321 (nnheader-temp-write newsrc-file 333 (with-temp-file newsrc-file
322 (insert "(setq nnkiboze-newsrc '") 334 (insert "(setq nnkiboze-newsrc '")
323 (gnus-prin1 nnkiboze-newsrc) 335 (gnus-prin1 nnkiboze-newsrc)
324 (insert ")\n"))) 336 (insert ")\n")))
@@ -340,19 +352,22 @@ Finds out what articles are to be part of the nnkiboze groups."
340 (forward-line 1)) 352 (forward-line 1))
341 (setq article 1)) 353 (setq article 1))
342 (mail-header-set-number oheader article) 354 (mail-header-set-number oheader article)
343 (nnheader-insert-nov oheader) 355 (with-temp-buffer
344 (search-backward "\t" nil t 2) 356 (insert (mail-header-xref oheader))
345 (if (re-search-forward " [^ ]+:[0-9]+" nil t) 357 (goto-char (point-min))
346 (goto-char (match-beginning 0)) 358 (if (re-search-forward " [^ ]+:[0-9]+" nil t)
359 (goto-char (match-beginning 0))
347 (forward-char 1)) 360 (forward-char 1))
348 ;; The first Xref has to be the group this article 361 ;; The first Xref has to be the group this article
349 ;; really came for - this is the article nnkiboze 362 ;; really came for - this is the article nnkiboze
350 ;; will request when it is asked for the article. 363 ;; will request when it is asked for the article.
351 (insert " " group ":" 364 (insert " " group ":"
352 (int-to-string (mail-header-number header)) " ") 365 (int-to-string (mail-header-number header)) " ")
353 (while (re-search-forward " [^ ]+:[0-9]+" nil t) 366 (while (re-search-forward " [^ ]+:[0-9]+" nil t)
354 (goto-char (1+ (match-beginning 0))) 367 (goto-char (1+ (match-beginning 0)))
355 (insert prefix))))) 368 (insert prefix))
369 (mail-header-set-xref oheader (buffer-string)))
370 (nnheader-insert-nov oheader))))
356 371
357(defun nnkiboze-nov-file-name (&optional suffix) 372(defun nnkiboze-nov-file-name (&optional suffix)
358 (concat (file-name-as-directory nnkiboze-directory) 373 (concat (file-name-as-directory nnkiboze-directory)